Consequence.hs

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

-- | The data type @Consequence@: the consequence of a risk (operations manual Appendix E, Table 10).
module ReOC.Data.Consequence (
  Consequence (..),
  ConsequenceLike (..),
  lawNamesConsequence,
  InheritConsequence,
  inheritConsequence,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.Catastrophic (CatastrophicLike (..))
import ReOC.Name.Hazardous (HazardousLike (..))
import ReOC.Name.Minor (MinorLike (..))
import ReOC.Name.Moderate (ModerateLike (..))
import ReOC.Name.Negligible (NegligibleLike (..))

-- | The consequence of a risk (operations manual Appendix E, Table 10).
data Consequence
  = Catastrophic
  | Hazardous
  | Moderate
  | Minor
  | Negligible
  deriving (Eq, Ord, Show)

-- | The name of the data type @Consequence@.
class ConsequenceLike p f x x' where
  consequence ::
    Optic p f x x' Consequence Consequence

-- | Identity
instance (x' ~ Consequence) => ConsequenceLike p f Consequence x' where
  consequence = id

-- | Prism
instance (Choice p, Applicative f, x' ~ Consequence) => CatastrophicLike p f Consequence x' where
  catastrophic = prism' (\() -> Catastrophic) (\case Catastrophic -> Just (); Hazardous -> Nothing; Moderate -> Nothing; Minor -> Nothing; Negligible -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Consequence) => HazardousLike p f Consequence x' where
  hazardous = prism' (\() -> Hazardous) (\case Catastrophic -> Nothing; Hazardous -> Just (); Moderate -> Nothing; Minor -> Nothing; Negligible -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Consequence) => ModerateLike p f Consequence x' where
  moderate = prism' (\() -> Moderate) (\case Catastrophic -> Nothing; Hazardous -> Nothing; Moderate -> Just (); Minor -> Nothing; Negligible -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Consequence) => MinorLike p f Consequence x' where
  minor = prism' (\() -> Minor) (\case Catastrophic -> Nothing; Hazardous -> Nothing; Moderate -> Nothing; Minor -> Just (); Negligible -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Consequence) => NegligibleLike p f Consequence x' where
  negligible = prism' (\() -> Negligible) (\case Catastrophic -> Nothing; Hazardous -> Nothing; Moderate -> Nothing; Minor -> Nothing; Negligible -> Just ())

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

Laws:

> lawNamesConsequence == id
-}
lawNamesConsequence :: Consequence -> Consequence
lawNamesConsequence = \case
  Catastrophic -> review catastrophic ()
  Hazardous -> review hazardous ()
  Moderate -> review moderate ()
  Minor -> review minor ()
  Negligible -> review negligible ()

-- | The classes that a data type holding @Consequence@ in one field, or in one or more constructors, inherits.
type InheritConsequence s =
  ( ConsequenceLike (->) (Const ()) s s
  , CatastrophicLike (->) (Const ()) s s
  , HazardousLike (->) (Const ()) s s
  , ModerateLike (->) (Const ()) s s
  , MinorLike (->) (Const ()) s s
  , NegligibleLike (->) (Const ()) s s
  )

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