WrittenSignature.hs

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

-- | The data type @WrittenSignature'@: the written signature of the declarant, which a document build places in the signature box of the declaration (CASA Form 101-02, question 31): a PNG image, given by its contents or by the path of its file.
module ReOC.Data.WrittenSignature (
  WrittenSignature' (..),
  WrittenSignature'Like (..),
  lawNamesWrittenSignature',
  WrittenSignature,
  UnfilledWrittenSignature,
  InheritWrittenSignature',
  inheritWrittenSignature',
) where

import Control.Lens (Choice, Optic, prism, review)
import Data.ByteString (ByteString)
import Data.Functor.Const (Const)
import ReOC.Name.WrittenSignatureFile (WrittenSignatureFileLike (..))
import ReOC.Name.WrittenSignatureImage (WrittenSignatureImageLike (..))

-- | The written signature of the declarant, which a document build places in the signature box of the declaration (CASA Form 101-02, question 31): a PNG image, given by its contents or by the path of its file. Its valid form is @WrittenSignature@, and its unfilled form @UnfilledWrittenSignature@.
data WrittenSignature' a1 a2
  = WrittenSignatureImage a1
  | WrittenSignatureFile a2
  deriving (Eq, Ord, Show)

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

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

-- | Prism
instance (Choice p, Applicative f, x' ~ WrittenSignature' a1' a2) => WrittenSignatureImageLike p f (WrittenSignature' a1 a2) x' a1 a1' where
  writtenSignatureImage = prism WrittenSignatureImage (\case WrittenSignatureImage x -> Right x; WrittenSignatureFile x -> Left (WrittenSignatureFile x))

-- | Prism
instance (Choice p, Applicative f, x' ~ WrittenSignature' a1 a2') => WrittenSignatureFileLike p f (WrittenSignature' a1 a2) x' a2 a2' where
  writtenSignatureFile = prism WrittenSignatureFile (\case WrittenSignatureImage x -> Left (WrittenSignatureImage x); WrittenSignatureFile x -> Right x)

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

Laws:

> lawNamesWrittenSignature' == id
-}
lawNamesWrittenSignature' :: WrittenSignature' a1 a2 -> WrittenSignature' a1 a2
lawNamesWrittenSignature' = \case
  WrittenSignatureImage x -> review writtenSignatureImage x
  WrittenSignatureFile x -> review writtenSignatureFile x

-- | A valid @WrittenSignature'@.
type WrittenSignature = WrittenSignature' ByteString FilePath

-- | An unfilled @WrittenSignature'@: each field holds what has been entered, if anything, to be checked by @fillWrittenSignature@.
type UnfilledWrittenSignature = WrittenSignature' (Maybe ByteString) (Maybe FilePath)

-- | The classes that a data type holding @WrittenSignature'@ in one field, or in one or more constructors, inherits.
type InheritWrittenSignature' s a1 a2 =
  ( WrittenSignature'Like (->) (Const ()) s s a1 a1 a2 a2
  , WrittenSignatureImageLike (->) (Const ()) s s a1 a1
  , WrittenSignatureFileLike (->) (Const ()) s s a2 a2
  )

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