InstructorTakeover.hs

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

-- | The data type @InstructorTakeover@: how an instructor takes immediate control of a training RPA.
module ReOC.Data.InstructorTakeover (
  InstructorTakeover (..),
  InstructorTakeoverLike (..),
  lawNamesInstructorTakeover,
  InheritInstructorTakeover,
  inheritInstructorTakeover,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.DualControllerLink (DualControllerLinkLike (..))
import ReOC.Name.SharedController (SharedControllerLike (..))

-- | How an instructor takes immediate control of a training RPA.
data InstructorTakeover
  = DualControllerLink
  | SharedController
  deriving (Eq, Ord, Show)

-- | The name of the data type @InstructorTakeover@.
class InstructorTakeoverLike p f x x' where
  instructorTakeover ::
    Optic p f x x' InstructorTakeover InstructorTakeover

-- | Identity
instance (x' ~ InstructorTakeover) => InstructorTakeoverLike p f InstructorTakeover x' where
  instructorTakeover = id

-- | Prism
instance (Choice p, Applicative f, x' ~ InstructorTakeover) => DualControllerLinkLike p f InstructorTakeover x' where
  dualControllerLink = prism' (\() -> DualControllerLink) (\case DualControllerLink -> Just (); SharedController -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ InstructorTakeover) => SharedControllerLike p f InstructorTakeover x' where
  sharedController = prism' (\() -> SharedController) (\case DualControllerLink -> Nothing; SharedController -> Just ())

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

Laws:

> lawNamesInstructorTakeover == id
-}
lawNamesInstructorTakeover :: InstructorTakeover -> InstructorTakeover
lawNamesInstructorTakeover = \case
  DualControllerLink -> review dualControllerLink ()
  SharedController -> review sharedController ()

-- | The classes that a data type holding @InstructorTakeover@ in one field, or in one or more constructors, inherits.
type InheritInstructorTakeover s =
  ( InstructorTakeoverLike (->) (Const ()) s s
  , DualControllerLinkLike (->) (Const ()) s s
  , SharedControllerLike (->) (Const ()) s s
  )

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