RiskLevel.hs

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

-- | The data type @RiskLevel@: the level of a risk, given by the risk rating matrix (operations manual Appendix E, Table 12).
module ReOC.Data.RiskLevel (
  RiskLevel (..),
  RiskLevelLike (..),
  lawNamesRiskLevel,
  InheritRiskLevel,
  inheritRiskLevel,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.High (HighLike (..))
import ReOC.Name.Low (LowLike (..))
import ReOC.Name.Medium (MediumLike (..))

-- | The level of a risk, given by the risk rating matrix (operations manual Appendix E, Table 12).
data RiskLevel
  = High
  | Medium
  | Low
  deriving (Eq, Ord, Show)

-- | The name of the data type @RiskLevel@.
class RiskLevelLike p f x x' where
  riskLevel ::
    Optic p f x x' RiskLevel RiskLevel

-- | Identity
instance (x' ~ RiskLevel) => RiskLevelLike p f RiskLevel x' where
  riskLevel = id

-- | Prism
instance (Choice p, Applicative f, x' ~ RiskLevel) => HighLike p f RiskLevel x' where
  high = prism' (\() -> High) (\case High -> Just (); Medium -> Nothing; Low -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ RiskLevel) => MediumLike p f RiskLevel x' where
  medium = prism' (\() -> Medium) (\case High -> Nothing; Medium -> Just (); Low -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ RiskLevel) => LowLike p f RiskLevel x' where
  low = prism' (\() -> Low) (\case High -> Nothing; Medium -> Nothing; Low -> Just ())

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

Laws:

> lawNamesRiskLevel == id
-}
lawNamesRiskLevel :: RiskLevel -> RiskLevel
lawNamesRiskLevel = \case
  High -> review high ()
  Medium -> review medium ()
  Low -> review low ()

-- | The classes that a data type holding @RiskLevel@ in one field, or in one or more constructors, inherits.
type InheritRiskLevel s =
  ( RiskLevelLike (->) (Const ()) s s
  , HighLike (->) (Const ()) s s
  , MediumLike (->) (Const ()) s s
  , LowLike (->) (Const ()) s s
  )

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