KeyPosition.hs

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

-- | The data type @KeyPosition@: a key position of the operator that can own a risk.
module ReOC.Data.KeyPosition (
  KeyPosition (..),
  KeyPositionLike (..),
  lawNamesKeyPosition,
  InheritKeyPosition,
  inheritKeyPosition,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.ChiefExecutiveOfficer (ChiefExecutiveOfficerLike (..))
import ReOC.Name.ChiefRemotePilot (ChiefRemotePilotLike (..))
import ReOC.Name.MaintenanceController (MaintenanceControllerLike (..))

-- | A key position of the operator that can own a risk.
data KeyPosition
  = ChiefExecutiveOfficer
  | ChiefRemotePilot
  | MaintenanceController
  deriving (Eq, Ord, Show)

-- | The name of the data type @KeyPosition@.
class KeyPositionLike p f x x' where
  keyPosition ::
    Optic p f x x' KeyPosition KeyPosition

-- | Identity
instance (x' ~ KeyPosition) => KeyPositionLike p f KeyPosition x' where
  keyPosition = id

-- | Prism
instance (Choice p, Applicative f, x' ~ KeyPosition) => ChiefExecutiveOfficerLike p f KeyPosition x' where
  chiefExecutiveOfficer = prism' (\() -> ChiefExecutiveOfficer) (\case ChiefExecutiveOfficer -> Just (); ChiefRemotePilot -> Nothing; MaintenanceController -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ KeyPosition) => ChiefRemotePilotLike p f KeyPosition x' where
  chiefRemotePilot = prism' (\() -> ChiefRemotePilot) (\case ChiefExecutiveOfficer -> Nothing; ChiefRemotePilot -> Just (); MaintenanceController -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ KeyPosition) => MaintenanceControllerLike p f KeyPosition x' where
  maintenanceController = prism' (\() -> MaintenanceController) (\case ChiefExecutiveOfficer -> Nothing; ChiefRemotePilot -> Nothing; MaintenanceController -> Just ())

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

Laws:

> lawNamesKeyPosition == id
-}
lawNamesKeyPosition :: KeyPosition -> KeyPosition
lawNamesKeyPosition = \case
  ChiefExecutiveOfficer -> review chiefExecutiveOfficer ()
  ChiefRemotePilot -> review chiefRemotePilot ()
  MaintenanceController -> review maintenanceController ()

-- | The classes that a data type holding @KeyPosition@ in one field, or in one or more constructors, inherits.
type InheritKeyPosition s =
  ( KeyPositionLike (->) (Const ()) s s
  , ChiefExecutiveOfficerLike (->) (Const ()) s s
  , ChiefRemotePilotLike (->) (Const ()) s s
  , MaintenanceControllerLike (->) (Const ()) s s
  )

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