HistoryAnswer.hs

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

-- | The data type @HistoryAnswer'@: an answer about the history of the applicant and nominated personnel, with the details where the answer is yes (CASA Form 101-02, questions 19 to 23). The details of all four answers share the box of question 23.
module ReOC.Data.HistoryAnswer (
  HistoryAnswer' (..),
  HistoryAnswer'Like (..),
  lawNamesHistoryAnswer',
  HistoryAnswer,
  UnfilledHistoryAnswer,
  InheritHistoryAnswer',
  inheritHistoryAnswer',
) where

import Control.Lens (Choice, Optic, prism, prism', review)
import Data.Functor.Const (Const)
import Data.Text (Text)
import ReOC.Name.HistoryDisclosed (HistoryDisclosedLike (..))
import ReOC.Name.NoHistory (NoHistoryLike (..))
import ReOC.Primitive.FormText (FormFont (..), FormText)

-- | An answer about the history of the applicant and nominated personnel, with the details where the answer is yes (CASA Form 101-02, questions 19 to 23). The details of all four answers share the box of question 23. Its valid form is @HistoryAnswer@, and its unfilled form @UnfilledHistoryAnswer@.
data HistoryAnswer' a1
  = NoHistory
  | HistoryDisclosed a1
  deriving (Eq, Ord, Show)

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

-- | Identity
instance (x' ~ HistoryAnswer' a1') => HistoryAnswer'Like p f (HistoryAnswer' a1) x' a1 a1' where
  historyAnswer' = id

-- | Prism
instance (Choice p, Applicative f, x' ~ HistoryAnswer' a1) => NoHistoryLike p f (HistoryAnswer' a1) x' where
  noHistory = prism' (\() -> NoHistory) (\case NoHistory -> Just (); HistoryDisclosed _ -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ HistoryAnswer' a1') => HistoryDisclosedLike p f (HistoryAnswer' a1) x' a1 a1' where
  historyDisclosed = prism HistoryDisclosed (\case NoHistory -> Left NoHistory; HistoryDisclosed x -> Right x)

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

Laws:

> lawNamesHistoryAnswer' == id
-}
lawNamesHistoryAnswer' :: HistoryAnswer' a1 -> HistoryAnswer' a1
lawNamesHistoryAnswer' = \case
  NoHistory -> review noHistory ()
  HistoryDisclosed x -> review historyDisclosed x

-- | A valid @HistoryAnswer'@.
type HistoryAnswer = HistoryAnswer' (FormText 'Narrow 190 3)

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

-- | The classes that a data type holding @HistoryAnswer'@ in one field, or in one or more constructors, inherits.
type InheritHistoryAnswer' s a1 =
  ( HistoryAnswer'Like (->) (Const ()) s s a1 a1
  , NoHistoryLike (->) (Const ()) s s
  , HistoryDisclosedLike (->) (Const ()) s s a1 a1
  )

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