TooMany.hs

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

-- | The data type @TooMany@: a list field filled in with more elements than it holds, at its path: the most it holds, and the number given.
module ReOC.Data.TooMany (
  TooMany (..),
  TooManyLike (..),
  lawNamesTooMany,
  InheritTooMany,
  inheritTooMany,
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import Numeric.Natural (Natural)
import ReOC.Data.Step (Step)
import ReOC.Name.GivenElements (GivenElementsLike (..))
import ReOC.Name.MostElements (MostElementsLike (..))
import ReOC.Name.Path (PathLike (..))

-- | A list field filled in with more elements than it holds, at its path: the most it holds, and the number given.
data TooMany = TooMany [Step] Natural Natural
  deriving (Eq, Ord, Show)

-- | The name of the data type @TooMany@.
class TooManyLike p f x x' where
  tooMany ::
    Optic p f x x' TooMany TooMany

-- | Identity
instance (x' ~ TooMany) => TooManyLike p f TooMany x' where
  tooMany = id

-- | Lens
instance (p ~ (->), Functor f, x' ~ TooMany) => PathLike p f TooMany x' where
  path f (TooMany x1 x2 x3) = fmap (\x1' -> TooMany x1' x2 x3) (f x1)

-- | Lens
instance (p ~ (->), Functor f, x' ~ TooMany) => MostElementsLike p f TooMany x' where
  mostElements f (TooMany x1 x2 x3) = fmap (\x2' -> TooMany x1 x2' x3) (f x2)

-- | Lens
instance (p ~ (->), Functor f, x' ~ TooMany) => GivenElementsLike p f TooMany x' where
  givenElements f (TooMany x1 x2 x3) = fmap (TooMany x1 x2) (f x3)

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

Laws:

> lawNamesTooMany == id
-}
lawNamesTooMany :: TooMany -> TooMany
lawNamesTooMany s =
  TooMany
    (view (cloneLens path) s)
    (view (cloneLens mostElements) s)
    (view (cloneLens givenElements) s)

-- | The classes that a data type holding @TooMany@ in one field, or in one or more constructors, inherits.
type InheritTooMany s =
  ( TooManyLike (->) (Const ()) s s
  , PathLike (->) (Const ()) s s
  , MostElementsLike (->) (Const ()) s s
  , GivenElementsLike (->) (Const ()) s s
  )

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