Declarant.hs

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

-- | The data type @Declarant'@: a person who makes the declaration in another capacity, with that capacity (CASA Form 101-02, question 32).
module ReOC.Data.Declarant (
  Declarant' (..),
  Declarant'Like (..),
  lawNamesDeclarant',
  Declarant,
  UnfilledDeclarant,
  mkUnfilledDeclarant,
  InheritDeclarant',
  inheritDeclarant',
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import Data.Text (Text)
import ReOC.Name.FullName (FullNameLike (..))
import ReOC.Name.Role (RoleLike (..))
import ReOC.Primitive.FormText (FormLine)

-- | A person who makes the declaration in another capacity, with that capacity (CASA Form 101-02, question 32). Its valid form is @Declarant@, and its unfilled form @UnfilledDeclarant@.
data Declarant' a1 a2 = Declarant' a1 a2
  deriving (Eq, Ord, Show)

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

-- | Identity
instance (x' ~ Declarant' a1' a2') => Declarant'Like p f (Declarant' a1 a2) x' a1 a1' a2 a2' where
  declarant' = id

-- | Lens
instance (p ~ (->), Functor f, x' ~ Declarant' a1' a2) => FullNameLike p f (Declarant' a1 a2) x' a1 a1' where
  fullName f (Declarant' x1 x2) = fmap (\x1' -> Declarant' x1' x2) (f x1)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Declarant' a1 a2') => RoleLike p f (Declarant' a1 a2) x' a2 a2' where
  role f (Declarant' x1 x2) = fmap (Declarant' x1) (f x2)

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

Laws:

> lawNamesDeclarant' == id
-}
lawNamesDeclarant' :: Declarant' a1 a2 -> Declarant' a1 a2
lawNamesDeclarant' s =
  Declarant'
    (view (cloneLens fullName) s)
    (view (cloneLens role) s)

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

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

-- | An unfilled @Declarant'@ with nothing entered.
mkUnfilledDeclarant :: UnfilledDeclarant
mkUnfilledDeclarant =
  Declarant'
    Nothing
    Nothing

-- | The classes that a data type holding @Declarant'@ in one field, or in one or more constructors, inherits.
type InheritDeclarant' s a1 a2 =
  ( Declarant'Like (->) (Const ()) s s a1 a1 a2 a2
  , FullNameLike (->) (Const ()) s s a1 a1
  , RoleLike (->) (Const ()) s s a2 a2
  )

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