{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE

    BlockArguments, DerivingStrategies, FlexibleInstances,
    GeneralizedNewtypeDeriving, LambdaCase, OverloadedStrings,
    ScopedTypeVariables, StandaloneDeriving, TupleSections,
    TypeApplications, ViewPatterns

#-}

module Data.GrabForm
  (
  -- * Tutorial
  -- $tutorial

  -- * What is a form
  -- ** The Parameter type
    Param (..)
  -- ** The Name type
  , Name (..), NamePart (..), showName, readName
  -- ** The Form type
  , Form (..)

  -- * Error messages
  -- ** The Log type
  , Log (..)
  -- ** Error classes
  , Err_Missing (..), Err_Duplicate (..)
  , Err_Unexpected (..), Err_OnlyAllowed (..)
  -- ** English sentences as error messages
  , EnglishSentence (..), englishSentenceLogText

  -- * Grabbing data from forms
  -- ** Types: Grab and Dump
  , Grab, Dump
  -- ** Parameter name selection
  , at
  -- ** Simple form fields
  , text, optionalText, checkbox
  -- ** Lists
  , natList, natListWithIndex
  -- ** Dealing with unrecognized parameters
  , only, etAlia, remainder
  -- ** Applying a grab to a form
  , readTextParams

  ) where

import Prelude hiding ((/))

import Data.Coerce (coerce)
import Data.Function (fix)
import Data.String (IsString (fromString))
import Data.Traversable (for)

import Numeric.Natural (Natural)

import qualified Data.List as List

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Read as Text

import qualified Data.Map as Map

import Data.Set (Set)
import qualified Data.Set as Set

import qualified Control.Grab as Grab
import Control.Grab ((/))


--- Form ---

data Form =
  Form
    { Form -> [Param]
formParams :: [Param]
    , Form -> Name -> Name
formContext :: Name -> Name
    }

data Param =
  Param
    { Param -> Name
paramName  :: Name
    , Param -> Text
paramValue :: Text
    }

deriving stock instance Eq Param
deriving stock instance Ord Param
deriving stock instance Show Param


--- Name ---

newtype Name = Name [NamePart]

instance IsString Name
  where
    fromString :: String -> Name
fromString = Text -> Name
readName (Text -> Name) -> (String -> Text) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

data NamePart
  = NameStr Text
  | NameNat Natural
  | NameErr Text

instance IsString NamePart
  where
    fromString :: String -> NamePart
fromString = Text -> NamePart
NameStr (Text -> NamePart) -> (String -> Text) -> String -> NamePart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

showName :: Name -> Text
showName :: Name -> Text
showName (Name []) = Text
""
showName (Name (NamePart
x : [NamePart]
xs)) = NamePart -> Text
showNamePart NamePart
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [NamePart] -> Text
showNameRemainder [NamePart]
xs
  where
    showNameRemainder :: [NamePart] -> Text
showNameRemainder [] = Text
""
    showNameRemainder (NamePart
y : [NamePart]
ys) = NamePart -> Text
showNamePart' NamePart
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [NamePart] -> Text
showNameRemainder [NamePart]
ys

    showNamePart :: NamePart -> Text
showNamePart (NameStr Text
s) = Text
s
    showNamePart (NameNat Natural
n) = Natural -> Text
showNat Natural
n
    showNamePart (NameErr Text
s) = Text
s

    showNamePart' :: NamePart -> Text
showNamePart' (NameStr Text
s) = Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
    showNamePart' (NameNat Natural
n) = Natural -> Text
showNat Natural
n
    showNamePart' (NameErr Text
s) = Text
s

    showNat :: Natural -> Text
showNat Natural
n = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show @Natural Natural
n) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

readName :: Text -> Name
readName :: Text -> Name
readName =
    \case
        (Text -> Bool
Text.null -> Bool
True, Text
r) -> [NamePart] -> Name
Name [Text -> NamePart
NameErr Text
r]
        (Text
s, Text
x) -> NamePart -> Name -> Name
cons (Text -> NamePart
NameStr Text
s) (Text -> Name
readNameRemainder Text
x)
    ((Text, Text) -> Name) -> (Text -> (Text, Text)) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Char -> Bool) -> Text -> (Text, Text)
Text.span (\Char
c -> Bool -> Bool
not (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c (String
".[]" :: [Char])))

  where
    cons :: NamePart -> Name -> Name
    cons :: NamePart -> Name -> Name
cons = (NamePart -> [NamePart] -> [NamePart]) -> NamePart -> Name -> Name
forall a b. Coercible a b => a -> b
coerce ((:) @NamePart)

    readNameRemainder :: Text -> Name
    readNameRemainder :: Text -> Name
