Aircraft.hs

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

-- | The data type @Aircraft'@: an RPA: its serial number and its associated equipment.
module ReOC.Data.Aircraft (
  Aircraft' (..),
  Aircraft'Like (..),
  lawNamesAircraft',
  Aircraft,
  UnfilledAircraft,
  mkAircraft,
  mkUnfilledAircraft,
  InheritAircraft',
  inheritAircraft',
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import Data.Text (Text)
import ReOC.Data.Equipment (Equipment, UnfilledEquipment)
import ReOC.Name.AssociatedEquipment (AssociatedEquipmentLike (..))
import ReOC.Name.SerialNumber (SerialNumberLike (..))
import ReOC.Primitive.Text1 (Text1)

-- | An RPA: its serial number and its associated equipment. Its valid form is @Aircraft@, and its unfilled form @UnfilledAircraft@.
data Aircraft' a1 a2 = Aircraft' a1 a2
  deriving (Eq, Ord, Show)

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

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

-- | Lens
instance (p ~ (->), Functor f, x' ~ Aircraft' a1' a2) => SerialNumberLike p f (Aircraft' a1 a2) x' a1 a1' where
  serialNumber f (Aircraft' x1 x2) = fmap (\x1' -> Aircraft' x1' x2) (f x1)

-- | Lens
instance (p ~ (->), Functor f, x' ~ Aircraft' a1 a2') => AssociatedEquipmentLike p f (Aircraft' a1 a2) x' a2 a2' where
  associatedEquipment f (Aircraft' x1 x2) = fmap (Aircraft' x1) (f x2)

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

Laws:

> lawNamesAircraft' == id
-}
lawNamesAircraft' :: Aircraft' a1 a2 -> Aircraft' a1 a2
lawNamesAircraft' s =
  Aircraft'
    (view (cloneLens serialNumber) s)
    (view (cloneLens associatedEquipment) s)

-- | A valid @Aircraft'@.
type Aircraft = Aircraft' Text1 [Equipment]

-- | An unfilled @Aircraft'@: each field holds what has been entered, if anything, to be checked by @fillAircraft@.
type UnfilledAircraft = Aircraft' (Maybe Text) [UnfilledEquipment]

-- | Builds a valid @Aircraft'@ with every @Maybe@ field @Nothing@ and every list (or @AtMost@) field empty.
mkAircraft :: Text1 -> Aircraft
mkAircraft x1 = Aircraft' x1 []

-- | An unfilled @Aircraft'@ with nothing entered.
mkUnfilledAircraft :: UnfilledAircraft
mkUnfilledAircraft =
  Aircraft'
    Nothing
    []

-- | The classes that a data type holding @Aircraft'@ in one field, or in one or more constructors, inherits.
type InheritAircraft' s a1 a2 =
  ( Aircraft'Like (->) (Const ()) s s a1 a1 a2 a2
  , SerialNumberLike (->) (Const ()) s s a1 a1
  , AssociatedEquipmentLike (->) (Const ()) s s a2 a2
  )

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