RPACategory.hs

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

-- | The data type @RPACategory@: a category of remotely piloted aircraft (CASA Form 101-02, questions 27 and 29). The operations manual does not cover airships.
module ReOC.Data.RPACategory (
  RPACategory (..),
  RPACategoryLike (..),
  lawNamesRPACategory,
  InheritRPACategory,
  inheritRPACategory,
) where

import Control.Lens (Choice, Optic, prism', review)
import Data.Functor.Const (Const)
import ReOC.Name.Aeroplane (AeroplaneLike (..))
import ReOC.Name.Helicopter (HelicopterLike (..))
import ReOC.Name.Multirotor (MultirotorLike (..))
import ReOC.Name.PoweredLift (PoweredLiftLike (..))

-- | A category of remotely piloted aircraft (CASA Form 101-02, questions 27 and 29). The operations manual does not cover airships.
data RPACategory
  = Aeroplane
  | Helicopter
  | Multirotor
  | PoweredLift
  deriving (Eq, Ord, Show)

-- | The name of the data type @RPACategory@.
class RPACategoryLike p f x x' where
  rpaCategory ::
    Optic p f x x' RPACategory RPACategory

-- | Identity
instance (x' ~ RPACategory) => RPACategoryLike p f RPACategory x' where
  rpaCategory = id

-- | Prism
instance (Choice p, Applicative f, x' ~ RPACategory) => AeroplaneLike p f RPACategory x' where
  aeroplane = prism' (\() -> Aeroplane) (\case Aeroplane -> Just (); Helicopter -> Nothing; Multirotor -> Nothing; PoweredLift -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ RPACategory) => HelicopterLike p f RPACategory x' where
  helicopter = prism' (\() -> Helicopter) (\case Aeroplane -> Nothing; Helicopter -> Just (); Multirotor -> Nothing; PoweredLift -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ RPACategory) => MultirotorLike p f RPACategory x' where
  multirotor = prism' (\() -> Multirotor) (\case Aeroplane -> Nothing; Helicopter -> Nothing; Multirotor -> Just (); PoweredLift -> Nothing)

-- | Prism
instance (Choice p, Applicative f, x' ~ RPACategory) => PoweredLiftLike p f RPACategory x' where
  poweredLift = prism' (\() -> PoweredLift) (\case Aeroplane -> Nothing; Helicopter -> Nothing; Multirotor -> Nothing; PoweredLift -> Just ())

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

Laws:

> lawNamesRPACategory == id
-}
lawNamesRPACategory :: RPACategory -> RPACategory
lawNamesRPACategory = \case
  Aeroplane -> review aeroplane ()
  Helicopter -> review helicopter ()
  Multirotor -> review multirotor ()
  PoweredLift -> review poweredLift ()

-- | The classes that a data type holding @RPACategory@ in one field, or in one or more constructors, inherits.
type InheritRPACategory s =
  ( RPACategoryLike (->) (Const ()) s s
  , AeroplaneLike (->) (Const ()) s s
  , HelicopterLike (->) (Const ()) s s
  , MultirotorLike (->) (Const ()) s s
  , PoweredLiftLike (->) (Const ()) s s
  )

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