Transponder.hs

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

-- | The data type @Transponder@: whether a type of RPA is fitted with a transponder or ADS-B (out).
module ReOC.Data.Transponder (
  Transponder (..),
  TransponderLike (..),
  lawNamesTransponder,
  InheritTransponder,
  inheritTransponder,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.NoTransponder (NoTransponderLike (..))
import ReOC.Name.TransponderFitted (TransponderFittedLike (..))

-- | Whether a type of RPA is fitted with a transponder or ADS-B (out).
data Transponder
  = NoTransponder
  | TransponderFitted
  deriving (Eq, Ord, Show)

-- | The name of the data type @Transponder@.
class TransponderLike p f x x' where
  transponder ::
    Optic p f x x' Transponder Transponder

-- | Identity
instance (x' ~ Transponder) => TransponderLike p f Transponder x' where
  transponder = id

-- | Prism
instance (Choice p, Applicative f, x' ~ Transponder) => NoTransponderLike p f Transponder x' where
  noTransponder = prism' (\() -> NoTransponder) (\case NoTransponder -> Just (); TransponderFitted -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ Transponder) => TransponderFittedLike p f Transponder x' where
  transponderFitted = prism' (\() -> TransponderFitted) (\case NoTransponder -> Nothing; TransponderFitted -> Just ())

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

Laws:

> lawNamesTransponder == id
-}
lawNamesTransponder :: Transponder -> Transponder
lawNamesTransponder = \case
  NoTransponder -> review noTransponder ()
  TransponderFitted -> review transponderFitted ()

-- | The classes that a data type holding @Transponder@ in one field, or in one or more constructors, inherits.
type InheritTransponder s =
  ( TransponderLike (->) (Const ()) s s
  , NoTransponderLike (->) (Const ()) s s
  , TransponderFittedLike (->) (Const ()) s s
  )

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