{-# LANGUAGE
    NamedFieldPuns
  , ScopedTypeVariables
  , LambdaCase
  , TypeFamilies
#-}

-- | This module provides helper functions for HTML input elements. These helper functions are not specific to any particular web framework or html library.

module Ditto.Generalized.Internal where

import Control.Monad.State.Class (get)
import Control.Monad.Trans (lift)
import Data.Either
import Data.List (find)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Traversable (for)
import Ditto.Backend
import Ditto.Core
import Ditto.Types

-- | used for constructing elements like @\<input type=\"text\"\>@, which pure a single input value.
input :: forall m input err a view. (Environment m input, FormError input err)
  => FormState m FormId
  -> (input -> Either err a)
  -> (FormId -> a -> view)
  -> a
  -> Form m input err view a
input :: FormState m FormId
-> (input -> Either err a)
-> (FormId -> a -> view)
-> a
-> Form m input err view a
input FormState m FormId
formSId input -> Either err a
fromInput FormId -> a -> view
toView a
initialValue =
  (input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (Either err a -> m (Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err a -> m (Either err a))
-> (input -> Either err a) -> input -> m (Either err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Either err a
fromInput) (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
initialValue) (FormState m (View err view, Result err (Proved a))
 -> Form m input err view a)
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall a b. (a -> b) -> a -> b
$ do
    FormId
i <- FormState m FormId
formSId
    Value input
v <- FormId -> FormState m (Value input)
forall (m :: * -> *) input.
Environment m input =>
FormId -> FormState m (Value input)
getFormInput' FormId
i
    case Value input
v of
      Value input
Default -> (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> a -> view
toView FormId
i a
initialValue
        , Proved a -> Result err (Proved a)
forall e ok. ok -> Result e ok
Ok (Proved a -> Result err (Proved a))
-> Proved a -> Result err (Proved a)
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
            { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
            , unProved :: a
unProved = a
initialValue
            }
        )
      Found input
inp -> case input -> Either err a
fromInput input
inp of
        Right a
a -> (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> a -> view
toView FormId
i a
a
          , Proved a -> Result err (Proved a)
forall e ok. ok -> Result e ok
Ok (Proved a -> Result err (Proved a))
-> Proved a -> Result err (Proved a)
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
              { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
              , unProved :: a
unProved = a
a
              }
          )
        Left err
err -> (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> a -> view
toView FormId
i a
initialValue
          , [(FormRange, err)] -> Result err (Proved a)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, err
err)]
          )
      Value input
Missing -> (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> a -> view
toView FormId
i a
initialValue
        , [(FormRange, err)] -> Result err (Proved a)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, CommonFormError input -> err
forall input err.
FormError input err =>
CommonFormError input -> err
commonFormError (FormId -> CommonFormError input
forall input. FormId -> CommonFormError input
InputMissing FormId
i :: CommonFormError input) :: err)]
        )

