TheoryDelivery.hs

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

-- | The data type @TheoryDelivery@: how theory lessons are delivered.
module ReOC.Data.TheoryDelivery (
  TheoryDelivery (..),
  TheoryDeliveryLike (..),
  lawNamesTheoryDelivery,
  InheritTheoryDelivery,
  inheritTheoryDelivery,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.BlendedTheory (BlendedTheoryLike (..))
import ReOC.Name.ClassroomTheory (ClassroomTheoryLike (..))
import ReOC.Name.OnlineTheory (OnlineTheoryLike (..))

-- | How theory lessons are delivered.
data TheoryDelivery
  = ClassroomTheory
  | BlendedTheory
  | OnlineTheory
  deriving (Eq, Ord, Show)

-- | The name of the data type @TheoryDelivery@.
class TheoryDeliveryLike p f x x' where
  theoryDelivery ::
    Optic p f x x' TheoryDelivery TheoryDelivery

-- | Identity
instance (x' ~ TheoryDelivery) => TheoryDeliveryLike p f TheoryDelivery x' where
  theoryDelivery = id

-- | Prism
instance (Choice p, Applicative f, x' ~ TheoryDelivery) => ClassroomTheoryLike p f TheoryDelivery x' where
  classroomTheory = prism' (\() -> ClassroomTheory) (\case ClassroomTheory -> Just (); BlendedTheory -> Nothing; OnlineTheory -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ TheoryDelivery) => BlendedTheoryLike p f TheoryDelivery x' where
  blendedTheory = prism' (\() -> BlendedTheory) (\case ClassroomTheory -> Nothing; BlendedTheory -> Just (); OnlineTheory -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ TheoryDelivery) => OnlineTheoryLike p f TheoryDelivery x' where
  onlineTheory = prism' (\() -> OnlineTheory) (\case ClassroomTheory -> Nothing; BlendedTheory -> Nothing; OnlineTheory -> Just ())

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

Laws:

> lawNamesTheoryDelivery == id
-}
lawNamesTheoryDelivery :: TheoryDelivery -> TheoryDelivery
lawNamesTheoryDelivery = \case
  ClassroomTheory -> review classroomTheory ()
  BlendedTheory -> review blendedTheory ()
  OnlineTheory -> review onlineTheory ()

-- | The classes that a data type holding @TheoryDelivery@ in one field, or in one or more constructors, inherits.
type InheritTheoryDelivery s =
  ( TheoryDeliveryLike (->) (Const ()) s s
  , ClassroomTheoryLike (->) (Const ()) s s
  , BlendedTheoryLike (->) (Const ()) s s
  , OnlineTheoryLike (->) (Const ()) s s
  )

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