CourseType.hs

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

-- | The data type @CourseType@: a type of RePL training course (CASA Form 101-02, question 29).
module ReOC.Data.CourseType (
  CourseType (..),
  CourseTypeLike (..),
  lawNamesCourseType,
  InheritCourseType,
  inheritCourseType,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.InitialCourse (InitialCourseLike (..))
import ReOC.Name.UpgradeDifferentCategory (UpgradeDifferentCategoryLike (..))
import ReOC.Name.UpgradeSameCategory (UpgradeSameCategoryLike (..))

-- | A type of RePL training course (CASA Form 101-02, question 29).
data CourseType
  = InitialCourse
  | UpgradeSameCategory
  | UpgradeDifferentCategory
  deriving (Eq, Ord, Show)

-- | The name of the data type @CourseType@.
class CourseTypeLike p f x x' where
  courseType ::
    Optic p f x x' CourseType CourseType

-- | Identity
instance (x' ~ CourseType) => CourseTypeLike p f CourseType x' where
  courseType = id

-- | Prism
instance (Choice p, Applicative f, x' ~ CourseType) => InitialCourseLike p f CourseType x' where
  initialCourse = prism' (\() -> InitialCourse) (\case InitialCourse -> Just (); UpgradeSameCategory -> Nothing; UpgradeDifferentCategory -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ CourseType) => UpgradeSameCategoryLike p f CourseType x' where
  upgradeSameCategory = prism' (\() -> UpgradeSameCategory) (\case InitialCourse -> Nothing; UpgradeSameCategory -> Just (); UpgradeDifferentCategory -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ CourseType) => UpgradeDifferentCategoryLike p f CourseType x' where
  upgradeDifferentCategory = prism' (\() -> UpgradeDifferentCategory) (\case InitialCourse -> Nothing; UpgradeSameCategory -> Nothing; UpgradeDifferentCategory -> Just ())

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

Laws:

> lawNamesCourseType == id
-}
lawNamesCourseType :: CourseType -> CourseType
lawNamesCourseType = \case
  InitialCourse -> review initialCourse ()
  UpgradeSameCategory -> review upgradeSameCategory ()
  UpgradeDifferentCategory -> review upgradeDifferentCategory ()

-- | The classes that a data type holding @CourseType@ in one field, or in one or more constructors, inherits.
type InheritCourseType s =
  ( CourseTypeLike (->) (Const ()) s s
  , InitialCourseLike (->) (Const ()) s s
  , UpgradeSameCategoryLike (->) (Const ()) s s
  , UpgradeDifferentCategoryLike (->) (Const ()) s s
  )

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