ReOC.hs

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

-- | The data type @ReOC'@: an application for the initial issue of a ReOC: the operator, the answers to the application form, the operations manual, and RePL training if it is applied for.
module ReOC.Data.ReOC (
  ReOC' (..),
  ReOC'Like (..),
  lawNamesReOC',
  ReOC,
  UnfilledReOC,
  mkReOC,
  mkUnfilledReOC,
  InheritReOC',
  inheritReOC',
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import ReOC.Data.ApplicationForm (ApplicationForm, UnfilledApplicationForm, mkUnfilledApplicationForm)
import ReOC.Data.OperationsManual (OperationsManual, UnfilledOperationsManual, mkUnfilledOperationsManual)
import ReOC.Data.Operator (Operator, UnfilledOperator, mkUnfilledOperator)
import ReOC.Data.TrainingMaterial (TrainingMaterial, UnfilledTrainingMaterial)
import ReOC.Name.ApplicationForm (ApplicationFormLike (..))
import ReOC.Name.MaybeTrainingMaterial (MaybeTrainingMaterialLike (..))
import ReOC.Name.OperationsManual (OperationsManualLike (..))
import ReOC.Name.Operator (OperatorLike (..))

-- | An application for the initial issue of a ReOC: the operator, the answers to the application form, the operations manual, and RePL training if it is applied for. Its valid form is @ReOC@, and its unfilled form @UnfilledReOC@.
data ReOC' a1 a2 a3 a4 = ReOC' a1 a2 a3 a4
  deriving (Eq, Ord, Show)

-- | The name of the data type @ReOC'@.
class ReOC'Like p f x x' a1 a1' a2 a2' a3 a3' a4 a4' | x -> a1 a2 a3 a4 where
  reOC' ::
    Optic p f x x' (ReOC' a1 a2 a3 a4) (ReOC' a1' a2' a3' a4')

-- | Identity
instance (x' ~ ReOC' a1' a2' a3' a4') => ReOC'Like p f (ReOC' a1 a2 a3 a4) x' a1 a1' a2 a2' a3 a3' a4 a4' where
  reOC' = id

-- | Lens
instance (p ~ (->), Functor f, x' ~ ReOC' a1' a2 a3 a4) => OperatorLike p f (ReOC' a1 a2 a3 a4) x' a1 a1' where
  operator f (ReOC' x1 x2 x3 x4) = fmap (\x1' -> ReOC' x1' x2 x3 x4) (f x1)

-- | Lens
instance (p ~ (->), Functor f, x' ~ ReOC' a1 a2' a3 a4) => ApplicationFormLike p f (ReOC' a1 a2 a3 a4) x' a2 a2' where
  applicationForm f (ReOC' x1 x2 x3 x4) = fmap (\x2' -> ReOC' x1 x2' x3 x4) (f x2)

-- | Lens
instance (p ~ (->), Functor f, x' ~ ReOC' a1 a2 a3' a4) => OperationsManualLike p f (ReOC' a1 a2 a3 a4) x' a3 a3' where
  operationsManual f (ReOC' x1 x2 x3 x4) = fmap (\x3' -> ReOC' x1 x2 x3' x4) (f x3)

-- | Lens
instance (p ~ (->), Functor f, x' ~ ReOC' a1 a2 a3 a4') => MaybeTrainingMaterialLike p f (ReOC' a1 a2 a3 a4) x' a4 a4' where
  maybeTrainingMaterial f (ReOC' x1 x2 x3 x4) = fmap (ReOC' x1 x2 x3) (f x4)

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

Laws:

> lawNamesReOC' == id
-}
lawNamesReOC' :: ReOC' a1 a2 a3 a4 -> ReOC' a1 a2 a3 a4
lawNamesReOC' s =
  ReOC'
    (view (cloneLens operator) s)
    (view (cloneLens applicationForm) s)
    (view (cloneLens operationsManual) s)
    (view (cloneLens maybeTrainingMaterial) s)

-- | A valid @ReOC'@.
type ReOC = ReOC' Operator ApplicationForm OperationsManual (Maybe TrainingMaterial)

-- | An unfilled @ReOC'@: each field holds what has been entered, if anything, to be checked by @fillReOC@.
type UnfilledReOC = ReOC' UnfilledOperator UnfilledApplicationForm UnfilledOperationsManual (Maybe UnfilledTrainingMaterial)

-- | Builds a valid @ReOC'@ with every @Maybe@ field @Nothing@ and every list (or @AtMost@) field empty.
mkReOC :: Operator -> ApplicationForm -> OperationsManual -> ReOC
mkReOC x1 x2 x3 = ReOC' x1 x2 x3 Nothing

-- | An unfilled @ReOC'@ with nothing entered.
mkUnfilledReOC :: UnfilledReOC
mkUnfilledReOC =
  ReOC'
    mkUnfilledOperator
    mkUnfilledApplicationForm
    mkUnfilledOperationsManual
    Nothing

-- | The classes that a data type holding @ReOC'@ in one field, or in one or more constructors, inherits.
type InheritReOC' s a1 a2 a3 a4 =
  ( ReOC'Like (->) (Const ()) s s a1 a1 a2 a2 a3 a3 a4 a4
  , OperatorLike (->) (Const ()) s s a1 a1
  , ApplicationFormLike (->) (Const ()) s s a2 a2
  , OperationsManualLike (->) (Const ()) s s a3 a3
  , MaybeTrainingMaterialLike (->) (Const ()) s s a4 a4
  )

-- | Checks that a data type inherits every class of @InheritReOC'@.
inheritReOC' :: (InheritReOC' s a1 a2 a3 a4) => proxy s -> ()
inheritReOC' _ = ()