readNameRemainder =
        \case
            (Text -> Bool
Text.null -> Bool
True) -> [NamePart] -> Name
Name []
            (Text -> Text -> Maybe Text
Text.stripPrefix Text
"." -> Just Text
x) -> Text -> Name
readName Text
x
            (Text -> Maybe (Natural, Text)
stripNat -> Just (Natural
n, Text
x)) -> NamePart -> Name -> Name
cons (Natural -> NamePart
NameNat Natural
n) (Text -> Name
readNameRemainder Text
x)
            Text
t -> [NamePart] -> Name
Name [Text -> NamePart
NameErr Text
t]

stripNat :: Text -> Maybe (Natural, Text)
stripNat :: Text -> Maybe (Natural, Text)
stripNat (
    Text -> Text -> Maybe Text
Text.stripPrefix Text
"[" -> Just (
    forall a. Integral a => Reader a
Text.decimal @Natural -> Right (Natural
n, (
    Text -> Text -> Maybe Text
Text.stripPrefix Text
"]" -> Just Text
x)))) =
        (Natural, Text) -> Maybe (Natural, Text)
forall a. a -> Maybe a
Just (Natural
n, Text
x)
stripNat Text
_ = Maybe (Natural, Text)
forall a. Maybe a
Nothing

deriving stock instance Eq NamePart
deriving stock instance Ord NamePart
deriving stock instance Show NamePart

deriving stock instance Eq Name
deriving stock instance Ord Name
deriving stock instance Show Name


--- Log ---

newtype Log err =
  Log
    (Set (Name, err))

deriving newtype instance Ord err => Semigroup (Log err)
deriving newtype instance Ord err => Monoid (Log err)

deriving stock instance Eq err => Eq (Log err)
deriving stock instance Show err => Show (Log err)

(.=) :: Ord err => Name -> err -> Log err
Name
k .= :: forall err. Ord err => Name -> err -> Log err
.= err
err =
    Set (Name, err) -> Log err
forall a b. Coercible a b => a -> b
coerce ((Name, err) -> Set (Name, err)
forall a. a -> Set a
Set.singleton (Name
k, err
err))


--- Errors ---

class Err_Missing a where
    -- | A parameter was expected, but none was given.
    err_missing :: a

class Err_Duplicate a where
    -- | A parameter was given repeatedly in a situation where it was expected to be present at most once.
    err_duplicate :: a

class Err_Unexpected a where
    -- | An unexpected parameter was given.
    err_unexpected :: a

class Err_OnlyAllowed a where
    -- | There is only one allowed value for a parameter, and something different was given.
    err_onlyAllowed :: Text {- ^ The allowed value -} -> a

instance Err_Missing () where err_missing :: ()
err_missing = ()
instance Err_Duplicate () where err_duplicate :: ()
err_duplicate = ()
instance Err_Unexpected () where err_unexpected :: ()
err_unexpected = ()
instance Err_OnlyAllowed () where err_onlyAllowed :: Text -> ()
err_onlyAllowed = () -> Text -> ()
forall a b. a -> b -> a
const ()


--- English ---

newtype EnglishSentence = EnglishSentence Text

deriving newtype instance IsString EnglishSentence
deriving newtype instance Show EnglishSentence

deriving stock instance Eq EnglishSentence
deriving stock instance Ord EnglishSentence

instance Err_Missing EnglishSentence where err_missing :: EnglishSentence
err_missing = EnglishSentence
"Required parameter is missing."
instance Err_Duplicate EnglishSentence where err_duplicate :: EnglishSentence
err_duplicate = EnglishSentence
"Parameter may not appear more than once."
instance Err_Unexpected EnglishSentence where err_unexpected :: EnglishSentence
err_unexpected = EnglishSentence
"Unexpected parameter."
instance Err_OnlyAllowed EnglishSentence where err_onlyAllowed :: Text -> EnglishSentence
err_onlyAllowed Text
value = Text -> EnglishSentence
EnglishSentence (Text
"The only allowed value is `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`.")

englishSentenceLogText :: Log EnglishSentence -> Text

englishSentenceLogText :: Log EnglishSentence -> Text
englishSentenceLogText =
    [Text] -> Text
