Person.hs

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

-- | The data type @Person'@: a person: their full name, aviation reference number and contact details.
module ReOC.Data.Person (
  Person' (..),
  Person'Like (..),
  lawNamesPerson',
  Person,
  UnfilledPerson,
  mkUnfilledPerson,
  InheritPerson',
  inheritPerson',
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import Data.Text (Text)
import ReOC.Name.Arn (ArnLike (..))
import ReOC.Name.EmailAddress (EmailAddressLike (..))
import ReOC.Name.FullName (FullNameLike (..))
import ReOC.Name.PhoneNumber (PhoneNumberLike (..))
import ReOC.Primitive.ARN (ARN)
import ReOC.Primitive.EmailAddress (EmailAddress)
import ReOC.Primitive.FormText (FormLine)
import ReOC.Primitive.PhoneNumber (PhoneNumber)

-- | A person: their full name, aviation reference number and contact details. Its valid form is @Person@, and its unfilled form @UnfilledPerson@.
data Person' a1 a2 a3 a4 = Person' a1 a2 a3 a4
  deriving (Eq, Ord, Show)

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

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

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

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

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

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

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

Laws:

> lawNamesPerson' == id
-}
lawNamesPerson' :: Person' a1 a2 a3 a4 -> Person' a1 a2 a3 a4
lawNamesPerson' s =
  Person'
    (view (cloneLens fullName) s)
    (view (cloneLens arn) s)
    (view (cloneLens phoneNumber) s)
    (view (cloneLens emailAddress) s)

-- | A valid @Person'@.
type Person = Person' FormLine ARN PhoneNumber EmailAddress

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

-- | An unfilled @Person'@ with nothing entered.
mkUnfilledPerson :: UnfilledPerson
mkUnfilledPerson =
  Person'
    Nothing
    Nothing
    Nothing
    Nothing

-- | The classes that a data type holding @Person'@ in one field, or in one or more constructors, inherits.
type InheritPerson' s a1 a2 a3 a4 =
  ( Person'Like (->) (Const ()) s s a1 a1 a2 a2 a3 a3 a4 a4
  , FullNameLike (->) (Const ()) s s a1 a1
  , ArnLike (->) (Const ()) s s a2 a2
  , PhoneNumberLike (->) (Const ()) s s a3 a3
  , EmailAddressLike (->) (Const ()) s s a4 a4
  )

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