Crewing.hs

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

-- | The data type @Crewing@: whether the operator conducts only solo operations, or multi-crew operations as well.
module ReOC.Data.Crewing (
  Crewing (..),
  CrewingLike (..),
  lawNamesCrewing,
  InheritCrewing,
  inheritCrewing,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.SoloAndMultiCrewOperations (SoloAndMultiCrewOperationsLike (..))
import ReOC.Name.SoloOperationsOnly (SoloOperationsOnlyLike (..))

-- | Whether the operator conducts only solo operations, or multi-crew operations as well.
data Crewing
  = SoloOperationsOnly
  | SoloAndMultiCrewOperations
  deriving (Eq, Ord, Show)

-- | The name of the data type @Crewing@.
class CrewingLike p f x x' where
  crewing ::
    Optic p f x x' Crewing Crewing

-- | Identity
instance (x' ~ Crewing) => CrewingLike p f Crewing x' where
  crewing = id

-- | Prism
instance (Choice p, Applicative f, x' ~ Crewing) => SoloOperationsOnlyLike p f Crewing x' where
  soloOperationsOnly = prism' (\() -> SoloOperationsOnly) (\case SoloOperationsOnly -> Just (); SoloAndMultiCrewOperations -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Crewing) => SoloAndMultiCrewOperationsLike p f Crewing x' where
  soloAndMultiCrewOperations = prism' (\() -> SoloAndMultiCrewOperations) (\case SoloOperationsOnly -> Nothing; SoloAndMultiCrewOperations -> Just ())

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

Laws:

> lawNamesCrewing == id
-}
lawNamesCrewing :: Crewing -> Crewing
lawNamesCrewing = \case
  SoloOperationsOnly -> review soloOperationsOnly ()
  SoloAndMultiCrewOperations -> review soloAndMultiCrewOperations ()

-- | The classes that a data type holding @Crewing@ in one field, or in one or more constructors, inherits.
type InheritCrewing s =
  ( CrewingLike (->) (Const ()) s s
  , SoloOperationsOnlyLike (->) (Const ()) s s
  , SoloAndMultiCrewOperationsLike (->) (Const ()) s s
  )

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