RemotePilots.hs

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

-- | The data type @RemotePilots@: whether the chief remote pilot is the operator’s only remote pilot.
module ReOC.Data.RemotePilots (
  RemotePilots (..),
  RemotePilotsLike (..),
  lawNamesRemotePilots,
  InheritRemotePilots,
  inheritRemotePilots,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.CrpIsOnlyRemotePilot (CrpIsOnlyRemotePilotLike (..))
import ReOC.Name.OtherRemotePilots (OtherRemotePilotsLike (..))

-- | Whether the chief remote pilot is the operator’s only remote pilot.
data RemotePilots
  = CRPIsOnlyRemotePilot
  | OtherRemotePilots
  deriving (Eq, Ord, Show)

-- | The name of the data type @RemotePilots@.
class RemotePilotsLike p f x x' where
  remotePilots ::
    Optic p f x x' RemotePilots RemotePilots

-- | Identity
instance (x' ~ RemotePilots) => RemotePilotsLike p f RemotePilots x' where
  remotePilots = id

-- | Prism
instance (Choice p, Applicative f, x' ~ RemotePilots) => CrpIsOnlyRemotePilotLike p f RemotePilots x' where
  crpIsOnlyRemotePilot = prism' (\() -> CRPIsOnlyRemotePilot) (\case CRPIsOnlyRemotePilot -> Just (); OtherRemotePilots -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ RemotePilots) => OtherRemotePilotsLike p f RemotePilots x' where
  otherRemotePilots = prism' (\() -> OtherRemotePilots) (\case CRPIsOnlyRemotePilot -> Nothing; OtherRemotePilots -> Just ())

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

Laws:

> lawNamesRemotePilots == id
-}
lawNamesRemotePilots :: RemotePilots -> RemotePilots
lawNamesRemotePilots = \case
  CRPIsOnlyRemotePilot -> review crpIsOnlyRemotePilot ()
  OtherRemotePilots -> review otherRemotePilots ()

-- | The classes that a data type holding @RemotePilots@ in one field, or in one or more constructors, inherits.
type InheritRemotePilots s =
  ( RemotePilotsLike (->) (Const ()) s s
  , CrpIsOnlyRemotePilotLike (->) (Const ()) s s
  , OtherRemotePilotsLike (->) (Const ()) s s
  )

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