Text.unlines ([Text] -> Text)
-> (Log EnglishSentence -> [Text]) -> Log EnglishSentence -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, EnglishSentence) -> Text)
-> [(Name, EnglishSentence)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> EnglishSentence -> Text)
-> (Name, EnglishSentence) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> EnglishSentence -> Text
f) ([(Name, EnglishSentence)] -> [Text])
-> (Log EnglishSentence -> [(Name, EnglishSentence)])
-> Log EnglishSentence
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Name, EnglishSentence) -> [(Name, EnglishSentence)]
forall a. Set a -> [a]
Set.toList (Set (Name, EnglishSentence) -> [(Name, EnglishSentence)])
-> (Log EnglishSentence -> Set (Name, EnglishSentence))
-> Log EnglishSentence
-> [(Name, EnglishSentence)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Log EnglishSentence -> Set (Name, EnglishSentence)
forall a b. Coercible a b => a -> b
coerce
  where
    f :: Name -> EnglishSentence -> Text
    f :: Name -> EnglishSentence -> Text
f Name
name EnglishSentence
err = [Text] -> Text
Text.concat
        [ Name -> Text
showName Name
name
        , Text
": "
        , forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @EnglishSentence @Text EnglishSentence
err
        ]


--- Grab types ---

type Grab err a =
    Grab.Simple Form (Log err) a

type Dump err a =
    Grab.Dump Form (Log err) a

type Extract err a =
    Grab.Extract (Log err) a


--- Parameter name selection ---

atGrab :: Ord err => NamePart -> Grab err Form
atGrab :: forall err. Ord err => NamePart -> Grab err Form
atGrab NamePart
k =
    (Form -> (Form, Form)) -> Grab Form Form (Log err) Form
forall bag residue log desideratum.
Monoid log =>
(bag -> (desideratum, residue)) -> Grab bag residue log desideratum
Grab.partition \(Form [Param]
xs Name -> Name
ctx) ->
        let
            ([Param]
s, [Param]
r) = (Param -> Maybe Param) -> [Param] -> ([Param], [Param])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
partitionMaybe (NamePart -> Param -> Maybe Param
namePrefixPartition NamePart
k) [Param]
xs
        in
            ([Param] -> (Name -> Name) -> Form
Form [Param]
s (Name -> Name
ctx (Name -> Name) -> (Name -> Name) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([NamePart] -> [NamePart]) -> Name -> Name
forall a b. Coercible a b => a -> b
coerce (NamePart
k NamePart -> [NamePart] -> [NamePart]
forall a. a -> [a] -> [a]
:)), [Param] -> (Name -> Name) -> Form
Form [Param]
r Name -> Name
ctx)

at :: Ord err => NamePart -> Dump err a -> Grab err a
at :: forall err a. Ord err => NamePart -> Dump err a -> Grab err a
at NamePart
k Dump err a
d = NamePart -> Grab err Form
forall err. Ord err => NamePart -> Grab err Form
atGrab NamePart
k Grab err Form -> Dump err a -> Grab Form Form (Log err) a
forall bag residue _r log x desideratum.
Semigroup log =>
Grab bag residue log x
-> Grab x _r log desideratum -> Grab bag residue log desideratum
/ Dump err a
d

namePrefixPartition :: NamePart -> Param -> Maybe Param
namePrefixPartition :: NamePart -> Param -> Maybe Param
namePrefixPartition NamePart
k (Param Name
name Text
value) =
    case Name
name of
        Name (NamePart
x : [NamePart]
xs) | NamePart
x NamePart -> NamePart -> Bool
forall a. Eq a => a -> a -> Bool
== NamePart
k ->
            Param -> Maybe Param
forall a. a -> Maybe a
Just (Name -> Text -> Param
Param ([NamePart] -> Name
Name [NamePart]
xs) Text
value)
        Name
_ ->
            Maybe Param
forall a. Maybe a
Nothing

here :: Ord err => Grab err Form
here :: forall err. Ord err => Grab err Form
here =
    (Form -> (Form, Form)) -> Grab Form Form (Log err) Form
forall bag residue log desideratum.
Monoid log =>
(bag -> (desideratum, residue)) -> Grab bag residue log desideratum
Grab.partition \(Form [Param]
xs Name -> Name
ctx) ->
        let
            ([Param]
s, [Param]
r) = (Param -> Maybe Param) -> [Param] -> ([Param], [Param])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
partitionMaybe Param -> Maybe Param
herePartition [Param]
xs
        in
            ([Param] -> (Name -> Name) -> Form
Form [Param]
s Name -> Name
ctx, [Param] -> (Name -> Name) -> Form
Form [Param]
r Name -> Name
ctx)

herePartition :: Param -> Maybe Param
herePartition :: Param -> Maybe Param
herePartition =
    \case
        p :: Param
p@(Param (Name []) Text
_) -> Param -> Maybe Param
forall a. a -> Maybe a
Just Param
p
        Param
_ -> Maybe Param
forall a. Maybe a
Nothing


--- Simple form fields ---

text :: forall err.
    (Ord err, Err_Missing err, Err_Duplicate err) =>
    Grab err Text

text :: forall err.
(Ord err, Err_Missing err, Err_Duplicate err) =>
Grab err Text
text = Grab err Form
forall err. Ord err => Grab err Form
here Grab err Form
-> Grab Form () (Log err) Text -> Grab Form Form (Log err) Text
forall bag residue _r log x desideratum.
Semigroup log =>
Grab bag residue log x
-> Grab x _r log desideratum -> Grab bag residue log desideratum
/ (Form -> Extract (Log err) Text) -> Grab Form () (Log err) Text
forall bag log desideratum.
(bag -> Extract log desideratum) -> Dump bag log desideratum
Grab.dump Form -> Extract (Log err) Text
f
  where
    f :: Form -> Extract err Text
    f :: Form -> Extract (Log err) Text
f (Form [Param]
xs Name -> Name
ctx) =
        case [Text] -> [Text]
forall a. Ord a => [a] -> [a]
unique ((Param -> Text) -> [Param] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Param -> Text
paramValue [Param]
xs) of
            []        -> Log err -> Extract (Log err) Text
forall log desideratum. log -> Extract log desideratum
Grab.failure (Name -> Name
ctx ([NamePart] -> Name
Name []) Name -> err -> Log err
forall err. Ord err => Name -> err -> Log err
.= err
forall a. Err_Missing a => a
err_missing)
            Text
x : []    -> Text -> Extract (Log err) Text
forall log desideratum.
Monoid log =>
desideratum -> Extract log desideratum
Grab.success Text
x
            Text
_ : Text
_ : [Text]
_ -> Log err -> Extract (Log err) Text
forall log desideratum. log -> Extract log desideratum
Grab.failure (Name -> Name
ctx ([NamePart] -> Name
Name []) Name -> err -> Log err
forall err. Ord err => Name -> err -> Log err
.= err
forall a. Err_Duplicate a => a
err_duplicate)

optionalText :: forall err.
    (Ord err, Err_Duplicate err) =>
    Grab err (Maybe Text)

optionalText :: forall err. (Ord err, Err_Duplicate err) => Grab err (Maybe Text)
optionalText = Grab err Form
forall err. Ord err => Grab err Form
here Grab err Form
-> Grab Form () (Log err) (Maybe Text)
-> Grab Form Form (Log err) (Maybe Text)
forall bag residue _r log x desideratum.
Semigroup log =>
Grab bag residue log x
-> Grab x _r log desideratum -> Grab bag residue log desideratum
/ (Form -> Extract (Log err) (Maybe Text))
-> Grab Form () (Log err) (Maybe Text)
forall bag log desideratum.
(bag -> Extract log desideratum) -> Dump bag log desideratum
Grab.dump Form -> Extract (Log err) (Maybe Text)
f
  where
    f :: Form -> Extract err (Maybe Text)
    f :: Form -> Extract (Log err) (Maybe Text)
f (Form [Param]
xs Name -> Name
ctx) =
        case [Text] -> [Text]
forall a. Ord a => [a] -> [a]
unique ((Param -> Text) -> [Param] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Param -> Text
paramValue [Param]
xs) of
            []        -> Maybe Text -> Extract (Log err) (Maybe Text)
forall log desideratum.
Monoid log =>
desideratum -> Extract log desideratum
Grab.success Maybe Text
forall a. Maybe a
Nothing
            Text
x : []    -> Maybe Text -> Extract (Log err) (Maybe Text)
forall log desideratum.
Monoid log =>
desideratum -> Extract log desideratum
Grab.success (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x)
            Text
_ : Text
_ : [Text]
_ -> Log err -> Extract (Log err) (Maybe Text)
forall log desideratum. log -> Extract log desideratum
Grab.failure (Name -> Name
ctx ([NamePart] -> Name
Name []) Name -> err -> Log err
forall err. Ord err => Name -> err -> Log err
.= err
forall a. Err_Duplicate a => a
err_duplicate)

checkbox :: forall err.
    (Ord err, Err_OnlyAllowed err) =>
    Text ->
    Grab err Bool

checkbox :: forall err. (Ord err, Err_OnlyAllowed err) => Text -> Grab err Bool
checkbox Text
yes = Grab err Form
forall err. Ord err => Grab err Form
here Grab err Form
-> Grab Form () (Log err) Bool -> Grab Form Form (Log err) Bool
forall bag residue _r log x desideratum.
Semigroup log =>
Grab bag residue log x
-> Grab x _r log desideratum -> Grab bag residue log desideratum
/ (Form -> Extract (Log err) Bool) -> Grab Form () (Log err) Bool
forall bag log desideratum.
(bag -> Extract log desideratum) -> Dump bag log desideratum
Grab.dump Form -> Extract (Log err) Bool
f
  where
    f :: Form -> Extract err Bool
    f :: Form -> Extract (Log err) Bool
f (Form [Param]
xs Name -> Name
ctx) =
        case (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
yes) ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
unique ((Param -> Text) -> [Param] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Param -> Text
paramValue [Param]
xs)) of
            ( []    , []    ) -> Bool -> Extract (Log err) Bool