-- | this is necessary in order to basically map over the decoding function
inputList :: forall m input err a view view'. (Monad m, FormError input err, Environment m input)
  => FormState m FormId
  -> (input -> m (Either err [a])) -- ^ decoding function for the list
  -> ([view] -> view') -- ^ how to concatenate views
  -> [a] -- ^ initial values
  -> view' -- ^ view to generate in the fail case
  -> (a -> Form m input err view a)
  -> Form m input err view' [a]
inputList :: FormState m FormId
-> (input -> m (Either err [a]))
-> ([view] -> view')
-> [a]
-> view'
-> (a -> Form m input err view a)
-> Form m input err view' [a]
inputList FormState m FormId
formSId input -> m (Either err [a])
fromInput [view] -> view'
viewCat [a]
initialValue view'
defView a -> Form m input err view a
createForm =
  (input -> m (Either err [a]))
-> m [a]
-> FormState m (View err view', Result err (Proved [a]))
-> Form m input err view' [a]
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form input -> m (Either err [a])
fromInput ([a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
initialValue) (FormState m (View err view', Result err (Proved [a]))
 -> Form m input err view' [a])
-> FormState m (View err view', Result err (Proved [a]))
-> Form m input err view' [a]
forall a b. (a -> b) -> a -> b
$ do
    FormId
i <- FormState m FormId
formSId
    Value input
v <- FormId -> FormState m (Value input)
forall (m :: * -> *) input.
Environment m input =>
FormId -> FormState m (Value input)
getFormInput' FormId
i
    case Value input
v of
      Value input
Default -> do
        [view]
views <- [a] -> (a -> StateT FormRange m view) -> StateT FormRange m [view]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [a]
initialValue ((a -> StateT FormRange m view) -> StateT FormRange m [view])
-> (a -> StateT FormRange m view) -> StateT FormRange m [view]
forall a b. (a -> b) -> a -> b
$ \a
x -> do
          (View [(FormRange, err)] -> view
viewF, Result err (Proved a)
_) <- Form m input err view a
-> FormState m (View err view, Result err (Proved a))
forall (m :: * -> *) input err view a.
Form m input err view a
-> FormState m (View err view, Result err (Proved a))
formFormlet (Form m input err view a
 -> FormState m (View err view, Result err (Proved a)))
-> Form m input err view a
-> FormState m (View err view, Result err (Proved a))
forall a b. (a -> b) -> a -> b
$ a -> Form m input err view a
createForm a
x
          view -> StateT FormRange m view
forall (f :: * -> *) a. Applicative f => a -> f a
pure (view -> StateT FormRange m view)
-> view -> StateT FormRange m view
forall a b. (a -> b) -> a -> b
$ [(FormRange, err)] -> view
viewF []
        (View err view', Result err (Proved [a]))
-> FormState m (View err view', Result err (Proved [a]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view') -> View err view'
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view') -> View err view')
-> ([(FormRange, err)] -> view') -> View err view'
forall a b. (a -> b) -> a -> b
$ view' -> [(FormRange, err)] -> view'
forall a b. a -> b -> a
const (view' -> [(FormRange, err)] -> view')
-> view' -> [(FormRange, err)] -> view'
forall a b. (a -> b) -> a -> b
$ [view] -> view'
viewCat [view]
views
          , Proved [a] -> Result err (Proved [a])
forall e ok. ok -> Result e ok
Ok (Proved [a] -> Result err (Proved [a]))
-> Proved [a] -> Result err (Proved [a])
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
              { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
              , unProved :: [a]
unProved = [a]
initialValue
              }
          )
      Found input
inp -> m (Either err [a]) -> StateT FormRange m (Either err [a])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (input -> m (Either err [a])
fromInput input
inp) StateT FormRange m (Either err [a])
-> (Either err [a]
    -> FormState m (View err view', Result err (Proved [a])))
-> FormState m (View err view', Result err (Proved [a]))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right [a]
xs -> do
          [view]
views <- [a] -> (a -> StateT FormRange m view) -> StateT FormRange m [view]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [a]
xs ((a -> StateT FormRange m view) -> StateT FormRange m [view])
-> (a -> StateT FormRange m view) -> StateT FormRange m [view]
forall a b. (a -> b) -> a -> b
$ \a
x -> do
            (View [(FormRange, err)] -> view
viewF, Result err (Proved a)
_) <- Form m input err view a
-> FormState m (View err view, Result err (Proved a))
forall (m :: * -> *) input err view a.
Form m input err view a
-> FormState m (View err view, Result err (Proved a))
formFormlet (Form m input err view a
 -> FormState m (View err view, Result err (Proved a)))
-> Form m input err view a
-> FormState m (View err view, Result err (Proved a))
forall a b. (a -> b) -> a -> b
$ a -> Form m input err view a
createForm a
x
            view -> StateT FormRange m view
forall (f :: * -> *) a. Applicative f => a -> f a
pure (view -> StateT FormRange m view)
-> view -> StateT FormRange m view
forall a b. (a -> b) -> a -> b
$ [(FormRange, err)] -> view
viewF []
          (View err view', Result err (Proved [a]))
-> FormState m (View err view', Result err (Proved [a]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( ([(FormRange, err)] -> view') -> View err view'
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view') -> View err view')
-> ([(FormRange, err)] -> view') -> View err view'
forall a b. (a -> b) -> a -> b
$ view' -> [(FormRange, err)] -> view'
forall a b. a -> b -> a
const (view' -> [(FormRange, err)] -> view')
-> view' -> [(FormRange, err)] -> view'
forall a b. (a -> b) -> a -> b
$ [view] -> view'
viewCat [view]
views
            , Proved [a] -> Result err (Proved [a])
forall e ok. ok -> Result e ok
Ok (Proved [a] -> Result err (Proved [a]))
-> Proved [a] -> Result err (Proved [a])
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
                { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
                , unProved :: [a]
unProved = [a]
xs
                }
            )
        Left err
err -> do
          let err' :: [(FormRange, err)]
err' = [(FormId -> FormRange
unitRange FormId
i, err
err)]
          [view]
views <- [a] -> (a -> StateT FormRange m view) -> StateT FormRange m [view]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [a]
initialValue ((a -> StateT FormRange m view) -> StateT FormRange m [view])
-> (a -> StateT FormRange m view) -> StateT FormRange m [view]
forall a b. (a -> b) -> a -> b
$ \a
x -> do
            (View [(FormRange, err)] -> view
viewF, Result err (Proved a)
_) <- Form m input err view a
-> FormState m (View err view, Result err (Proved a))
forall (m :: * -> *) input err view a.
Form m input err view a
-> FormState m (View err view, Result err (Proved a))
formFormlet (Form m input err view a
 -> FormState m (View err view, Result err (Proved a)))
-> Form m input err view a
-> FormState m (View err view, Result err (Proved a))
forall a b. (a -> b) -> a -> b
$ a -> Form m input err view a
createForm a
x
            view -> StateT FormRange m view
forall (f :: * -> *) a. Applicative f => a -> f a
pure (view -> StateT FormRange m view)
-> view -> StateT FormRange m view
forall a b. (a -> b) -> a -> b
$ [(FormRange, err)] -> view
viewF [(FormRange, err)]
err'
          (View err view', Result err (Proved [a]))
-> FormState m (View err view', Result err (Proved [a]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( ([(FormRange, err)] -> view') -> View err view'
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view') -> View err view')
-> ([(FormRange, err)] -> view') -> View err view'
forall a b. (a -> b) -> a -> b
$ view' -> [(FormRange, err)] -> view'
forall a b. a -> b -> a
const (view' -> [(FormRange, err)] -> view')
-> view' -> [(FormRange, err)] -> view'
forall a b. (a -> b) -> a -> b
$ [view] -> view'
viewCat [view]
views
            , [(FormRange, err)] -> Result err (Proved [a])
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormRange, err)]
err'
            )
      Value input
Missing -> do
        (View err view', Result err (Proved [a]))
-> FormState m (View err view', Result err (Proved [a]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view') -> View err view'
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view') -> View err view')
-> ([(FormRange, err)] -> view') -> View err view'
forall a b. (a -> b) -> a -> b
$ view' -> [(FormRange, err)] -> view'
forall a b. a -> b -> a
const view'
defView
          , Proved [a] -> Result err (Proved [a])
forall e ok. ok -> Result e ok
Ok (Proved [a] -> Result err (Proved [a]))
-> Proved [a] -> Result err (Proved [a])
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
              { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
              , unProved :: [a]
unProved = []
              }
          )

-- | used for elements like @\<input type=\"submit\"\>@ which are not always present in the form submission data.
inputMaybe :: (Monad m, FormError input err, Environment m input)
  => FormState m FormId
  -> (input -> Either err a)
  -> (FormId -> Maybe a -> view)
  -> Maybe a
  -> Form m input err view (Maybe a)
inputMaybe :: FormState m FormId
-> (input -> Either err a)
-> (FormId -> Maybe a -> view)
-> Maybe a
-> Form m input err view (Maybe a)
inputMaybe FormState m FormId
i' input -> Either err a
fromInput FormId -> Maybe a -> view
toView Maybe a
initialValue =
  (input -> m (Either err (Maybe a)))
-> m (Maybe a)
-> FormState m (View err view, Result err (Proved (Maybe a)))
-> Form m input err view (Maybe a)
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (Either err (Maybe a) -> m (Either err (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err (Maybe a) -> m (Either err (Maybe a)))
-> (input -> Either err (Maybe a))
-> input
-> m (Either err (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> Either err a -> Either err (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Either err a -> Either err (Maybe a))
-> (input -> Either err a) -> input -> Either err (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Either err a
fromInput) (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
initialValue) (FormState m (View err view, Result err (Proved (Maybe a)))
 -> Form m input err view (Maybe a))
-> FormState m (View err view, Result err (Proved (Maybe a)))
-> Form m input err view (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
    FormId
i <- FormState m FormId
i'
    Value input
v <- FormId -> FormState m (Value input)
forall (m :: * -> *) input.
Environment m input =>
FormId -> FormState m (Value input)
getFormInput' FormId
i
    case Value input
v of
      Value input
Default -> (View err view, Result err (Proved (Maybe a)))
-> FormState m (View err view, Result err (Proved (Maybe a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> Maybe a -> view
toView FormId
i Maybe a
initialValue
          , Proved (Maybe a) -> Result err (Proved (Maybe a))
forall e ok. ok -> Result e ok
Ok Proved :: forall a. FormRange -> a -> Proved a
Proved
              { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
              , unProved :: Maybe a
unProved = Maybe a
initialValue
              }
          )
      Found input
x -> case input -> Either err a
fromInput input
x of
        Right a
a -> (View err view, Result err (Proved (Maybe a)))
-> FormState m (View err view, Result err (Proved (Maybe a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> Maybe a -> view
toView FormId
i (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
          , Proved (Maybe a) -> Result err (Proved (Maybe a))
forall e ok. ok -> Result e ok
Ok Proved :: forall a. FormRange -> a -> Proved a
Proved
              { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
              , unProved :: Maybe a
unProved = a -> Maybe a
forall a. a -> Maybe a
Just a
a
              }
          )
        Left err
err -> (View err view, Result err (Proved (Maybe a)))
-> FormState m (View err view, Result err (Proved (Maybe a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> Maybe a -> view
toView FormId
i Maybe a
initialValue
          , [(FormRange, err)] -> Result err (Proved (Maybe a))
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, err
err)]
          )
      Value input
Missing -> (View err view, Result err (Proved (Maybe a)))
-> FormState m (View err view, Result err (Proved (Maybe a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> Maybe a -> view
toView FormId
i Maybe a
initialValue
        , Proved (Maybe a) -> Result err (Proved (Maybe a))
forall e ok. ok -> Result e ok
Ok (Proved (Maybe a) -> Result err (Proved (Maybe a)))
-> Proved (Maybe a) -> Result err (Proved (Maybe a))
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
            { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
            , unProved :: Maybe a
unProved = Maybe a
forall a. Maybe a
Nothing
            }
        )

-- | used for elements like @\<input type=\"reset\"\>@ which take a value, but are never present in the form data set.
inputNoData :: (Monad m)
  => FormState m FormId
  -> (FormId -> view)
  -> Form m input err view ()
inputNoData :: FormState m FormId -> (FormId -> view) -> Form m input err view ()
inputNoData FormState m FormId
i' FormId -> view
toView =
  (input -> m (Either err ()))
-> m ()
-> FormState m (View err view, Result err (Proved ()))
-> Form m input err view ()
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (() -> input -> m (Either err ())
forall (m :: * -> *) a input err.
Applicative m =>
a -> input -> m (Either err a)
successDecode ()) (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (FormState m (View err view, Result err (Proved ()))
 -> Form m input err view ())
-> FormState m (View err view, Result err (Proved ()))
-> Form m input err view ()
forall a b. (a -> b) -> a -> b
$ do
    FormId
i <- FormState m FormId
i'
    (View err view, Result err (Proved ()))
-> FormState m (View err view, Result err (Proved ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> view
toView FormId
i
      , Proved () -> Result err (Proved ())
forall e ok. ok -> Result e ok
Ok Proved :: forall a. FormRange -> a -> Proved a
Proved
          { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
          , unProved :: ()
unProved = ()
          }
      )

-- | used for @\<input type=\"file\"\>@
inputFile :: forall m ft input err view. (Monad m, FormInput input, FormError input err, Environment m input, ft ~ FileType input, Monoid ft)
  => FormState m FormId
  -> (FormId -> view)
  -> Form m input err view (FileType input)
inputFile :: FormState m FormId
-> (FormId -> view) -> Form m input err view (FileType input)
inputFile FormState m FormId
i' FormId -> view
toView =
  (input -> m (Either err ft))
-> m ft
-> FormState m (View err view, Result err (Proved ft))
-> Form m input err view ft
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (Either err ft -> m (Either err ft)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err ft -> m (Either err ft))
-> (input -> Either err ft) -> input -> m (Either err ft)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Either err ft
forall input err.
(FormInput input, FormError input err) =>
input -> Either err (FileType input)
getInputFile) (ft -> m ft
forall (f :: * -> *) a. Applicative f => a -> f a
pure ft
forall a. Monoid a => a
mempty) (FormState m (View err view, Result err (Proved ft))
 -> Form m input err view ft)
-> FormState m (View err view, Result err (Proved ft))
-> Form m input err view ft
forall a b. (a -> b) -> a -> b
$ do -- FIXME
    FormId
i <- FormState m FormId
i'
    Value input
v <- FormId -> FormState m (Value input)
forall (m :: * -> *) input.
Environment m input =>
FormId -> FormState m (Value input)
getFormInput' FormId
i
    case Value input
v of
      Value input
Default ->
        (View err view, Result err (Proved ft))
-> FormState m (View err view, Result err (Proved ft))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> view
toView FormId
i
          , [(FormRange, err)] -> Result err (Proved ft)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, CommonFormError input -> err
forall input err.
FormError input err =>
CommonFormError input -> err
commonFormError (FormId -> CommonFormError input
forall input. FormId -> CommonFormError input
InputMissing FormId
i :: CommonFormError input) :: err)]
          )
      Found input
x -> case input -> Either err (FileType input)
forall input err.
(FormInput input, FormError input err) =>
input -> Either err (FileType input)
getInputFile input
x of
        Right FileType input
a -> (View err view, Result err (Proved ft))
-> FormState m (View err view, Result err (Proved ft))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> view
toView FormId
i
          , Proved ft -> Result err (Proved ft)
forall e ok. ok -> Result e ok
Ok Proved :: forall a. FormRange -> a -> Proved a
Proved
              { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
i
              , unProved :: ft
unProved = ft
FileType input
a
              }
          )
        Left err
err -> (View err view, Result err (Proved ft))
-> FormState m (View err view, Result err (Proved ft))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> view
toView FormId
i
          , [(FormRange, err)] -> Result err (Proved ft)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, err
err)]
          )
      Value input
Missing ->
        (View err view, Result err (Proved ft))
-> FormState m (View err view, Result err (Proved ft))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> view
toView FormId
i
          , [(FormRange, err)] -> Result err (Proved ft)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, CommonFormError input -> err
forall input err.
FormError input err =>
CommonFormError input -> err
commonFormError (FormId -> CommonFormError input
forall input. FormId -> CommonFormError input
InputMissing FormId
i :: CommonFormError input) ::err)]
          )

-- | used for groups of checkboxes, @\<select multiple=\"multiple\"\>@ boxes
inputMulti :: forall m input err view a lbl. (FormError input err, FormInput input, Environment m input, Eq a)
  => FormState m FormId
  -> [(a, lbl)] -- ^ value, label, initially checked
  -> (input -> Either err [a])
  -> (FormId -> [Choice lbl a] -> view) -- ^ function which generates the view
  -> (a -> Bool) -- ^ isChecked/isSelected initially
  -> Form m input err view [a]
inputMulti :: FormState m FormId
-> [(a, lbl)]
-> (input -> Either err [a])
-> (FormId -> [Choice lbl a] -> view)
-> (a -> Bool)
-> Form m input err view [a]
inputMulti FormState m FormId
i' [(a, lbl)]
choices input -> Either err [a]
fromInput FormId -> [Choice lbl a] -> view
mkView a -> Bool
isSelected =
  (input -> m (Either err [a]))
-> m [a]
-> FormState m (View err view, Result err (Proved [a]))
-> Form m input err view [a]
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (Either err [a] -> m (Either err [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err [a] -> m (Either err [a]))
-> (input -> Either err [a]) -> input -> m (Either err [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Either err [a]
fromInput) ([a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ ((a, lbl) -> a) -> [(a, lbl)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, lbl) -> a
forall a b. (a, b) -> a
fst [(a, lbl)]
choices) (FormState m (View err view, Result err (Proved [a]))
 -> Form m input err view [a])
-> FormState m (View err view, Result err (Proved [a]))
-> Form m input err view [a]
forall a b. (a -> b) -> a -> b
$ do
    FormId
i <- FormState m FormId
i'
    Value input
inp <- FormId -> FormState m (Value input)
forall (m :: * -> *) input.
Environment m input =>
FormId -> FormState m (Value input)
getFormInput' FormId
i
    case Value input
inp of
      Value input
Default -> do
        let ([(a, lbl, Bool)]
choices', [a]
vals) =
              ((a, lbl) -> ([(a, lbl, Bool)], [a]) -> ([(a, lbl, Bool)], [a]))
-> ([(a, lbl, Bool)], [a]) -> [(a, lbl)] -> ([(a, lbl, Bool)], [a])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                ( \(a
a, lbl
lbl) ([(a, lbl, Bool)]
cs, [a]
vs) ->
                  if a -> Bool
isSelected a
a
                  then ((a
a, lbl
lbl, Bool
True) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
cs, a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
vs)
                  else ((a
a, lbl
lbl, Bool
False) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
cs, [a]
vs)
                )
                ([], [])
                [(a, lbl)]
choices
        view
view' <- FormId -> [Choice lbl a] -> view
mkView FormId
i ([Choice lbl a] -> view)
-> StateT FormRange m [Choice lbl a] -> StateT FormRange m view
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormId -> [(a, lbl, Bool)] -> StateT FormRange m [Choice lbl a]
forall (m :: * -> *) a lbl.
Monad m =>
FormId -> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices FormId
i [(a, lbl, Bool)]
choices'
        FormId
-> view
-> [a]
-> FormState m (View err view, Result err (Proved [a]))
forall (m :: * -> *) view a err.
Monad m =>
FormId
-> view -> a -> FormState m (View err view, Result err (Proved a))
mkOk FormId
i view
view' [a]
vals
      Value input
Missing -> do
        -- just means that no checkboxes were checked
        view
view' <- FormId -> [Choice lbl a] -> view
mkView FormId
i ([Choice lbl a] -> view)
-> StateT FormRange m [Choice lbl a] -> StateT FormRange m view
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormId -> [(a, lbl, Bool)] -> StateT FormRange m [Choice lbl a]
forall (m :: * -> *) a lbl.
Monad m =>
FormId -> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices FormId
i (((a, lbl) -> (a, lbl, Bool)) -> [(a, lbl)] -> [(a, lbl, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
x, lbl
y) -> (a
x, lbl
y, Bool
False)) [(a, lbl)]
choices)
        FormId
-> view
-> [a]
-> FormState m (View err view, Result err (Proved [a]))
forall (m :: * -> *) view a err.
Monad m =>
FormId
-> view -> a -> FormState m (View err view, Result err (Proved a))
mkOk FormId
i view
view' []
      Found input
v -> do
        let keys :: [a]
keys = [a] -> Either err [a] -> [a]
forall b a. b -> Either a b -> b
fromRight [] (Either err [a] -> [a]) -> Either err [a] -> [a]
forall a b. (a -> b) -> a -> b
$ input -> Either err [a]
fromInput input
v
            ([(a, lbl, Bool)]
choices', [a]
vals) =
              ((a, lbl) -> ([(a, lbl, Bool)], [a]) -> ([(a, lbl, Bool)], [a]))
-> ([(a, lbl, Bool)], [a]) -> [(a, lbl)] -> ([(a, lbl, Bool)], [a])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                ( \(a
a, lbl
lbl) ([(a, lbl, Bool)]
c, [a]
v0) ->
                  if a
a a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
keys
                  then ((a
a, lbl
lbl, Bool
True) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
c, a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
v0)
                  else ((a
a, lbl
lbl, Bool
False) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
c, [a]
v0)
                )
                ([], [])
                [(a, lbl)]
choices
        view
view' <- FormId -> [Choice lbl a] -> view
mkView FormId
i ([Choice lbl a] -> view)
-> StateT FormRange m [Choice lbl a] -> StateT FormRange m view
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormId -> [(a, lbl, Bool)] -> StateT FormRange m [Choice lbl a]
forall (m :: * -> *) a lbl.
Monad m =>
FormId -> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices FormId
i [(a, lbl, Bool)]
choices'
        FormId
-> view
-> [a]
-> FormState m (View err view, Result err (Proved [a]))
forall (m :: * -> *) view a err.
Monad m =>
FormId
-> view -> a -> FormState m (View err view, Result err (Proved a))
mkOk FormId
i view
view' [a]
vals

augmentChoices :: (Monad m) => FormId ->  [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices :: FormId -> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices FormId
i [(a, lbl, Bool)]
choices = ((a, lbl, Bool) -> StateT FormRange m (Choice lbl a))
-> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FormId -> (a, lbl, Bool) -> StateT FormRange m (Choice lbl a)
forall (m :: * -> *) a lbl.
Monad m =>
FormId -> (a, lbl, Bool) -> FormState m (Choice lbl a)
augmentChoice FormId
i) [(a, lbl, Bool)]
choices

augmentChoice :: (Monad m) => FormId -> (a, lbl, Bool) -> FormState m (Choice lbl a)
augmentChoice :: FormId -> (a, lbl, Bool) -> FormState m (Choice lbl a)
augmentChoice FormId
i (a
a, lbl
lbl, Bool
selected) = do
  Choice lbl a -> FormState m (Choice lbl a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Choice lbl a -> FormState m (Choice lbl a))
-> Choice lbl a -> FormState m (Choice lbl a)
forall a b. (a -> b) -> a -> b
$ FormId -> lbl -> Bool -> a -> Choice lbl a
forall lbl a. FormId -> lbl -> Bool -> a -> Choice lbl a
Choice FormId
i lbl
lbl Bool
selected a
a

-- | a choice for inputChoice
data Choice lbl a = Choice
  { Choice lbl a -> FormId
choiceFormId :: FormId -- ^ the formId
  , Choice lbl a -> lbl
choiceLabel :: lbl -- ^ <label>
  , Choice lbl a -> Bool
choiceIsSelected :: Bool -- ^ is the choice selected
  , Choice lbl a -> a
choiceVal :: a -- ^ the haskell value of the choice
  }

-- | radio buttons, single @\<select\>@ boxes
inputChoice :: forall a m err input lbl view. (FormError input err, FormInput input, Monad m, Eq a, Monoid view, Environment m input)
  => FormState m FormId
  -> (a -> Bool) -- ^ is default
  -> NonEmpty (a, lbl) -- ^ value, label
  -> (input -> Either err a)
  -> (FormId -> [Choice lbl a] -> view) -- ^ function which generates the view
  -> Form m input err view a
inputChoice :: FormState m FormId
-> (a -> Bool)
-> NonEmpty (a, lbl)
-> (input -> Either err a)
-> (FormId -> [Choice lbl a] -> view)
-> Form m input err view a
inputChoice FormState m FormId
i' a -> Bool
isDefault choices :: NonEmpty (a, lbl)
choices@((a, lbl)
headChoice :| [(a, lbl)]
_) input -> Either err a
fromInput FormId -> [Choice lbl a] -> view
mkView = do
  let f :: FormState m (View err view, Result err (Proved a))
-> Form m input err view a
f = case (a -> Bool) -> NonEmpty a -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find a -> Bool
isDefault (((a, lbl) -> a) -> NonEmpty (a, lbl) -> NonEmpty a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, lbl) -> a
forall a b. (a, b) -> a
fst NonEmpty (a, lbl)
choices) of
        Maybe a
Nothing -> (input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (Either err a -> m (Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err a -> m (Either err a))
-> (input -> Either err a) -> input -> m (Either err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Either err a
fromInput) (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ (a, lbl) -> a
forall a b. (a, b) -> a
fst (a, lbl)
headChoice)
        Just a
defChoice -> (input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (Either err a -> m (Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err a -> m (Either err a))
-> (input -> Either err a) -> input -> m (Either err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Either err a
fromInput) (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
defChoice)
  FormState m (View err view, Result err (Proved a))
-> Form m input err view a
f (FormState m (View err view, Result err (Proved a))
 -> Form m input err view a)
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall a b. (a -> b) -> a -> b
$ do
    FormId
i <- FormState m FormId
i'
    Value input
inp <- FormId -> FormState m (Value input)
forall (m :: * -> *) input.
Environment m input =>
FormId -> FormState m (Value input)
getFormInput' FormId
i
    case Value input
inp of
      Value input
Default -> do
        let ([(a, lbl, Bool)]
choices', Maybe a
def) = NonEmpty (a, lbl) -> ([(a, lbl, Bool)], Maybe a)
forall (f :: * -> *).
Foldable f =>
f (a, lbl) -> ([(a, lbl, Bool)], Maybe a)
markSelected NonEmpty (a, lbl)
choices
        view
view' <- FormId -> [Choice lbl a] -> view
mkView FormId
i ([Choice lbl a] -> view)
-> StateT FormRange m [Choice lbl a] -> StateT FormRange m view
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormId -> [(a, lbl, Bool)] -> StateT FormRange m [Choice lbl a]
forall (m :: * -> *) a lbl.
Monad m =>
FormId -> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices FormId
i [(a, lbl, Bool)]
choices'
        FormId
-> view
-> Maybe a
-> FormState m (View err view, Result err (Proved a))
mkOk' FormId
i view
view' Maybe a
def
      Value input
Missing -> do
        -- can happen if no choices where checked
        let ([(a, lbl, Bool)]
choices', Maybe a
def) = NonEmpty (a, lbl) -> ([(a, lbl, Bool)], Maybe a)
forall (f :: * -> *).
Foldable f =>
f (a, lbl) -> ([(a, lbl, Bool)], Maybe a)
markSelected NonEmpty (a, lbl)
choices
        view
view' <- FormId -> [Choice lbl a] -> view
mkView FormId
i ([Choice lbl a] -> view)
-> StateT FormRange m [Choice lbl a] -> StateT FormRange m view
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormId -> [(a, lbl, Bool)] -> StateT FormRange m [Choice lbl a]
forall (m :: * -> *) a lbl.
Monad m =>
FormId -> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices FormId
i [(a, lbl, Bool)]
choices'
        FormId
-> view
-> Maybe a
-> FormState m (View err view, Result err (Proved a))
mkOk' FormId
i view
view' Maybe a
def
      Found input
v -> do
        case input -> Either err a
fromInput input
v of
          Left err
err -> do
            let choices' :: [(a, lbl, Bool)]
choices' =
                  ((a, lbl) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)])
-> [(a, lbl, Bool)] -> NonEmpty (a, lbl) -> [(a, lbl, Bool)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                    ( \(a
a, lbl
lbl) [(a, lbl, Bool)]
c -> (a
a, lbl
lbl, Bool
False) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
c )
                    []
                    NonEmpty (a, lbl)
choices
            view
view' <- FormId -> [Choice lbl a] -> view
mkView FormId
i ([Choice lbl a] -> view)
-> StateT FormRange m [Choice lbl a] -> StateT FormRange m view
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormId -> [(a, lbl, Bool)] -> StateT FormRange m [Choice lbl a]
forall (m :: * -> *) a lbl.
Monad m =>
FormId -> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices FormId
i [(a, lbl, Bool)]
choices'
            (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const view
view'
              , [(FormRange, err)] -> Result err (Proved a)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, err
err)]
              )
          Right a
key -> do
            let ([(a, lbl, Bool)]
choices', Maybe a
mval) =
                  ((a, lbl)
 -> ([(a, lbl, Bool)], Maybe a) -> ([(a, lbl, Bool)], Maybe a))
-> ([(a, lbl, Bool)], Maybe a)
-> NonEmpty (a, lbl)
-> ([(a, lbl, Bool)], Maybe a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                    ( \(a
a, lbl
lbl) ([(a, lbl, Bool)]
c, Maybe a
v0) ->
                      if a
key a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
                      then ((a
a, lbl
lbl, Bool
True) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
c, a -> Maybe a
forall a. a -> Maybe a
Just a
a)
                      else ((a
a, lbl
lbl, Bool
False) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
c, Maybe a
v0)
                    )
                    ([], Maybe a
forall a. Maybe a
Nothing)
                    NonEmpty (a, lbl)
choices
            view
view' <- FormId -> [Choice lbl a] -> view
mkView FormId
i ([Choice lbl a] -> view)
-> StateT FormRange m [Choice lbl a] -> StateT FormRange m view
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormId -> [(a, lbl, Bool)] -> StateT FormRange m [Choice lbl a]
forall (m :: * -> *) a lbl.
Monad m =>
FormId -> [(a, lbl, Bool)] -> FormState m [Choice lbl a]
augmentChoices FormId
i [(a, lbl, Bool)]
choices'
            case Maybe a
mval of
              Maybe a
Nothing -> (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const view
view'
                , [(FormRange, err)] -> Result err (Proved a)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, CommonFormError input -> err
forall input err.
FormError input err =>
CommonFormError input -> err
commonFormError (FormId -> CommonFormError input
forall input. FormId -> CommonFormError input
InputMissing FormId
i :: CommonFormError input) :: err)]
                )
              Just a
val -> FormId
-> view -> a -> FormState m (View err view, Result err (Proved a))
forall (m :: * -> *) view a err.
Monad m =>
FormId
-> view -> a -> FormState m (View err view, Result err (Proved a))
mkOk FormId
i view
view' a
val
  where
    mkOk' :: FormId
-> view
-> Maybe a
-> FormState m (View err view, Result err (Proved a))
mkOk' FormId
i view
view' (Just a
val) = FormId
-> view -> a -> FormState m (View err view, Result err (Proved a))
forall (m :: * -> *) view a err.
Monad m =>
FormId
-> view -> a -> FormState m (View err view, Result err (Proved a))
mkOk FormId
i view
view' a
val
    mkOk' FormId
i view
view' Maybe a
Nothing =
      (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const view
view'
        , [(FormRange, err)] -> Result err (Proved a)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormRange
unitRange FormId
i, CommonFormError input -> err
forall input err.
FormError input err =>
CommonFormError input -> err
commonFormError (CommonFormError input
forall input. CommonFormError input
MissingDefaultValue :: CommonFormError input) :: err)]
        )
    markSelected :: Foldable f => f (a, lbl) -> ([(a, lbl, Bool)], Maybe a)
    markSelected :: f (a, lbl) -> ([(a, lbl, Bool)], Maybe a)
markSelected f (a, lbl)
cs =
      ((a, lbl)
 -> ([(a, lbl, Bool)], Maybe a) -> ([(a, lbl, Bool)], Maybe a))
-> ([(a, lbl, Bool)], Maybe a)
-> f (a, lbl)
-> ([(a, lbl, Bool)], Maybe a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        ( \(a
a, lbl
lbl) ([(a, lbl, Bool)]
vs, Maybe a
ma) ->
          if a -> Bool
isDefault a
a
          then ((a
a, lbl
lbl, Bool
True) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
vs, a -> Maybe a
forall a. a -> Maybe a
Just a
a)
          else ((a
a, lbl
lbl, Bool
False) (a, lbl, Bool) -> [(a, lbl, Bool)] -> [(a, lbl, Bool)]
forall a. a -> [a] -> [a]
: [(a, lbl, Bool)]
vs, Maybe a
ma)
        )
        ([], Maybe a
forall a. Maybe a
Nothing)
        f (a, lbl)
cs

-- | used to create @\<label\>@ elements
label :: Monad m
  => FormState m FormId
  -> (FormId -> view)
  -> Form m input err view ()
label :: FormState m FormId -> (FormId -> view) -> Form m input err view ()
label FormState m FormId
i' FormId -> view
f = (input -> m (Either err ()))
-> m ()
-> FormState m (View err view, Result err (Proved ()))
-> Form m input err view ()
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (() -> input -> m (Either err ())
forall (m :: * -> *) a input err.
Applicative m =>
a -> input -> m (Either err a)
successDecode ()) (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (FormState m (View err view, Result err (Proved ()))
 -> Form m input err view ())
-> FormState m (View err view, Result err (Proved ()))
-> Form m input err view ()
forall a b. (a -> b) -> a -> b
$ do
  FormId
id' <- FormState m FormId
i'
  (View err view, Result err (Proved ()))
-> FormState m (View err view, Result err (Proved ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (view -> [(FormRange, err)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, err)] -> view)
-> view -> [(FormRange, err)] -> view
forall a b. (a -> b) -> a -> b
$ FormId -> view
f FormId
id')
    , Proved () -> Result err (Proved ())
forall e ok. ok -> Result e ok
Ok (Proved () -> Result err (Proved ()))
-> Proved () -> Result err (Proved ())
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
        { pos :: FormRange
pos = FormId -> FormRange
unitRange FormId
id'
        , unProved :: ()
unProved = ()
        }
    )

-- | used to add a list of err messages to a 'Form'
--
-- This function automatically takes care of extracting only the
-- errors that are relevent to the form element it is attached to via
-- '<*' or '*>'.
errors :: Monad m
  => ([err] -> view) -- ^ function to convert the err messages into a view
  -> Form m input err view ()
errors :: ([err] -> view) -> Form m input err view ()
errors [err] -> view
f = (input -> m (Either err ()))
-> m ()
-> FormState m (View err view, Result err (Proved ()))
-> Form m input err view ()
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (() -> input -> m (Either err ())
forall (m :: * -> *) a input err.
Applicative m =>
a -> input -> m (Either err a)
successDecode ()) (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (FormState m (View err view, Result err (Proved ()))
 -> Form m input err view ())
-> FormState m (View err view, Result err (Proved ()))
-> Form m input err view ()
forall a b. (a -> b) -> a -> b
$ do
  FormRange
range <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  (View err view, Result err (Proved ()))
-> FormState m (View err view, Result err (Proved ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View ([err] -> view
f ([err] -> view)
-> ([(FormRange, err)] -> [err]) -> [(FormRange, err)] -> view
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormRange -> [(FormRange, err)] -> [err]
forall e. FormRange -> [(FormRange, e)] -> [e]
retainErrors FormRange
range)
    , Proved () -> Result err (Proved ())
forall e ok. ok -> Result e ok
Ok (Proved () -> Result err (Proved ()))
-> Proved () -> Result err (Proved ())
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
        { pos :: FormRange
pos = FormRange
range
        , unProved :: ()
unProved = ()
        }
    )

-- | similar to 'errors' but includes err messages from children of the form as well.
childErrors :: Monad m
  => ([err] -> view)
  -> Form m input err view ()
childErrors :: ([err] -> view) -> Form m input err view ()
childErrors [err] -> view
f = (input -> m (Either err ()))
-> m ()
-> FormState m (View err view, Result err (Proved ()))
-> Form m input err view ()
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form (() -> input -> m (Either err ())
forall (m :: * -> *) a input err.
Applicative m =>
a -> input -> m (Either err a)
successDecode ()) (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (FormState m (View err view, Result err (Proved ()))
 -> Form m input err view ())
-> FormState m (View err view, Result err (Proved ()))
-> Form m input err view ()
forall a b. (a -> b) -> a -> b
$ do
  FormRange
range <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  (View err view, Result err (Proved ()))
-> FormState m (View err view, Result err (Proved ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View ([err] -> view
f ([err] -> view)
-> ([(FormRange, err)] -> [err]) -> [(FormRange, err)] -> view
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormRange -> [(FormRange, err)] -> [err]
forall e. FormRange -> [(FormRange, e)] -> [e]
retainChildErrors FormRange
range)
    , Proved () -> Result err (Proved ())
forall e ok. ok -> Result e ok
Ok (Proved () -> Result err (Proved ()))
-> Proved () -> Result err (Proved ())
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
        { pos :: FormRange
pos = FormRange
range
        , unProved :: ()
unProved = ()
        }
    )

-- | modify the view of a form based on its child errors
withChildErrors :: Monad m
  => (view -> [err] -> view)
  -> Form m input err view a
  -> Form m input err view a
withChildErrors :: (view -> [err] -> view)
-> Form m input err view a -> Form m input err view a
withChildErrors view -> [err] -> view
f Form{input -> m (Either err a)
formDecodeInput :: forall (m :: * -> *) input err view a.
Form m input err view a -> input -> m (Either err a)
formDecodeInput :: input -> m (Either err a)
formDecodeInput, m a
formInitialValue :: forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue :: m a
formInitialValue, FormState m (View err view, Result err (Proved a))
formFormlet :: FormState m (View err view, Result err (Proved a))
formFormlet :: forall (m :: * -> *) input err view a.
Form m input err view a
-> FormState m (View err view, Result err (Proved a))
formFormlet} = (input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form input -> m (Either err a)
formDecodeInput m a
formInitialValue (FormState m (View err view, Result err (Proved a))
 -> Form m input err view a)
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall a b. (a -> b) -> a -> b
$ do
  (View [(FormRange, err)] -> view
v, Result err (Proved a)
r) <- FormState m (View err view, Result err (Proved a))
formFormlet
  FormRange
range <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ \[(FormRange, err)]
x ->
        let errs :: [err]
errs = FormRange -> [(FormRange, err)] -> [err]
forall e. FormRange -> [(FormRange, e)] -> [e]
retainChildErrors FormRange
range [(FormRange, err)]
x
        in view -> [err] -> view
f ([(FormRange, err)] -> view
v [(FormRange, err)]
x) [err]
errs
    , Result err (Proved a)
r
    )

-- | modify the view of a form based on its errors
withErrors :: Monad m
  => (view -> [err] -> view)
  -> Form m input err view a
  -> Form m input err view a
withErrors :: (view -> [err] -> view)
-> Form m input err view a -> Form m input err view a
withErrors view -> [err] -> view
f Form{input -> m (Either err a)
formDecodeInput :: input -> m (Either err a)
formDecodeInput :: forall (m :: * -> *) input err view a.
Form m input err view a -> input -> m (Either err a)
formDecodeInput, m a
formInitialValue :: m a
formInitialValue :: forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue, FormState m (View err view, Result err (Proved a))
formFormlet :: FormState m (View err view, Result err (Proved a))
formFormlet :: forall (m :: * -> *) input err view a.
Form m input err view a
-> FormState m (View err view, Result err (Proved a))
formFormlet} = (input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall (m :: * -> *) input err view a.
(input -> m (Either err a))
-> m a
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
Form input -> m (Either err a)
formDecodeInput m a
formInitialValue (FormState m (View err view, Result err (Proved a))
 -> Form m input err view a)
-> FormState m (View err view, Result err (Proved a))
-> Form m input err view a
forall a b. (a -> b) -> a -> b
$ do
  (View [(FormRange, err)] -> view
v, Result err (Proved a)
r) <- FormState m (View err view, Result err (Proved a))
formFormlet
  FormRange
range <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  (View err view, Result err (Proved a))
-> FormState m (View err view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ([(FormRange, err)] -> view) -> View err view
forall err v. ([(FormRange, err)] -> v) -> View err v
View (([(FormRange, err)] -> view) -> View err view)
-> ([(FormRange, err)] -> view) -> View err view
forall a b. (a -> b) -> a -> b
$ \[(FormRange, err)]
x ->
        let errs :: [err]
errs = FormRange -> [(FormRange, err)] -> [err]
forall e. FormRange -> [(FormRange, e)] -> [e]
retainErrors FormRange
range [(FormRange, err)]
x
        in view -> [err] -> view
f ([(FormRange, err)] -> view
v [(FormRange, err)]
x) [err]
errs
    , Result err (Proved a)
r
    )