Risk.hs

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

-- | The data type @Risk'@: an entry in the risk register (operations manual Appendix E). It is due for review a number of months, at most 12, after it is entered.
module ReOC.Data.Risk (
  Risk' (..),
  Risk'Like (..),
  lawNamesRisk',
  Risk,
  UnfilledRisk,
  mkUnfilledRisk,
  InheritRisk',
  inheritRisk',
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import Data.Text (Text)
import Data.Time.Calendar.Month (Month)
import Numeric.Natural (Natural)
import ReOC.Data.KeyPosition (KeyPosition)
import ReOC.Data.RiskAssessment (RiskAssessment, UnfilledRiskAssessment, mkUnfilledRiskAssessment)
import ReOC.Name.AdditionalControls (AdditionalControlsLike (..))
import ReOC.Name.DateEntered (DateEnteredLike (..))
import ReOC.Name.ExistingControls (ExistingControlsLike (..))
import ReOC.Name.Hazard (HazardLike (..))
import ReOC.Name.InitialRisk (InitialRiskLike (..))
import ReOC.Name.ResidualRisk (ResidualRiskLike (..))
import ReOC.Name.ReviewMonths (ReviewMonthsLike (..))
import ReOC.Name.RiskDescription (RiskDescriptionLike (..))
import ReOC.Name.RiskOwner (RiskOwnerLike (..))
import ReOC.Primitive.ReviewMonths (ReviewMonths)
import ReOC.Primitive.Text1 (Text1)

-- | An entry in the risk register (operations manual Appendix E). It is due for review a number of months, at most 12, after it is entered. Its valid form is @Risk@, and its unfilled form @UnfilledRisk@.
data Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9 = Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9
  deriving (Eq, Ord, Show)

-- | The name of the data type @Risk'@.
class Risk'Like p f x x' a1 a1' a2 a2' a3 a3' a4 a4' a5 a5' a6 a6' a7 a7' a8 a8' a9 a9' | x -> a1 a2 a3 a4 a5 a6 a7 a8 a9 where
  risk' ::
    Optic p f x x' (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) (Risk' a1' a2' a3' a4' a5' a6' a7' a8' a9')

-- | Identity
instance (x' ~ Risk' a1' a2' a3' a4' a5' a6' a7' a8' a9') => Risk'Like p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a1 a1' a2 a2' a3 a3' a4 a4' a5 a5' a6 a6' a7 a7' a8 a8' a9 a9' where
  risk' = id

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1' a2 a3 a4 a5 a6 a7 a8 a9) => HazardLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a1 a1' where
  hazard f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (\x1' -> Risk' x1' x2 x3 x4 x5 x6 x7 x8 x9) (f x1)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1 a2' a3 a4 a5 a6 a7 a8 a9) => RiskDescriptionLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a2 a2' where
  riskDescription f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (\x2' -> Risk' x1 x2' x3 x4 x5 x6 x7 x8 x9) (f x2)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1 a2 a3' a4 a5 a6 a7 a8 a9) => ExistingControlsLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a3 a3' where
  existingControls f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (\x3' -> Risk' x1 x2 x3' x4 x5 x6 x7 x8 x9) (f x3)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1 a2 a3 a4' a5 a6 a7 a8 a9) => InitialRiskLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a4 a4' where
  initialRisk f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (\x4' -> Risk' x1 x2 x3 x4' x5 x6 x7 x8 x9) (f x4)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1 a2 a3 a4 a5' a6 a7 a8 a9) => AdditionalControlsLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a5 a5' where
  additionalControls f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (\x5' -> Risk' x1 x2 x3 x4 x5' x6 x7 x8 x9) (f x5)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1 a2 a3 a4 a5 a6' a7 a8 a9) => ResidualRiskLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a6 a6' where
  residualRisk f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (\x6' -> Risk' x1 x2 x3 x4 x5 x6' x7 x8 x9) (f x6)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1 a2 a3 a4 a5 a6 a7' a8 a9) => RiskOwnerLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a7 a7' where
  riskOwner f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (\x7' -> Risk' x1 x2 x3 x4 x5 x6 x7' x8 x9) (f x7)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1 a2 a3 a4 a5 a6 a7 a8' a9) => DateEnteredLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a8 a8' where
  dateEntered f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (\x8' -> Risk' x1 x2 x3 x4 x5 x6 x7 x8' x9) (f x8)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9') => ReviewMonthsLike p f (Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9) x' a9 a9' where
  reviewMonths f (Risk' x1 x2 x3 x4 x5 x6 x7 x8 x9) = fmap (Risk' x1 x2 x3 x4 x5 x6 x7 x8) (f x9)

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

Laws:

> lawNamesRisk' == id
-}
lawNamesRisk' :: Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9 -> Risk' a1 a2 a3 a4 a5 a6 a7 a8 a9
lawNamesRisk' s =
  Risk'
    (view (cloneLens hazard) s)
    (view (cloneLens riskDescription) s)
    (view (cloneLens existingControls) s)
    (view (cloneLens initialRisk) s)
    (view (cloneLens additionalControls) s)
    (view (cloneLens residualRisk) s)
    (view (cloneLens riskOwner) s)
    (view (cloneLens dateEntered) s)
    (view (cloneLens reviewMonths) s)

-- | A valid @Risk'@.
type Risk = Risk' Text1 Text1 Text1 RiskAssessment Text1 RiskAssessment KeyPosition Month ReviewMonths

-- | An unfilled @Risk'@: each field holds what has been entered, if anything, to be checked by @fillRisk@.
type UnfilledRisk = Risk' (Maybe Text) (Maybe Text) (Maybe Text) UnfilledRiskAssessment (Maybe Text) UnfilledRiskAssessment (Maybe KeyPosition) (Maybe Month) (Maybe Natural)

-- | An unfilled @Risk'@ with nothing entered.
mkUnfilledRisk :: UnfilledRisk
mkUnfilledRisk =
  Risk'
    Nothing
    Nothing
    Nothing
    mkUnfilledRiskAssessment
    Nothing
    mkUnfilledRiskAssessment
    Nothing
    Nothing
    Nothing

-- | The classes that a data type holding @Risk'@ in one field, or in one or more constructors, inherits.
type InheritRisk' s a1 a2 a3 a4 a5 a6 a7 a8 a9 =
  ( Risk'Like (->) (Const ()) s s a1 a1 a2 a2 a3 a3 a4 a4 a5 a5 a6 a6 a7 a7 a8 a8 a9 a9
  , HazardLike (->) (Const ()) s s a1 a1
  , RiskDescriptionLike (->) (Const ()) s s a2 a2
  , ExistingControlsLike (->) (Const ()) s s a3 a3
  , InitialRiskLike (->) (Const ()) s s a4 a4
  , AdditionalControlsLike (->) (Const ()) s s a5 a5
  , ResidualRiskLike (->) (Const ()) s s a6 a6
  , RiskOwnerLike (->) (Const ()) s s a7 a7
  , DateEnteredLike (->) (Const ()) s s a8 a8
  , ReviewMonthsLike (->) (Const ()) s s a9 a9
  )

-- | Checks that a data type inherits every class of @InheritRisk'@.
inheritRisk' :: (InheritRisk' s a1 a2 a3 a4 a5 a6 a7 a8 a9) => proxy s -> ()
inheritRisk' _ = ()