forall log desideratum.
Monoid log =>
desideratum -> Extract log desideratum
Grab.success Bool
False
            ( Text
_ : [Text]
_ , []    ) -> Bool -> Extract (Log err) Bool
forall log desideratum.
Monoid log =>
desideratum -> Extract log desideratum
Grab.success Bool
True
            ( [Text]
_     , Text
_ : [Text]
_ ) -> Log err -> Extract (Log err) Bool
forall log desideratum. log -> Extract log desideratum
Grab.failure (Name -> Name
ctx ([NamePart] -> Name
Name []) Name -> err -> Log err
forall err. Ord err => Name -> err -> Log err
.= Text -> err
forall a. Err_OnlyAllowed a => Text -> a
err_onlyAllowed Text
yes)


--- Internal ---

unique :: Ord a => [a] -> [a]
unique :: forall a. Ord a => [a] -> [a]
unique =
    Set a -> [a]
forall a. Set a -> [a]
Set.toList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList

partitionMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
partitionMaybe :: forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
partitionMaybe a -> Maybe b
f = (([a] -> ([b], [a])) -> [a] -> ([b], [a])) -> [a] -> ([b], [a])
forall a. (a -> a) -> a
fix \[a] -> ([b], [a])
r ->
    \case
        [] -> ([], [])
        a
