RiskAssessment.hs

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

-- | The data type @RiskAssessment'@: the likelihood and consequence of a risk. Its level is given by the risk rating matrix.
module ReOC.Data.RiskAssessment (
  RiskAssessment' (..),
  RiskAssessment'Like (..),
  lawNamesRiskAssessment',
  RiskAssessment,
  UnfilledRiskAssessment,
  mkUnfilledRiskAssessment,
  InheritRiskAssessment',
  inheritRiskAssessment',
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import ReOC.Data.Consequence (Consequence)
import ReOC.Data.Likelihood (Likelihood)
import ReOC.Name.RiskConsequence (RiskConsequenceLike (..))
import ReOC.Name.RiskLikelihood (RiskLikelihoodLike (..))

-- | The likelihood and consequence of a risk. Its level is given by the risk rating matrix. Its valid form is @RiskAssessment@, and its unfilled form @UnfilledRiskAssessment@.
data RiskAssessment' a1 a2 = RiskAssessment' a1 a2
  deriving (Eq, Ord, Show)

-- | The name of the data type @RiskAssessment'@.
class RiskAssessment'Like p f x x' a1 a1' a2 a2' | x -> a1 a2 where
  riskAssessment' ::
    Optic p f x x' (RiskAssessment' a1 a2) (RiskAssessment' a1' a2')

-- | Identity
instance (x' ~ RiskAssessment' a1' a2') => RiskAssessment'Like p f (RiskAssessment' a1 a2) x' a1 a1' a2 a2' where
  riskAssessment' = id

-- | Lens
instance (p ~ (->), Functor f, x' ~ RiskAssessment' a1' a2) => RiskLikelihoodLike p f (RiskAssessment' a1 a2) x' a1 a1' where
  riskLikelihood f (RiskAssessment' x1 x2) = fmap (\x1' -> RiskAssessment' x1' x2) (f x1)

-- | Lens
instance (p ~ (->), Functor f, x' ~ RiskAssessment' a1 a2') => RiskConsequenceLike p f (RiskAssessment' a1 a2) x' a2 a2' where
  riskConsequence f (RiskAssessment' x1 x2) = fmap (RiskAssessment' x1) (f x2)

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

Laws:

> lawNamesRiskAssessment' == id
-}
lawNamesRiskAssessment' :: RiskAssessment' a1 a2 -> RiskAssessment' a1 a2
lawNamesRiskAssessment' s =
  RiskAssessment'
    (view (cloneLens riskLikelihood) s)
    (view (cloneLens riskConsequence) s)

-- | A valid @RiskAssessment'@.
type RiskAssessment = RiskAssessment' Likelihood Consequence

-- | An unfilled @RiskAssessment'@: each field holds what has been entered, if anything, to be checked by @fillRiskAssessment@.
type UnfilledRiskAssessment = RiskAssessment' (Maybe Likelihood) (Maybe Consequence)

-- | An unfilled @RiskAssessment'@ with nothing entered.
mkUnfilledRiskAssessment :: UnfilledRiskAssessment
mkUnfilledRiskAssessment =
  RiskAssessment'
    Nothing
    Nothing

-- | The classes that a data type holding @RiskAssessment'@ in one field, or in one or more constructors, inherits.
type InheritRiskAssessment' s a1 a2 =
  ( RiskAssessment'Like (->) (Const ()) s s a1 a1 a2 a2
  , RiskLikelihoodLike (->) (Const ()) s s a1 a1
  , RiskConsequenceLike (->) (Const ()) s s a2 a2
  )

-- | Checks that a data type inherits every class of @InheritRiskAssessment'@.
inheritRiskAssessment' :: (InheritRiskAssessment' s a1 a2) => proxy s -> ()
inheritRiskAssessment' _ = ()