Directorship.hs

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

-- | The data type @Directorship@: whether the CEO is a director of the company.
module ReOC.Data.Directorship (
  Directorship (..),
  DirectorshipLike (..),
  lawNamesDirectorship,
  InheritDirectorship,
  inheritDirectorship,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.Director (DirectorLike (..))
import ReOC.Name.NotADirector (NotADirectorLike (..))
import ReOC.Name.SoleDirector (SoleDirectorLike (..))

-- | Whether the CEO is a director of the company.
data Directorship
  = SoleDirector
  | Director
  | NotADirector
  deriving (Eq, Ord, Show)

-- | The name of the data type @Directorship@.
class DirectorshipLike p f x x' where
  directorship ::
    Optic p f x x' Directorship Directorship

-- | Identity
instance (x' ~ Directorship) => DirectorshipLike p f Directorship x' where
  directorship = id

-- | Prism
instance (Choice p, Applicative f, x' ~ Directorship) => SoleDirectorLike p f Directorship x' where
  soleDirector = prism' (\() -> SoleDirector) (\case SoleDirector -> Just (); Director -> Nothing; NotADirector -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Directorship) => DirectorLike p f Directorship x' where
  director = prism' (\() -> Director) (\case SoleDirector -> Nothing; Director -> Just (); NotADirector -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Directorship) => NotADirectorLike p f Directorship x' where
  notADirector = prism' (\() -> NotADirector) (\case SoleDirector -> Nothing; Director -> Nothing; NotADirector -> Just ())

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

Laws:

> lawNamesDirectorship == id
-}
lawNamesDirectorship :: Directorship -> Directorship
lawNamesDirectorship = \case
  SoleDirector -> review soleDirector ()
  Director -> review director ()
  NotADirector -> review notADirector ()

-- | The classes that a data type holding @Directorship@ in one field, or in one or more constructors, inherits.
type InheritDirectorship s =
  ( DirectorshipLike (->) (Const ()) s s
  , SoleDirectorLike (->) (Const ()) s s
  , DirectorLike (->) (Const ()) s s
  , NotADirectorLike (->) (Const ()) s s
  )

-- | Checks that a data type inherits every class of @InheritDirectorship@.
inheritDirectorship :: (InheritDirectorship s) => proxy s -> ()
inheritDirectorship _ = ()