Input.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}

{- | What filling in an unfilled form is built from: the errors it can give,
and how each kind of field is checked.

The errors are given in any type @e@ that has the names of the three kinds of
error, 'Unfilled', 'Invalid' and 'TooMany' ('AsReOCError'); 'ReOCError' is
one. Each error holds the path of its field, from the whole form, so that the
same field in different places (a person's name as CEO, or as chief remote
pilot) is told apart, and the help text of the field is at hand
('ReOC.Help.fieldHelp').
-}
module ReOC.Input (
  AsReOCError,
  Fill,
  at,
  accepted,
  checked,
  required,
  optional,
  elements,
  nonEmptyElements,
  someElements,
  atMostElements,
  unfilledAt,
) where

import Control.Lens (preview, review)
import Data.Functor.Identity (Identity)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Tagged (Tagged)
import Data.Validation (Validation (..))
import GHC.TypeNats (KnownNat, natVal)
import Numeric.Natural (Natural)
import ReOC.Model

{- | A type that the three kinds of error can be built in: an error type of
the caller's choice, such as 'ReOCError'.
-}
type AsReOCError e =
  ( UnfilledLike Tagged Identity e e
  , InvalidLike Tagged Identity e e
  , TooManyLike Tagged Identity e e
  )

-- | The result of filling in: the valid value, or every error.
type Fill e a =
  Validation (NonEmpty e) a

-- | The path to a field of the data type at a path.
at :: [Step] -> Field -> [Step]
at p f =
  p <> [StepField f]

-- | An error at a path.
failAt :: e -> Fill e a
failAt e =
  Failure (e :| [])

-- | A field that has not been filled in, at its path.
unfilledAt :: (AsReOCError e) => [Step] -> Fill e a
unfilledAt p =
  failAt (review unfilled (Unfilled p))

-- | A value that is accepted as it is entered (an enumeration, a date, a number of any size).
accepted :: [Step] -> a -> Fill e a
accepted _ =
  Success

{- | A value that is parsed and checked (by its smart constructor, such as
@preview _Text1@, or a parser that also accepts spaces, such as 'parseABN'),
with the kind of invalid value it is when it is not accepted.
-}
checked :: (AsReOCError e) => (r -> Maybe a) -> (r -> InvalidValue) -> [Step] -> r -> Fill e a
checked parse invalidAs q r =
  maybe (failAt (review invalid (Invalid q (invalidAs r)))) Success (parse r)

-- | A field that must be filled in.
required :: (AsReOCError e) => ([Step] -> a -> Fill e b) -> [Step] -> Maybe a -> Fill e b
required f q =
  maybe (unfilledAt q) (f q)

-- | A field that may be left empty.
optional :: ([Step] -> a -> Fill e b) -> [Step] -> Maybe a -> Fill e (Maybe b)
optional f q =
  traverse (f q)

-- | The elements of a list field, each at its index.
elements :: ([Step] -> a -> Fill e b) -> [Step] -> [a] -> Fill e [b]
elements f q xs =
  traverse (\(i, x) -> f (q <> [StepIndex i]) x) (zip [0 :: Natural ..] xs)

-- | A list field that must have at least one element.
nonEmptyElements :: (AsReOCError e) => ([Step] -> a -> Fill e b) -> [Step] -> [a] -> Fill e (NonEmpty b)
nonEmptyElements f q xs =
  case NonEmpty.nonEmpty xs of
    Nothing -> unfilledAt q
    Just _ -> NonEmpty.fromList <$> elements f q xs

-- | A list field with one to @n@ elements.
someElements :: forall n e a b. (AsReOCError e, KnownNat n) => ([Step] -> a -> Fill e b) -> [Step] -> [a] -> Fill e (Some n b)
someElements f q xs =
  let most = natVal (Proxy :: Proxy n)
   in case NonEmpty.nonEmpty xs of
        Nothing -> unfilledAt q
        Just _
          | fromIntegral (length xs) > most -> failAt (review tooMany (TooMany q most (fromIntegral (length xs))))
          | otherwise ->
              (\ys -> fromMaybe (error "someElements: checked length") (NonEmpty.nonEmpty ys >>= preview (_Some @n)))
                <$> elements f q xs

-- | A list field with at most @n@ elements.
atMostElements :: forall n e a b. (AsReOCError e, KnownNat n) => ([Step] -> a -> Fill e b) -> [Step] -> [a] -> Fill e (AtMost n b)
atMostElements f q xs =
  let most = natVal (Proxy :: Proxy n)
   in if fromIntegral (length xs) > most
        then failAt (review tooMany (TooMany q most (fromIntegral (length xs))))
        else fromMaybe (error "atMostElements: checked length") . preview (_AtMost @n) <$> elements f q xs