PrimaryContact.hs

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

-- | The data type @PrimaryContact'@: who is the primary contact for the application (CASA Form 101-02, questions 2 and 3).
module ReOC.Data.PrimaryContact (
  PrimaryContact' (..),
  PrimaryContact'Like (..),
  lawNamesPrimaryContact',
  PrimaryContact,
  UnfilledPrimaryContact,
  InheritPrimaryContact',
  inheritPrimaryContact',
) where

import Control.Lens (Choice, Optic, prism, prism', review)
import Data.Functor.Const (Const)
import ReOC.Data.ContactPerson (ContactPerson, UnfilledContactPerson)
import ReOC.Name.ApplicantIsPrimaryContact (ApplicantIsPrimaryContactLike (..))
import ReOC.Name.PrimaryContactPerson (PrimaryContactPersonLike (..))

-- | Who is the primary contact for the application (CASA Form 101-02, questions 2 and 3). Its valid form is @PrimaryContact@, and its unfilled form @UnfilledPrimaryContact@.
data PrimaryContact' a1
  = ApplicantIsPrimaryContact
  | PrimaryContactPerson a1
  deriving (Eq, Ord, Show)

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

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

-- | Prism
instance (Choice p, Applicative f, x' ~ PrimaryContact' a1) => ApplicantIsPrimaryContactLike p f (PrimaryContact' a1) x' where
  applicantIsPrimaryContact = prism' (\() -> ApplicantIsPrimaryContact) (\case ApplicantIsPrimaryContact -> Just (); PrimaryContactPerson _ -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ PrimaryContact' a1') => PrimaryContactPersonLike p f (PrimaryContact' a1) x' a1 a1' where
  primaryContactPerson = prism PrimaryContactPerson (\case ApplicantIsPrimaryContact -> Left ApplicantIsPrimaryContact; PrimaryContactPerson x -> Right x)

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

Laws:

> lawNamesPrimaryContact' == id
-}
lawNamesPrimaryContact' :: PrimaryContact' a1 -> PrimaryContact' a1
lawNamesPrimaryContact' = \case
  ApplicantIsPrimaryContact -> review applicantIsPrimaryContact ()
  PrimaryContactPerson x -> review primaryContactPerson x

-- | A valid @PrimaryContact'@.
type PrimaryContact = PrimaryContact' ContactPerson

-- | An unfilled @PrimaryContact'@: each field holds what has been entered, if anything, to be checked by @fillPrimaryContact@.
type UnfilledPrimaryContact = PrimaryContact' UnfilledContactPerson

-- | The classes that a data type holding @PrimaryContact'@ in one field, or in one or more constructors, inherits.
type InheritPrimaryContact' s a1 =
  ( PrimaryContact'Like (->) (Const ()) s s a1 a1
  , ApplicantIsPrimaryContactLike (->) (Const ()) s s
  , PrimaryContactPersonLike (->) (Const ()) s s a1 a1
  )

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