ExamDelivery.hs

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

-- | The data type @ExamDelivery@: how a supervised theory examination is sat.
module ReOC.Data.ExamDelivery (
  ExamDelivery (..),
  ExamDeliveryLike (..),
  lawNamesExamDelivery,
  InheritExamDelivery,
  inheritExamDelivery,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.ComputerExamination (ComputerExaminationLike (..))
import ReOC.Name.PaperExamination (PaperExaminationLike (..))

-- | How a supervised theory examination is sat.
data ExamDelivery
  = PaperExamination
  | ComputerExamination
  deriving (Eq, Ord, Show)

-- | The name of the data type @ExamDelivery@.
class ExamDeliveryLike p f x x' where
  examDelivery ::
    Optic p f x x' ExamDelivery ExamDelivery

-- | Identity
instance (x' ~ ExamDelivery) => ExamDeliveryLike p f ExamDelivery x' where
  examDelivery = id

-- | Prism
instance (Choice p, Applicative f, x' ~ ExamDelivery) => PaperExaminationLike p f ExamDelivery x' where
  paperExamination = prism' (\() -> PaperExamination) (\case PaperExamination -> Just (); ComputerExamination -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ ExamDelivery) => ComputerExaminationLike p f ExamDelivery x' where
  computerExamination = prism' (\() -> ComputerExamination) (\case PaperExamination -> Nothing; ComputerExamination -> Just ())

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

Laws:

> lawNamesExamDelivery == id
-}
lawNamesExamDelivery :: ExamDelivery -> ExamDelivery
lawNamesExamDelivery = \case
  PaperExamination -> review paperExamination ()
  ComputerExamination -> review computerExamination ()

-- | The classes that a data type holding @ExamDelivery@ in one field, or in one or more constructors, inherits.
type InheritExamDelivery s =
  ( ExamDeliveryLike (->) (Const ()) s s
  , PaperExaminationLike (->) (Const ()) s s
  , ComputerExaminationLike (->) (Const ()) s s
  )

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