x : [a]
xs ->
            let
              ([b]
bs, [a]
as) = [a] -> ([b], [a])
r [a]
xs
            in
              case a -> Maybe b
f a
x of
                Maybe b
Nothing -> ([b]
bs, a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as)
                Just b
y  -> (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
bs, [a]
as)


--- Dealing with unrecognized parameters ---

only :: forall err a. (Ord err, Err_Unexpected err) =>
    Grab err a -> Dump err a
only :: forall err a.
(Ord err, Err_Unexpected err) =>
Grab err a -> Dump err a
only Grab err a
g =
    (Form -> Extract (Log err) a) -> Dump Form (Log err) a
forall bag log desideratum.
(bag -> Extract log desideratum) -> Dump bag log desideratum
Grab.dump \Form
i ->
        let
            r :: Result Form (Log err) a
r = Grab err a -> Form -> Result Form (Log err) a
forall bag residue log desideratum.
Grab bag residue log desideratum
-> bag -> Result residue log desideratum
Grab.runGrab Grab err a
g Form
i
        in
            case Result Form (Log err) a -> Form
forall residue log desideratum.
Result residue log desideratum -> residue
Grab.residue Result Form (Log err) a
r of
                Form [] Name -> Name
_ -> Result Form (Log err) a -> Extract (Log err) a
forall bag residue log desideratum.
Grab bag residue log desideratum -> Dump bag log desideratum
Grab.discardResidue Result Form (Log err) a
r
                Form [Param]
xs Name -> Name
ctx ->
                    Log err -> Maybe a -> Extract (Log err) a
forall log desideratum.
log -> Maybe desideratum -> Extract log desideratum
Grab.extract
                        (Result Form (Log err) a -> Log err
forall residue log desideratum.
Result residue log desideratum -> log
Grab.log Result Form (Log err) a
r
                            Log err -> Log err -> Log err
forall a. Semigroup a => a -> a -> a
<> (Param -> Log err) -> [Param] -> Log err
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Param Name
n Text
_) -> Name -> Name
ctx Name
n Name -> err -> Log err
forall err. Ord err => Name -> err -> Log err
.= err
forall a. Err_Unexpected a => a
err_unexpected) [Param]
xs)
                        (Result Form (Log err) a -> Maybe a
forall residue log desideratum.
Result residue log desideratum -> Maybe desideratum
Grab.desideratum Result Form (Log err) a
r)

etAlia :: Grab err a -> Dump err a
etAlia :: forall err a. Grab err a -> Dump err a
etAlia = Grab Form Form (Log err) a -> Dump Form (Log err) a
forall bag residue log desideratum.
Grab bag residue log desideratum -> Dump bag log desideratum
Grab.discardResidue

remainder :: Ord err => Grab err [Param]
remainder :: forall err. Ord err => Grab err [Param]
remainder = (Form -> ([Param], Form)) -> Grab Form Form (Log err) [Param]
forall bag residue log desideratum.
Monoid log =>
(bag -> (desideratum, residue)) -> Grab bag residue log desideratum
Grab.partition \(Form [Param]
xs Name -> Name
_) -> ([Param]
xs, [Param] -> (Name -> Name) -> Form
Form [] Name -> Name
forall a. a -> a
id)


--- Lists ---

groupByFst :: Ord a => [(a, b)] -> [(a, [b])]
groupByFst :: forall a b. Ord a => [(a, b)] -> [(a, [b])]
groupByFst =
    Map a [b] -> [(a, [b])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map a [b] -> [(a, [b])])
