Likelihood.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall #-}
-- The checks of inheritance (inheritLikelihood) have a constraint that their body does not use, by design.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | The data type @Likelihood@: the likelihood of a risk (operations manual Appendix E, Table 11).
module ReOC.Data.Likelihood (
  Likelihood (..),
  LikelihoodLike (..),
  lawNamesLikelihood,
  InheritLikelihood,
  inheritLikelihood,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.ExtremelyImprobable (ExtremelyImprobableLike (..))
import ReOC.Name.Frequent (FrequentLike (..))
import ReOC.Name.Improbable (ImprobableLike (..))
import ReOC.Name.Occasional (OccasionalLike (..))
import ReOC.Name.Remote (RemoteLike (..))

-- | The likelihood of a risk (operations manual Appendix E, Table 11).
data Likelihood
  = Frequent
  | Occasional
  | Remote
  | Improbable
  | ExtremelyImprobable
  deriving (Eq, Ord, Show)

-- | The name of the data type @Likelihood@.
class LikelihoodLike p f x x' where
  likelihood ::
    Optic p f x x' Likelihood Likelihood

-- | Identity
instance (x' ~ Likelihood) => LikelihoodLike p f Likelihood x' where
  likelihood = id

-- | Prism
instance (Choice p, Applicative f, x' ~ Likelihood) => FrequentLike p f Likelihood x' where
  frequent = prism' (\() -> Frequent) (\case Frequent -> Just (); Occasional -> Nothing; Remote -> Nothing; Improbable -> Nothing; ExtremelyImprobable -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Likelihood) => OccasionalLike p f Likelihood x' where
  occasional = prism' (\() -> Occasional) (\case Frequent -> Nothing; Occasional -> Just (); Remote -> Nothing; Improbable -> Nothing; ExtremelyImprobable -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Likelihood) => RemoteLike p f Likelihood x' where
  remote = prism' (\() -> Remote) (\case Frequent -> Nothing; Occasional -> Nothing; Remote -> Just (); Improbable -> Nothing; ExtremelyImprobable -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Likelihood) => ImprobableLike p f Likelihood x' where
  improbable = prism' (\() -> Improbable) (\case Frequent -> Nothing; Occasional -> Nothing; Remote -> Nothing; Improbable -> Just (); ExtremelyImprobable -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Likelihood) => ExtremelyImprobableLike p f Likelihood x' where
  extremelyImprobable = prism' (\() -> ExtremelyImprobable) (\case Frequent -> Nothing; Occasional -> Nothing; Remote -> Nothing; Improbable -> Nothing; ExtremelyImprobable -> Just ())

{- | Rebuilds a value from the name of each field or constructor.

Laws:

> lawNamesLikelihood == id
-}
lawNamesLikelihood :: Likelihood -> Likelihood
lawNamesLikelihood = \case
  Frequent -> review frequent ()
  Occasional -> review occasional ()
  Remote -> review remote ()
  Improbable -> review improbable ()
  ExtremelyImprobable -> review extremelyImprobable ()

-- | The classes that a data type holding @Likelihood@ in one field, or in one or more constructors, inherits.
type InheritLikelihood s =
  ( LikelihoodLike (->) (Const ()) s s
  , FrequentLike (->) (Const ()) s s
  , OccasionalLike (->) (Const ()) s s
  , RemoteLike (->) (Const ()) s s
  , ImprobableLike (->) (Const ()) s s
  , ExtremelyImprobableLike (->) (Const ()) s s
  )

-- | Checks that a data type inherits every class of @InheritLikelihood@.
inheritLikelihood :: (InheritLikelihood s) => proxy s -> ()
inheritLikelihood _ = ()