OperatedType.hs

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

-- | The data type @OperatedType'@: a type of RPA that the operator operates, and each RPA of that type.
module ReOC.Data.OperatedType (
  OperatedType' (..),
  OperatedType'Like (..),
  lawNamesOperatedType',
  OperatedType,
  UnfilledOperatedType,
  mkUnfilledOperatedType,
  InheritOperatedType',
  inheritOperatedType',
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import Data.List.NonEmpty (NonEmpty)
import ReOC.Data.Aircraft (Aircraft, UnfilledAircraft)
import ReOC.Data.RPAType (RPAType, UnfilledRPAType, mkUnfilledRPAType)
import ReOC.Name.Airframes (AirframesLike (..))
import ReOC.Name.RpaType (RpaTypeLike (..))

-- | A type of RPA that the operator operates, and each RPA of that type. Its valid form is @OperatedType@, and its unfilled form @UnfilledOperatedType@.
data OperatedType' a1 a2 = OperatedType' a1 a2
  deriving (Eq, Ord, Show)

-- | The name of the data type @OperatedType'@.
class OperatedType'Like p f x x' a1 a1' a2 a2' | x -> a1 a2 where
  operatedType' ::
    Optic p f x x' (OperatedType' a1 a2) (OperatedType' a1' a2')

-- | Identity
instance (x' ~ OperatedType' a1' a2') => OperatedType'Like p f (OperatedType' a1 a2) x' a1 a1' a2 a2' where
  operatedType' = id

-- | Lens
instance (p ~ (->), Functor f, x' ~ OperatedType' a1' a2) => RpaTypeLike p f (OperatedType' a1 a2) x' a1 a1' where
  rpaType f (OperatedType' x1 x2) = fmap (\x1' -> OperatedType' x1' x2) (f x1)

-- | Lens
instance (p ~ (->), Functor f, x' ~ OperatedType' a1 a2') => AirframesLike p f (OperatedType' a1 a2) x' a2 a2' where
  airframes f (OperatedType' x1 x2) = fmap (OperatedType' x1) (f x2)

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

Laws:

> lawNamesOperatedType' == id
-}
lawNamesOperatedType' :: OperatedType' a1 a2 -> OperatedType' a1 a2
lawNamesOperatedType' s =
  OperatedType'
    (view (cloneLens rpaType) s)
    (view (cloneLens airframes) s)

-- | A valid @OperatedType'@.
type OperatedType = OperatedType' RPAType (NonEmpty Aircraft)

-- | An unfilled @OperatedType'@: each field holds what has been entered, if anything, to be checked by @fillOperatedType@.
type UnfilledOperatedType = OperatedType' UnfilledRPAType [UnfilledAircraft]

-- | An unfilled @OperatedType'@ with nothing entered.
mkUnfilledOperatedType :: UnfilledOperatedType
mkUnfilledOperatedType =
  OperatedType'
    mkUnfilledRPAType
    []

-- | The classes that a data type holding @OperatedType'@ in one field, or in one or more constructors, inherits.
type InheritOperatedType' s a1 a2 =
  ( OperatedType'Like (->) (Const ()) s s a1 a1 a2 a2
  , RpaTypeLike (->) (Const ()) s s a1 a1
  , AirframesLike (->) (Const ()) s s a2 a2
  )

-- | Checks that a data type inherits every class of @InheritOperatedType'@.
inheritOperatedType' :: (InheritOperatedType' s a1 a2) => proxy s -> ()
inheritOperatedType' _ = ()