-> ([(a, b)] -> Map a [b]) -> [(a, b)] -> [(a, [b])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Map a [b] -> Map a [b] -> Map a [b])
-> Map a [b] -> [Map a [b]] -> Map a [b]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([b] -> [b] -> [b]) -> Map a [b] -> Map a [b] -> Map a [b]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++)) Map a [b]
forall k a. Map k a
Map.empty ([Map a [b]] -> Map a [b])
-> ([(a, b)] -> [Map a [b]]) -> [(a, b)] -> Map a [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ((a, b) -> Map a [b]) -> [(a, b)] -> [Map a [b]]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
a, b
b) -> a -> [b] -> Map a [b]
forall k a. k -> a -> Map k a
Map.singleton a
a [b
b])

natListWithIndex :: forall err a. Ord err =>
    Dump err a ->
    Grab err [(Natural, a)]

natListWithIndex :: forall err a. Ord err => Dump err a -> Grab err [(Natural, a)]
natListWithIndex =
  \Dump err a
d ->
    (Form -> (([(Natural, Param)], Name -> Name), Form))
-> Grab Form Form (Log err) ([(Natural, Param)], Name -> Name)
forall bag residue log desideratum.
Monoid log =>
(bag -> (desideratum, residue)) -> Grab bag residue log desideratum
Grab.partition Form -> (([(Natural, Param)], Name -> Name), Form)
selectNats
    Grab Form Form (Log err) ([(Natural, Param)], Name -> Name)
-> Grab
     ([(Natural, Param)], Name -> Name) () (Log err) [(Natural, a)]
-> Grab err [(Natural, a)]
forall bag residue _r log x desideratum.
Semigroup log =>
Grab bag residue log x
-> Grab x _r log desideratum -> Grab bag residue log desideratum
/
    (([(Natural, Param)], Name -> Name)
 -> Extract (Log err) [(Natural, a)])
-> Grab
     ([(Natural, Param)], Name -> Name) () (Log err) [(Natural, a)]
forall bag log desideratum.
(bag -> Extract log desideratum) -> Dump bag log desideratum
Grab.dump \([(Natural, Param)]
xs, Name -> Name
ctx) ->
        [(Natural, [Param])]
