Invalid.hs

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

-- | The data type @Invalid@: a field filled in with a value it does not accept, at its path.
module ReOC.Data.Invalid (
  Invalid (..),
  InvalidLike (..),
  lawNamesInvalid,
  InheritInvalid,
  inheritInvalid,
  inheritsInvalid,
) where

import Control.Lens (Optic, cloneLens, view)
import Data.Functor.Const (Const)
import Data.Proxy (Proxy (..))
import ReOC.Data.InvalidValue (InvalidValue, InvalidValueLike (..), inheritInvalidValue)
import ReOC.Data.Step (Step)
import ReOC.Name.InvalidABN (InvalidABNLike (..))
import ReOC.Name.InvalidARN (InvalidARNLike (..))
import ReOC.Name.InvalidEmailAddress (InvalidEmailAddressLike (..))
import ReOC.Name.InvalidFormText (InvalidFormTextLike (..))
import ReOC.Name.InvalidGrossWeight (InvalidGrossWeightLike (..))
import ReOC.Name.InvalidPassMark (InvalidPassMarkLike (..))
import ReOC.Name.InvalidPercentage (InvalidPercentageLike (..))
import ReOC.Name.InvalidPhoneNumber (InvalidPhoneNumberLike (..))
import ReOC.Name.InvalidPositive (InvalidPositiveLike (..))
import ReOC.Name.InvalidPostcode (InvalidPostcodeLike (..))
import ReOC.Name.InvalidReviewMonths (InvalidReviewMonthsLike (..))
import ReOC.Name.InvalidText1 (InvalidText1Like (..))
import ReOC.Name.Path (PathLike (..))

-- | A field filled in with a value it does not accept, at its path.
data Invalid = Invalid [Step] InvalidValue
  deriving (Eq, Ord, Show)

-- | The name of the data type @Invalid@.
class InvalidLike p f x x' where
  invalid ::
    Optic p f x x' Invalid Invalid

-- | Identity
instance (x' ~ Invalid) => InvalidLike p f Invalid x' where
  invalid = id

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

-- | Lens
instance (p ~ (->), Functor f, x' ~ Invalid) => InvalidValueLike p f Invalid x' where
  invalidValue f (Invalid x1 x2) = fmap (Invalid x1) (f x2)

-- | Affine traversal: through @invalidValue@, then @invalidText1@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidText1Like p f Invalid x' where
  invalidText1 = invalidValue . invalidText1

-- | Affine traversal: through @invalidValue@, then @invalidFormText@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidFormTextLike p f Invalid x' where
  invalidFormText = invalidValue . invalidFormText

-- | Affine traversal: through @invalidValue@, then @invalidABN@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidABNLike p f Invalid x' where
  invalidABN = invalidValue . invalidABN

-- | Affine traversal: through @invalidValue@, then @invalidARN@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidARNLike p f Invalid x' where
  invalidARN = invalidValue . invalidARN

-- | Affine traversal: through @invalidValue@, then @invalidEmailAddress@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidEmailAddressLike p f Invalid x' where
  invalidEmailAddress = invalidValue . invalidEmailAddress

-- | Affine traversal: through @invalidValue@, then @invalidPhoneNumber@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidPhoneNumberLike p f Invalid x' where
  invalidPhoneNumber = invalidValue . invalidPhoneNumber

-- | Affine traversal: through @invalidValue@, then @invalidPostcode@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidPostcodeLike p f Invalid x' where
  invalidPostcode = invalidValue . invalidPostcode

-- | Affine traversal: through @invalidValue@, then @invalidPositive@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidPositiveLike p f Invalid x' where
  invalidPositive = invalidValue . invalidPositive

-- | Affine traversal: through @invalidValue@, then @invalidPercentage@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidPercentageLike p f Invalid x' where
  invalidPercentage = invalidValue . invalidPercentage

-- | Affine traversal: through @invalidValue@, then @invalidGrossWeight@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidGrossWeightLike p f Invalid x' where
  invalidGrossWeight = invalidValue . invalidGrossWeight

-- | Affine traversal: through @invalidValue@, then @invalidReviewMonths@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidReviewMonthsLike p f Invalid x' where
  invalidReviewMonths = invalidValue . invalidReviewMonths

-- | Affine traversal: through @invalidValue@, then @invalidPassMark@ of @InvalidValue@.
instance (p ~ (->), Applicative f, x' ~ Invalid) => InvalidPassMarkLike p f Invalid x' where
  invalidPassMark = invalidValue . invalidPassMark

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

Laws:

> lawNamesInvalid == id
-}
lawNamesInvalid :: Invalid -> Invalid
lawNamesInvalid s =
  Invalid
    (view (cloneLens path) s)
    (view (cloneLens invalidValue) s)

-- | The classes that a data type holding @Invalid@ in one field, or in one or more constructors, inherits.
type InheritInvalid s =
  ( InvalidLike (->) (Const ()) s s
  , PathLike (->) (Const ()) s s
  , InvalidValueLike (->) (Const ()) s s
  , InvalidText1Like (->) (Const ()) s s
  , InvalidFormTextLike (->) (Const ()) s s
  , InvalidABNLike (->) (Const ()) s s
  , InvalidARNLike (->) (Const ()) s s
  , InvalidEmailAddressLike (->) (Const ()) s s
  , InvalidPhoneNumberLike (->) (Const ()) s s
  , InvalidPostcodeLike (->) (Const ()) s s
  , InvalidPositiveLike (->) (Const ()) s s
  , InvalidPercentageLike (->) (Const ()) s s
  , InvalidGrossWeightLike (->) (Const ()) s s
  , InvalidReviewMonthsLike (->) (Const ()) s s
  , InvalidPassMarkLike (->) (Const ()) s s
  )

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

-- | The checks of inheritance of @Invalid@.
inheritsInvalid :: [()]
inheritsInvalid =
  [ inheritInvalidValue p
  ]
 where
  p = Proxy :: Proxy Invalid