Declaration.hs

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

-- | The data type @Declaration'@: who makes the declaration, and in what capacity (CASA Form 101-02, questions 31 and 32).
module ReOC.Data.Declaration (
  Declaration' (..),
  Declaration'Like (..),
  lawNamesDeclaration',
  Declaration,
  UnfilledDeclaration,
  InheritDeclaration',
  inheritDeclaration',
) where

import Control.Lens (Choice, Optic, prism, prism', review)
import Data.Functor.Const (Const)
import Data.Text (Text)
import ReOC.Data.Declarant (Declarant, UnfilledDeclarant)
import ReOC.Name.DeclaredByAgent (DeclaredByAgentLike (..))
import ReOC.Name.DeclaredByCEO (DeclaredByCEOLike (..))
import ReOC.Name.DeclaredByOther (DeclaredByOtherLike (..))
import ReOC.Name.DeclaredByResponsibleManager (DeclaredByResponsibleManagerLike (..))
import ReOC.Primitive.FormText (FormLine)

-- | Who makes the declaration, and in what capacity (CASA Form 101-02, questions 31 and 32). Its valid form is @Declaration@, and its unfilled form @UnfilledDeclaration@.
data Declaration' a1 a2 a3
  = DeclaredByCEO
  | DeclaredByResponsibleManager a1
  | DeclaredByAgent a2
  | DeclaredByOther a3
  deriving (Eq, Ord, Show)

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

-- | Identity
instance (x' ~ Declaration' a1' a2' a3') => Declaration'Like p f (Declaration' a1 a2 a3) x' a1 a1' a2 a2' a3 a3' where
  declaration' = id

-- | Prism
instance (Choice p, Applicative f, x' ~ Declaration' a1 a2 a3) => DeclaredByCEOLike p f (Declaration' a1 a2 a3) x' where
  declaredByCEO = prism' (\() -> DeclaredByCEO) (\case DeclaredByCEO -> Just (); DeclaredByResponsibleManager _ -> Nothing; DeclaredByAgent _ -> Nothing; DeclaredByOther _ -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Declaration' a1' a2 a3) => DeclaredByResponsibleManagerLike p f (Declaration' a1 a2 a3) x' a1 a1' where
  declaredByResponsibleManager = prism DeclaredByResponsibleManager (\case DeclaredByCEO -> Left DeclaredByCEO; DeclaredByResponsibleManager x -> Right x; DeclaredByAgent x -> Left (DeclaredByAgent x); DeclaredByOther x -> Left (DeclaredByOther x))

-- | Prism
instance (Choice p, Applicative f, x' ~ Declaration' a1 a2' a3) => DeclaredByAgentLike p f (Declaration' a1 a2 a3) x' a2 a2' where
  declaredByAgent = prism DeclaredByAgent (\case DeclaredByCEO -> Left DeclaredByCEO; DeclaredByResponsibleManager x -> Left (DeclaredByResponsibleManager x); DeclaredByAgent x -> Right x; DeclaredByOther x -> Left (DeclaredByOther x))

-- | Prism
instance (Choice p, Applicative f, x' ~ Declaration' a1 a2 a3') => DeclaredByOtherLike p f (Declaration' a1 a2 a3) x' a3 a3' where
  declaredByOther = prism DeclaredByOther (\case DeclaredByCEO -> Left DeclaredByCEO; DeclaredByResponsibleManager x -> Left (DeclaredByResponsibleManager x); DeclaredByAgent x -> Left (DeclaredByAgent x); DeclaredByOther x -> Right x)

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

Laws:

> lawNamesDeclaration' == id
-}
lawNamesDeclaration' :: Declaration' a1 a2 a3 -> Declaration' a1 a2 a3
lawNamesDeclaration' = \case
  DeclaredByCEO -> review declaredByCEO ()
  DeclaredByResponsibleManager x -> review declaredByResponsibleManager x
  DeclaredByAgent x -> review declaredByAgent x
  DeclaredByOther x -> review declaredByOther x

-- | A valid @Declaration'@.
type Declaration = Declaration' FormLine FormLine Declarant

-- | An unfilled @Declaration'@: each field holds what has been entered, if anything, to be checked by @fillDeclaration@.
type UnfilledDeclaration = Declaration' (Maybe Text) (Maybe Text) UnfilledDeclarant

-- | The classes that a data type holding @Declaration'@ in one field, or in one or more constructors, inherits.
type InheritDeclaration' s a1 a2 a3 =
  ( Declaration'Like (->) (Const ()) s s a1 a1 a2 a2 a3 a3
  , DeclaredByCEOLike (->) (Const ()) s s
  , DeclaredByResponsibleManagerLike (->) (Const ()) s s a1 a1
  , DeclaredByAgentLike (->) (Const ()) s s a2 a2
  , DeclaredByOtherLike (->) (Const ()) s s a3 a3
  )

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