-> ((Natural, [Param]) -> Grab () () (Log err) (Natural, a))
-> Extract (Log err) [(Natural, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([(Natural, Param)] -> [(Natural, [Param])]
forall a b. Ord a => [(a, b)] -> [(a, [b])]
groupByFst [(Natural, Param)]
xs) \(Natural
n, [Param]
xs') ->
            Dump Form (Log err) (Natural, a)
-> Form -> Grab () () (Log err) (Natural, a)
forall bag log desideratum.
Dump bag log desideratum -> bag -> Extract log desideratum
Grab.runDump
                ((a -> (Natural, a))
-> Dump err a -> Dump Form (Log err) (Natural, a)
forall a b.
(a -> b) -> Grab Form () (Log err) a -> Grab Form () (Log err) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Natural
n,) Dump err a
d)
                ([Param] -> (Name -> Name) -> Form
Form [Param]
xs' (Name -> Name
ctx (Name -> Name) -> (Name -> Name) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([NamePart] -> [NamePart]) -> Name -> Name
forall a b. Coercible a b => a -> b
coerce (Natural -> NamePart
NameNat Natural
n NamePart -> [NamePart] -> [NamePart]
forall a. a -> [a] -> [a]
:)))

  where
    selectNats :: Form -> (([(Natural, Param)], Name -> Name), Form)
    selectNats :: Form -> (([(Natural, Param)], Name -> Name), Form)
selectNats (Form [Param]
xs Name -> Name
ctx) =
        let
            ([(Natural, Param)]
s, [Param]
r) = (Param -> Maybe (Natural, Param))
-> [Param] -> ([(Natural, Param)], [Param])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
partitionMaybe Param -> Maybe (Natural, Param)
f [Param]
xs
        in
            (([(Natural, Param)]
s, Name -> Name
ctx), [Param] -> (Name -> Name) -> Form
Form [Param]
r Name -> Name
ctx)
      where
        f :: Param -> Maybe (Natural, Param)
        f :: Param -> Maybe (Natural, Param)
f (Param (Name (NameNat Natural
n : [NamePart]
ns)) Text
v) = (Natural, Param) -> Maybe (Natural, Param)
forall a. a -> Maybe a
Just (Natural
n, Name -> Text -> Param
Param ([NamePart] -> Name
Name [NamePart]
ns) Text
v)
        f Param
_ = Maybe (Natural, Param)
forall a. Maybe a
Nothing

natList :: Ord err =>
    Dump err a ->
    Grab err [a]

natList :: forall err a. Ord err => Dump err a -> Grab err [a]
natList Dump err a
d =
    (((Natural, a) -> a) -> [(Natural, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Natural, a) -> a
forall a b. (a, b) -> b
snd) ([(Natural, a)] -> [a])
-> Grab Form Form (Log err) [(Natural, a)]
-> Grab Form Form (Log err) [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dump err a -> Grab Form Form (Log err) [(Natural, a)]
forall err a. Ord err => Dump err a -> Grab err [(Natural, a)]
natListWithIndex Dump err a
d


--- Applying a grab to a form ---

readTextParams :: Ord err => Dump err a -> [(Text, Text)] -> (Log err, Maybe a)
readTextParams :: forall err a.
Ord err =>
Dump err a -> [(Text, Text)] -> (Log err, Maybe a)
readTextParams Dump err a
d [(Text, Text)]
x =
     let
         r :: Extract (Log err) a
r = Dump err a -> Form -> Extract (Log err) a
forall bag log desideratum.
Dump bag log desideratum -> bag -> Extract log desideratum
Grab.runDump Dump err a
d ([(Text, Text)] -> Form
textParamsToForm [(Text, Text)]
x)
     in
         (Extract (Log err) a -> Log err
forall residue log desideratum.
Result residue log desideratum -> log
Grab.log Extract (Log err) a
r, Extract (Log err) a -> Maybe a
forall residue log desideratum.
Result residue log desideratum -> Maybe desideratum
Grab.desideratum Extract (Log err) a
r)

textParamsToForm :: [(Text, Text)] -> Form
textParamsToForm :: [(Text, Text)] -> Form
textParamsToForm [(Text, Text)]
xs = [Param] -> (Name -> Name) -> Form
Form (((Text, Text) -> Param) -> [(Text, Text)] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Param
textParam [(Text, Text)]
xs) Name -> Name
forall a. a -> a
id

textParam :: (Text, Text) -> Param
textParam :: (Text, Text) -> Param
textParam (Text
x, Text
y) = Name -> Text -> Param
Param (Text -> Name
readName Text
x) Text
y


{- $tutorial

We are concerned here with data submitted by web browsers in a normal form
submission. Ignoring the encoding details, we can think of a form as looking
something like this:

> name:               Alonzo
> state:              Montana
> security_question:  What is your favorite hobby?
> security_answer:    watching cars

This example has four parameters. Each parameter has a name and a value. We
might represent this in Haskell as:

> [ ("name", "Alonzo")
> , ("state", "Montana")
> , ("security_question", "What is your favorite hobby?")
> , ("security_answer", "watching cars")
> ]

Suppose we're only interested in two parts of this form: The name and the state.

> nameAndState :: Grab EnglishSentence (Text, Text)
> nameAndState =
>     (,)
>         <$> at "name" (only text)
>         <*> at "state" (only text)

If we apply @nameAndState@ to the form parameters above, we get the following
result: @(\"Alonzo\", \"Montana\")@

> λ> :{
>  > readTextParams (etAlia nameAndState)
>  >     [ ("name", "Alonzo")
>  >     , ("state", "Montana")
>  >     , ("security_question", "What is your favorite hobby?")
>  >     , ("security_answer", "watching cars")
>  >     ]
>  > :}
> ( Log []
> , Just ("Alonzo", "Montana")
> )

When receiving information submitted from an external source, there is usually
some possibility that the input is invalid. Consider the following form that is
missing the "state" field. In this case, the result we get is @Nothing@,
accompanied by an error message indicating that something is missing.

> λ> :{
>  > readTextParams (etAlia nameAndState)
>  >     [ ("name", "Alonzo")
>  >     , ("security_question", "What is your favorite hobby?")
>  >     , ("security_answer", "watching cars")
>  >     ]
>  > :}
> ( Log [("state", "Required parameter is missing.")]
> , Nothing
> )

The 'etAlia' function we've been using signifies that the input is allowed to
contain parameters other than the ones that @nameAndState@ grabs. If we use
'only' instead, we can specify that there should be no additional parameters.

> λ> :{
>  > readTextParams (only nameAndState)
>  >     [ ("name", "Alonzo")
>  >     , ("state", "Montana")
>  >     , ("security_question", "What is your favorite hobby?")
>  >     , ("security_answer", "watching cars")
>  >     ]
>  > :}
> ( Log [ ("security_question", "Unexpected parameter.")
>       , ("security_answer", "Unexpected parameter.")
>       ]
> , Just ("Alonzo", "Montana")
> )

However, we still get the result: @(\"Alonzo\", \"Montana\")@. Unexpected parameters
do not prevent us from being able to read the form. Whether you choose 'only' or
'etAlia' only determines whether these warnings end up in the log; it does not
affect whether reading the form succeeds or fails.

Duplicate parameters are not permitted, since we cannot know which of the values
to accept as the real one. Alonzo cannot live in both Georgia and Montana:

> λ> :{
>  > readTextParams (only nameAndState)
>  >     [ ("name", "Alonzo")
>  >     , ("state", "Georgia")
>  >     , ("state", "Montana")
>  >     ]
>  > :}
> ( Log [("state", "Parameter may not appear more than once.")]
> , Nothing
> )

Duplicated parameters are only allowed if they have the same value, because in
that case the problem of deciding which value to accept does not arise.

> λ> :{
>  > readTextParams (only nameAndState)
>  >     [ ("name", "Alonzo")
>  >     , ("state", "Montana")
>  >     , ("state", "Montana")
>  >     ]
>  > :}
> ( Log []
> , Just ("Alonzo", "Montana")
> )

Sometimes a form has a tree structure. Suppose there are multiple security
questions. If we were using a data format like YAML, it might look like this:

> name: Alonzo
> state: Montana
> security:
>   - Q: What is your favorite hobby?
>     A: watching cars
>   - Q: What is your oldest sibling's name?
>     A: melman
>   - Q: What was the make and model of your first car?
>     A: bmw x5

To cajole this data into our concept of a form as a list of parameters, we need
to flatten it somehow. We adopt the following convention:

> name:           Alonzo
> state:          Montana
> security[1].Q:  What is your favorite hobby?
> security[1].A:  watching cars
> security[2].Q:  What is your oldest sibling's name?
> security[2].A:  melman
> security[3].Q:  What was the make and model of your first car?
> security[3].A:  bmw x5

Let's define a data type to represent a question and answer:

> data QA = QA { qa_question :: Text, qa_answer :: Text } deriving (Eq, Show)

> nameStateAndQAs :: Grab EnglishSentence (Text, Text, [QA])
> nameStateAndQAs =
>     (,,)
>         <$> at "name" (only text)
>         <*> at "state" (only text)
>         <*> at "security" (only (natList (only qa)))

> qa :: Grab EnglishSentence QA
> qa =
>     QA
>         <$> at "Q" (only text)
>         <*> at "A" (only text)

> λ> :{
>  > readTextParams (only nameStateAndQAs)
>  >     [ ("name", "Alonzo")
>  >     , ("state", "Montana")
>  >     , ("security[0].Q", "What is your favorite hobby?")
>  >     , ("security[0].A", "watching cars")
>  >     , ("security[1].Q", "What is your oldest sibling's name?")
>  >     , ("security[1].A", "melman")
>  >     , ("security[2].Q", "What was the make and model of your first car?")
>  >     , ("security[2].A", "bmw x5")
>  >     ]
>  > :}
> ( Log []
> , Just
>       ( "Alonzo"
>       , "Montana"
>       , [ QA
>             { qa_question = "What is your favorite hobby?"
>             , qa_answer = "watching cars"
>             }
>         , QA
>             { qa_question = "What is your oldest sibling's name?"
>             , qa_answer = "melman"
>             }
>         , QA
>             { qa_question = "What was the make and model of your first car?"
>             , qa_answer = "bmw x5"
>             }
>         ]
>       )
> )

The parameters of the list may appear in any order. The order of the result is
determined by the numbers in the parameter names.

> λ> :{
>  > readTextParams (only (at "security" (only (natList (only qa)))))
>  >     [ ("security[2].Q", "What was the make and model of your first car?")
>  >     , ("security[1].A", "melman")
>  >     , ("security[0].Q", "What is your favorite hobby?")
>  >     , ("security[1].Q", "What is your oldest sibling's name?")
>  >     , ("security[0].A", "watching cars")
>  >     , ("security[2].A", "bmw x5")
>  >     ]
>  > :}
> ( Log []
> , Just
>       [ QA
>           { qa_question = "What is your favorite hobby?"
>           , qa_answer = "watching cars"
>           }
>       , QA
>           { qa_question = "What is your oldest sibling's name?"
>           , qa_answer = "melman"
>           }
>       , QA
>           { qa_question = "What was the make and model of your first car?"
>           , qa_answer = "bmw x5"
>           }
>       ]
> )

Error messages work the same within nested grabs. The result is a complete list
of every error encountered.

> λ> :{
>  > readTextParams (only nameStateAndQAs)
>  >     [ ("state", "Montana")
>  >     , ("itchy face", "yes")
>  >     , ("security[0].Q", "What is your favorite hobby?")
>  >     , ("security[0].A", "watching cars")
>  >     , ("security[1].Q", "What is your oldest sibling's name?")
>  >     , ("security[1].A", "melman")
>  >     , ("security[1].A", "iowa")
>  >     , ("security[2].Q", "What was the make and model of your first car?")
>  >     , ("security[2].A", "bmw x5")
>  >     , ("security[2].A2", "xyz")
>  >     ]
>  > :}
> ( Log [ ("name", "Required parameter is missing.")
>       , ("itchy face", "Unexpected parameter.")
>       , ("security[1].A", "Parameter may not appear more than once.")
>       , ("security[2].A2", "Unexpected parameter.")
>       ]
> , Nothing
> )

-}