{-# LANGUAGE
    DeriveFunctor
  , FlexibleInstances
  , FunctionalDependencies
  , GeneralizedNewtypeDeriving
  , LambdaCase
  , NamedFieldPuns
  , OverloadedStrings
  , RankNTypes
  , RecordWildCards
  , ScopedTypeVariables
  , StandaloneDeriving
  , TypeApplications
#-}

-- | The core module for @ditto@.
--
-- This module provides the @Form@ type and helper functions
-- for constructing typesafe forms inside arbitrary "views" / web frameworks.
-- @ditto@ is meant to be a generalized formlet library used to write
-- formlet libraries specific to a web / gui framework
module Ditto.Core (
  -- * Form types
  -- | The representation of formlets
    FormState
  , Form(..)
  -- * Environment
  -- | The interface to a given web framework
  , Environment(..)
  , NoEnvironment(..)
  , WithEnvironment(..)
  , noEnvironment
  -- * Utility functions
  , (@$)
  , catchFormError
  , catchFormErrorM
  , eitherForm
  , getFormId
  , getFormInput
  , getFormInput'
  , getFormRange
  , getNamedFormId
  , incrementFormId
  , isInRange
  , mapResult
  , mapView
  , mkOk
  , retainChildErrors
  , retainErrors
  , runForm
  , runForm_
  , successDecode
  , unitRange
  , view
  , viewForm
  , pureRes
  , liftForm
  ) where

import Control.Applicative
import Control.Monad.Reader
import Control.Monad.State.Lazy
import Data.Bifunctor
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import Ditto.Backend
import Ditto.Types
------------------------------------------------------------------------------
-- Form types
------------------------------------------------------------------------------

-- | The Form's state is just the range of identifiers so far
type FormState m = StateT FormRange m

-- | @ditto@'s representation of a formlet
--
-- It's reccommended to use @ApplicativeDo@ where possible when constructing forms
data Form m input err view a = Form
  { Form m input err view a -> input -> m (Either err a)
formDecodeInput :: input -> m (Either err a) -- ^ Decode the value from the input
  , Form m input err view a -> m a
formInitialValue :: m a -- ^ The initial value
  , Form m input err view a
-> FormState m (View err view, Result err (Proved a))
formFormlet :: FormState m (View err view, Result err (Proved a)) -- ^ A @FormState@ which produces a @View@ and a @Result@
  } deriving (a -> Form m input err view b -> Form m input err view a
(a -> b) -> Form m input err view a -> Form m input err view b
(forall a b.
 (a -> b) -> Form m input err view a -> Form m input err view b)
-> (forall a b.
    a -> Form m input err view b -> Form m input err view a)
-> Functor (Form m input err view)
forall a b. a -> Form m input err view b -> Form m input err view a
forall a b.
(a -> b) -> Form m input err view a -> Form m input err view b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) input err view a b.
Functor m =>
a -> Form m input err view b -> Form m input err view a
forall (m :: * -> *) input err view a b.
Functor m =>
(a -> b) -> Form m input err view a -> Form m input err view b
<$ :: a -> Form m input err view b -> Form m input err view a
$c<$ :: forall (m :: * -> *) input err view a b.
Functor m =>
a -> Form m input err view b -> Form m input err view a
fmap :: (a -> b) -> Form m input err view a -> Form m input err view b
$cfmap :: forall (m :: * -> *) input err view a b.
Functor m =>
(a -> b) -> Form m input err view a -> Form m input err view b
Functor)

instance (Monad m, Monoid view) => Applicative (Form m input err view) where

  pure :: a -> Form m input err view a
pure a
x = (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 (a -> input -> m (Either err a)
forall (m :: * -> *) a input err.
Applicative m =>
a -> input -> m (Either err a)
successDecode a
x) (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (a -> FormState m (View err view, Result err (Proved a))
forall (m :: * -> *) view a err.
(Monad m, Monoid view) =>
a -> FormState m (view, Result err (Proved a))
pureFormState a
x)

  (Form input -> m (Either err (a -> b))
df m (a -> b)
ivF FormState m (View err view, Result err (Proved (a -> b)))
frmF) <*> :: Form m input err view (a -> b)
-> Form m input err view a -> Form m input err view b
<*> (Form input -> m (Either err a)
da m a
ivA FormState m (View err view, Result err (Proved a))
frmA) = Form :: 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
    { formDecodeInput :: input -> m (Either err b)
formDecodeInput = \input
inp -> (Either err (a -> b) -> Either err a -> Either err b)
-> m (Either err (a -> b)) -> m (Either err a) -> m (Either err b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Either err (a -> b) -> Either err a -> Either err b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (input -> m (Either err (a -> b))
df input
inp) (input -> m (Either err a)
da input
inp)
    , formInitialValue :: m b
formInitialValue = m (a -> b)
ivF m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
ivA
    , formFormlet :: FormState m (View err view, Result err (Proved b))
formFormlet = do
        ((View err view
view1, Result err (Proved (a -> b))
fok), (View err view
view2, Result err (Proved a)
aok)) <-
          FormState
  m
  ((View err view, Result err (Proved (a -> b))),
   (View err view, Result err (Proved a)))
-> FormState
     m
     ((View err view, Result err (Proved (a -> b))),
      (View err view, Result err (Proved a)))
forall (m :: * -> *) a. Monad m => FormState m a -> FormState m a
bracketState (FormState
   m
   ((View err view, Result err (Proved (a -> b))),
    (View err view, Result err (Proved a)))
 -> FormState
      m
      ((View err view, Result err (Proved (a -> b))),
       (View err view, Result err (Proved a))))
-> FormState
     m
     ((View err view, Result err (Proved (a -> b))),
      (View err view, Result err (Proved a)))
-> FormState
     m
     ((View err view, Result err (Proved (a -> b))),
      (View err view, Result err (Proved a)))
forall a b. (a -> b) -> a -> b
$ do
            (View err view, Result err (Proved (a -> b)))
res1 <- FormState m (View err view, Result err (Proved (a -> b)))
frmF
            FormState m ()
forall (m :: * -> *). Monad m => FormState m ()
incrementFormRange
            (View err view, Result err (Proved a))
res2 <- FormState m (View err view, Result err (Proved a))
frmA
            ((View err view, Result err (Proved (a -> b))),
 (View err view, Result err (Proved a)))
-> FormState
     m
     ((View err view, Result err (Proved (a -> b))),
      (View err view, Result err (Proved a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((View err view, Result err (Proved (a -> b)))
res1, (View err view, Result err (Proved a))
res2)
        let view' :: View err view
view' = View err view
view1 View err view -> View err view -> View err view
forall a. Semigroup a => a -> a -> a
<> View err view
view2
        case (Result err (Proved (a -> b))
fok, Result err (Proved a)
aok) of
          (Error [(FormRange, err)]
errs1, Error [(FormRange, err)]
errs2) -> (View err view, Result err (Proved b))
-> FormState m (View err view, Result err (Proved b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (View err view
view', [(FormRange, err)] -> Result err (Proved b)
forall e ok. [(FormRange, e)] -> Result e ok
Error ([(FormRange, err)] -> Result err (Proved b))
-> [(FormRange, err)] -> Result err (Proved b)
forall a b. (a -> b) -> a -> b
$ [(FormRange, err)]
errs1 [(FormRange, err)] -> [(FormRange, err)] -> [(FormRange, err)]
forall a. [a] -> [a] -> [a]
++ [(FormRange, err)]
errs2)
          (Error [(FormRange, err)]
errs1, Result err (Proved a)
_) -> (View err view, Result err (Proved b))
-> FormState m (View err view, Result err (Proved b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (View err view
view', [(FormRange, err)] -> Result err (Proved b)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormRange, err)]
errs1)
          (Result err (Proved (a -> b))
_, Error [(FormRange, err)]
errs2) -> (View err view, Result err (Proved b))
-> FormState m (View err view, Result err (Proved b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (View err view
view', [(FormRange, err)] -> Result err (Proved b)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormRange, err)]
errs2)
          (Ok (Proved (FormRange FormId
l FormId
_) a -> b
f), Ok (Proved (FormRange FormId
_ FormId
r) a
a)) ->
            (View err view, Result err (Proved b))
-> FormState m (View err view, Result err (Proved b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              ( View err view
view'
              , Proved b -> Result err (Proved b)
forall e ok. ok -> Result e ok
Ok (Proved b -> Result err (Proved b))
-> Proved b -> Result err (Proved b)
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
                { pos :: FormRange
pos = FormId -> FormId -> FormRange
FormRange FormId
l FormId
r
                , unProved :: b
unProved = a -> b
f a
a
                }
              )
    }

  Form m input err view a
f1 *> :: Form m input err view a
-> Form m input err view b -> Form m input err view b
*> Form m input err view b
f2 = (input -> m (Either err b))
-> m b
-> FormState m (View err view, Result err (Proved b))
-> Form m input err view b
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 (Form m input err view b -> input -> m (Either err b)
forall (m :: * -> *) input err view a.
Form m input err view a -> input -> m (Either err a)
formDecodeInput Form m input err view b
f2) (Form m input err view b -> m b
forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue Form m input err view b
f2) (FormState m (View err view, Result err (Proved b))
 -> Form m input err view b)
-> FormState m (View err view, Result err (Proved b))
-> Form m input err view b
forall a b. (a -> b) -> a -> b
$ do
    -- Evaluate the form that matters first, so we have a correct range set
    (View err view
v2, Result err (Proved b)
r) <- Form m input err view b
-> FormState m (View err view, Result err (Proved b))
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 b
f2
    (View err view
v1, 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
f1
    (View err view, Result err (Proved b))
-> FormState m (View err view, Result err (Proved b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (View err view
v1 View err view -> View err view -> View err view
forall a. Semigroup a => a -> a -> a
<> View err view
v2, Result err (Proved b)
r)

  Form m input err view a
f1 <* :: Form m input err view a
-> Form m input err view b -> Form m input err view a
<* Form m input err view b
f2 = (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 (Form m input err view a -> input -> m (Either err a)
forall (m :: * -> *) input err view a.
Form m input err view a -> input -> m (Either err a)
formDecodeInput Form m input err view a
f1) (Form m input err view a -> m a
forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue Form m input err view a
f1) (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
    -- Evaluate the form that matters first, so we have a correct range set
    (View err view
v1, Result err (Proved a)
r) <- 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
f1
    (View err view
v2, Result err (Proved b)
_) <- Form m input err view b
-> FormState m (View err view, Result err (Proved b))
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 b
f2
    (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 (View err view
v1 View err view -> View err view -> View err view
forall a. Semigroup a => a -> a -> a
<> View err view
v2, Result err (Proved a)
r)

instance (Environment m input, Monoid view, FormError input err) => Monad (Form m input err view) where
  Form m input err view a
form >>= :: Form m input err view a
-> (a -> Form m input err view b) -> Form m input err view b
>>= a -> Form m input err view b
f =
    let mres :: m (Result err (Proved a))
mres = (View err view, Result err (Proved a)) -> Result err (Proved a)
forall a b. (a, b) -> b
snd ((View err view, Result err (Proved a)) -> Result err (Proved a))
-> m (View err view, Result err (Proved a))
-> m (Result err (Proved a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
forall (m :: * -> *) input err view a.
Monad m =>
Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
runForm Text
"" Form m input err view a
form
    in Form :: 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
      { formDecodeInput :: input -> m (Either err b)
formDecodeInput = \input
input -> do
          m (Result err (Proved a))
mres m (Result err (Proved a))
-> (Result err (Proved a) -> m (Either err b)) -> m (Either err b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Error {} -> do
              a
iv <- Form m input err view a -> m a
forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue Form m input err view a
form
              Form m input err view b -> input -> m (Either err b)
forall (m :: * -> *) input err view a.
Form m input err view a -> input -> m (Either err a)
formDecodeInput (a -> Form m input err view b
f a
iv) input
input
            Ok (Proved FormRange
_ a
x) -> Form m input err view b -> input -> m (Either err b)
forall (m :: * -> *) input err view a.
Form m input err view a -> input -> m (Either err a)
formDecodeInput (a -> Form m input err view b
f a
x) input
input
      , formInitialValue :: m b
formInitialValue = do
          m (Result err (Proved a))
mres m (Result err (Proved a)) -> (Result err (Proved a) -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Error {} -> do
              a
iv <- Form m input err view a -> m a
forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue Form m input err view a
form
              Form m input err view b -> m b
forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue (Form m input err view b -> m b) -> Form m input err view b -> m b
forall a b. (a -> b) -> a -> b
$ a -> Form m input err view b
f a
iv
            Ok (Proved FormRange
_ a
x) -> Form m input err view b -> m b
forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue (a -> Form m input err view b
f a
x)
      , formFormlet :: FormState m (View err view, Result err (Proved b))
formFormlet = do
          (View [(FormRange, err)] -> view
viewF0, Result err (Proved a)
res0) <- 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
form
          case Result err (Proved a)
res0 of
            Error [(FormRange, err)]
errs0 -> do
              a
iv <- m a -> StateT FormRange m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT FormRange m a) -> m a -> StateT FormRange m a
forall a b. (a -> b) -> a -> b
$ Form m input err view a -> m a
forall (m :: * -> *) input err view a.
Form m input err view a -> m a
formInitialValue Form m input err view a
form
              (View [(FormRange, err)] -> view
viewF, Result err (Proved b)
res) <- Form m input err view b
-> FormState m (View err view, Result err (Proved b))
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 b
 -> FormState m (View err view, Result err (Proved b)))
-> Form m input err view b
-> FormState m (View err view, Result err (Proved b))
forall a b. (a -> b) -> a -> b
$ a -> Form m input err view b
f a
iv
              let errs :: [(FormRange, err)]
errs = case Result err (Proved b)
res of
                    Error [(FormRange, err)]
es -> [(FormRange, err)]
es
                    Ok {} -> []
              (View err view, Result err (Proved b))
-> FormState m (View err view, Result err (Proved b))
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
$ [(FormRange, err)] -> view
viewF0 [(FormRange, err)]
errs0 view -> view -> view
forall a. Semigroup a => a -> a -> a
<> [(FormRange, err)] -> view
viewF [(FormRange, err)]
errs, [(FormRange, err)] -> Result err (Proved b)
forall e ok. [(FormRange, e)] -> Result e ok
Error ([(FormRange, err)]
errs0 [(FormRange, err)] -> [(FormRange, err)] -> [(FormRange, err)]
forall a. Semigroup a => a -> a -> a
<> [(FormRange, err)]
errs))
            Ok (Proved FormRange
_ a
x) ->
                  (View err view -> View err view)
-> (View err view, Result err (Proved b))
-> (View err view, Result err (Proved b))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\(View [(FormRange, err)] -> view
v) -> ([(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)]
e -> [(FormRange, err)] -> view
viewF0 [] view -> view -> view
forall a. Semigroup a => a -> a -> a
<> [(FormRange, err)] -> view
v [(FormRange, err)]
e)
              ((View err view, Result err (Proved b))
 -> (View err view, Result err (Proved b)))
-> FormState m (View err view, Result err (Proved b))
-> FormState m (View err view, Result err (Proved b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Form m input err view b
-> FormState m (View err view, Result err (Proved b))
forall (m :: * -> *) input err view a.
Form m input err view a
-> FormState m (View err view, Result err (Proved a))
formFormlet (a -> Form m input err view b
f a
x)
      }
  return :: a -> Form m input err view a
return = a -> Form m input err view a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >> :: Form m input err view a
-> Form m input err view b -> Form m input err view b
(>>) = Form m input err view a
-> Form m input err view b -> Form m input err view b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>) -- way more efficient than the default

instance (Monad m, Monoid view, Semigroup a) => Semigroup (Form m input err view a) where
  <> :: Form m input err view a
-> Form m input err view a -> Form m input err view a
(<>) = (a -> a -> a)
-> Form m input err view a
-> Form m input err view a
-> Form m input err view a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Monad m, Monoid view, Monoid a) => Monoid (Form m input err view a) where
  mempty :: Form m input err view a
mempty = a -> Form m input err view a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

instance Functor m => Bifunctor (Form m input err) where
  first :: (a -> b) -> Form m input err a c -> Form m input err b c
first = (a -> b) -> Form m input err a c -> Form m input err b c
forall (m :: * -> *) view view' input err a.
Functor m =>
(view -> view')
-> Form m input err view a -> Form m input err view' a
mapView
  second :: (b -> c) -> Form m input err a b -> Form m input err a c
second = (b -> c) -> Form m input err a b -> Form m input err a c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

errorInitialValue :: String
errorInitialValue :: String
errorInitialValue = String
"ditto: Ditto.Core.errorInitialValue was evaluated"

instance (Monad m, Monoid view, FormError input err, Environment m input) => Alternative (Form m input err view) where
  empty :: Form m input err view a
empty = (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)
forall (m :: * -> *) input err a.
(Applicative m, FormError input err) =>
input -> m (Either err a)
failDecodeMDF
    (String -> m a
forall a. HasCallStack => String -> a
error String
errorInitialValue)
    ((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 (View err view
forall a. Monoid a => a
mempty, [(FormRange, err)] -> Result err (Proved a)
forall e ok. [(FormRange, e)] -> Result e ok
Error []))
  Form m input err view a
formA <|> :: Form m input err view a
-> Form m input err view a -> Form m input err view a
<|> Form m input err view a
formB = do
    Either [err] a
efA <- Form m input err view a -> Form m input err view (Either [err] a)
forall (m :: * -> *) input err view a.
Monad m =>
Form m input err view a -> Form m input err view (Either [err] a)
formEither Form m input err view a
formA
    case Either [err] a
efA of
      Right{} -> Form m input err view a
formA
      Left{} -> Form m input err view a
formB

------------------------------------------------------------------------------
-- Environment
------------------------------------------------------------------------------

-- | The environment typeclass: the interface between ditto and a given framework
class Monad m => Environment m input | m -> input where
  environment :: FormId -> m (Value input)

-- | Run the form, but always return the initial value
newtype NoEnvironment input m a = NoEnvironment { NoEnvironment input m a -> m a
getNoEnvironment ::  m a }
  deriving (Applicative (NoEnvironment input m)
a -> NoEnvironment input m a
Applicative (NoEnvironment input m)
-> (forall a b.
    NoEnvironment input m a
    -> (a -> NoEnvironment input m b) -> NoEnvironment input m b)
-> (forall a b.
    NoEnvironment input m a
    -> NoEnvironment input m b -> NoEnvironment input m b)
-> (forall a. a -> NoEnvironment input m a)
-> Monad (NoEnvironment input m)
NoEnvironment input m a
-> (a -> NoEnvironment input m b) -> NoEnvironment input m b
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
forall a. a -> NoEnvironment input m a
forall a b.
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
forall a b.
NoEnvironment input m a
-> (a -> NoEnvironment input m b) -> NoEnvironment input m b
forall input (m :: * -> *).
Monad m =>
Applicative (NoEnvironment input m)
forall input (m :: * -> *) a.
Monad m =>
a -> NoEnvironment input m a
forall input (m :: * -> *) a b.
Monad m =>
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
forall input (m :: * -> *) a b.
Monad m =>
NoEnvironment input m a
-> (a -> NoEnvironment input m b) -> NoEnvironment input m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> NoEnvironment input m a
$creturn :: forall input (m :: * -> *) a.
Monad m =>
a -> NoEnvironment input m a
>> :: NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
$c>> :: forall input (m :: * -> *) a b.
Monad m =>
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
>>= :: NoEnvironment input m a
-> (a -> NoEnvironment input m b) -> NoEnvironment input m b
$c>>= :: forall input (m :: * -> *) a b.
Monad m =>
NoEnvironment input m a
-> (a -> NoEnvironment input m b) -> NoEnvironment input m b
$cp1Monad :: forall input (m :: * -> *).
Monad m =>
Applicative (NoEnvironment input m)
Monad, a -> NoEnvironment input m b -> NoEnvironment input m a
(a -> b) -> NoEnvironment input m a -> NoEnvironment input m b
(forall a b.
 (a -> b) -> NoEnvironment input m a -> NoEnvironment input m b)
-> (forall a b.
    a -> NoEnvironment input m b -> NoEnvironment input m a)
-> Functor (NoEnvironment input m)
forall a b. a -> NoEnvironment input m b -> NoEnvironment input m a
forall a b.
(a -> b) -> NoEnvironment input m a -> NoEnvironment input m b
forall input (m :: * -> *) a b.
Functor m =>
a -> NoEnvironment input m b -> NoEnvironment input m a
forall input (m :: * -> *) a b.
Functor m =>
(a -> b) -> NoEnvironment input m a -> NoEnvironment input m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> NoEnvironment input m b -> NoEnvironment input m a
$c<$ :: forall input (m :: * -> *) a b.
Functor m =>
a -> NoEnvironment input m b -> NoEnvironment input m a
fmap :: (a -> b) -> NoEnvironment input m a -> NoEnvironment input m b
$cfmap :: forall input (m :: * -> *) a b.
Functor m =>
(a -> b) -> NoEnvironment input m a -> NoEnvironment input m b
Functor, Functor (NoEnvironment input m)
a -> NoEnvironment input m a
Functor (NoEnvironment input m)
-> (forall a. a -> NoEnvironment input m a)
-> (forall a b.
    NoEnvironment input m (a -> b)
    -> NoEnvironment input m a -> NoEnvironment input m b)
-> (forall a b c.
    (a -> b -> c)
    -> NoEnvironment input m a
    -> NoEnvironment input m b
    -> NoEnvironment input m c)
-> (forall a b.
    NoEnvironment input m a
    -> NoEnvironment input m b -> NoEnvironment input m b)
-> (forall a b.
    NoEnvironment input m a
    -> NoEnvironment input m b -> NoEnvironment input m a)
-> Applicative (NoEnvironment input m)
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m a
NoEnvironment input m (a -> b)
-> NoEnvironment input m a -> NoEnvironment input m b
(a -> b -> c)
-> NoEnvironment input m a
-> NoEnvironment input m b
-> NoEnvironment input m c
forall a. a -> NoEnvironment input m a
forall a b.
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m a
forall a b.
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
forall a b.
NoEnvironment input m (a -> b)
-> NoEnvironment input m a -> NoEnvironment input m b
forall a b c.
(a -> b -> c)
-> NoEnvironment input m a
-> NoEnvironment input m b
-> NoEnvironment input m c
forall input (m :: * -> *).
Applicative m =>
Functor (NoEnvironment input m)
forall input (m :: * -> *) a.
Applicative m =>
a -> NoEnvironment input m a
forall input (m :: * -> *) a b.
Applicative m =>
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m a
forall input (m :: * -> *) a b.
Applicative m =>
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
forall input (m :: * -> *) a b.
Applicative m =>
NoEnvironment input m (a -> b)
-> NoEnvironment input m a -> NoEnvironment input m b
forall input (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> NoEnvironment input m a
-> NoEnvironment input m b
-> NoEnvironment input m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m a
$c<* :: forall input (m :: * -> *) a b.
Applicative m =>
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m a
*> :: NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
$c*> :: forall input (m :: * -> *) a b.
Applicative m =>
NoEnvironment input m a
-> NoEnvironment input m b -> NoEnvironment input m b
liftA2 :: (a -> b -> c)
-> NoEnvironment input m a
-> NoEnvironment input m b
-> NoEnvironment input m c
$cliftA2 :: forall input (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> NoEnvironment input m a
-> NoEnvironment input m b
-> NoEnvironment input m c
<*> :: NoEnvironment input m (a -> b)
-> NoEnvironment input m a -> NoEnvironment input m b
$c<*> :: forall input (m :: * -> *) a b.
Applicative m =>
NoEnvironment input m (a -> b)
-> NoEnvironment input m a -> NoEnvironment input m b
pure :: a -> NoEnvironment input m a
$cpure :: forall input (m :: * -> *) a.
Applicative m =>
a -> NoEnvironment input m a
$cp1Applicative :: forall input (m :: * -> *).
Applicative m =>
Functor (NoEnvironment input m)
Applicative)

instance Monad m => Environment (NoEnvironment input m) input where
  environment :: FormId -> NoEnvironment input m (Value input)
environment = FormId -> NoEnvironment input m (Value input)
forall (m :: * -> *) input.
Applicative m =>
FormId -> m (Value input)
noEnvironment

-- | @environment@ which will always return the initial value
noEnvironment :: Applicative m => FormId -> m (Value input)
noEnvironment :: FormId -> m (Value input)
noEnvironment = m (Value input) -> FormId -> m (Value input)
forall a b. a -> b -> a
const (m (Value input) -> FormId -> m (Value input))
-> m (Value input) -> FormId -> m (Value input)
forall a b. (a -> b) -> a -> b
$ Value input -> m (Value input)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value input
forall a. Value a
Default

-- | Run the form, but with a given @environment@ function
newtype WithEnvironment input m a = WithEnvironment { WithEnvironment input m a
-> ReaderT (FormId -> m (Value input)) m a
getWithEnvironment :: ReaderT (FormId -> m (Value input)) m a }
  deriving (Applicative (WithEnvironment input m)
a -> WithEnvironment input m a
Applicative (WithEnvironment input m)
-> (forall a b.
    WithEnvironment input m a
    -> (a -> WithEnvironment input m b) -> WithEnvironment input m b)
-> (forall a b.
    WithEnvironment input m a
    -> WithEnvironment input m b -> WithEnvironment input m b)
-> (forall a. a -> WithEnvironment input m a)
-> Monad (WithEnvironment input m)
WithEnvironment input m a
-> (a -> WithEnvironment input m b) -> WithEnvironment input m b
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
forall a. a -> WithEnvironment input m a
forall a b.
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
forall a b.
WithEnvironment input m a
-> (a -> WithEnvironment input m b) -> WithEnvironment input m b
forall input (m :: * -> *).
Monad m =>
Applicative (WithEnvironment input m)
forall input (m :: * -> *) a.
Monad m =>
a -> WithEnvironment input m a
forall input (m :: * -> *) a b.
Monad m =>
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
forall input (m :: * -> *) a b.
Monad m =>
WithEnvironment input m a
-> (a -> WithEnvironment input m b) -> WithEnvironment input m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> WithEnvironment input m a
$creturn :: forall input (m :: * -> *) a.
Monad m =>
a -> WithEnvironment input m a
>> :: WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
$c>> :: forall input (m :: * -> *) a b.
Monad m =>
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
>>= :: WithEnvironment input m a
-> (a -> WithEnvironment input m b) -> WithEnvironment input m b
$c>>= :: forall input (m :: * -> *) a b.
Monad m =>
WithEnvironment input m a
-> (a -> WithEnvironment input m b) -> WithEnvironment input m b
$cp1Monad :: forall input (m :: * -> *).
Monad m =>
Applicative (WithEnvironment input m)
Monad, a -> WithEnvironment input m b -> WithEnvironment input m a
(a -> b) -> WithEnvironment input m a -> WithEnvironment input m b
(forall a b.
 (a -> b) -> WithEnvironment input m a -> WithEnvironment input m b)
-> (forall a b.
    a -> WithEnvironment input m b -> WithEnvironment input m a)
-> Functor (WithEnvironment input m)
forall a b.
a -> WithEnvironment input m b -> WithEnvironment input m a
forall a b.
(a -> b) -> WithEnvironment input m a -> WithEnvironment input m b
forall input (m :: * -> *) a b.
Functor m =>
a -> WithEnvironment input m b -> WithEnvironment input m a
forall input (m :: * -> *) a b.
Functor m =>
(a -> b) -> WithEnvironment input m a -> WithEnvironment input m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> WithEnvironment input m b -> WithEnvironment input m a
$c<$ :: forall input (m :: * -> *) a b.
Functor m =>
a -> WithEnvironment input m b -> WithEnvironment input m a
fmap :: (a -> b) -> WithEnvironment input m a -> WithEnvironment input m b
$cfmap :: forall input (m :: * -> *) a b.
Functor m =>
(a -> b) -> WithEnvironment input m a -> WithEnvironment input m b
Functor, Functor (WithEnvironment input m)
a -> WithEnvironment input m a
Functor (WithEnvironment input m)
-> (forall a. a -> WithEnvironment input m a)
-> (forall a b.
    WithEnvironment input m (a -> b)
    -> WithEnvironment input m a -> WithEnvironment input m b)
-> (forall a b c.
    (a -> b -> c)
    -> WithEnvironment input m a
    -> WithEnvironment input m b
    -> WithEnvironment input m c)
-> (forall a b.
    WithEnvironment input m a
    -> WithEnvironment input m b -> WithEnvironment input m b)
-> (forall a b.
    WithEnvironment input m a
    -> WithEnvironment input m b -> WithEnvironment input m a)
-> Applicative (WithEnvironment input m)
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m a
WithEnvironment input m (a -> b)
-> WithEnvironment input m a -> WithEnvironment input m b
(a -> b -> c)
-> WithEnvironment input m a
-> WithEnvironment input m b
-> WithEnvironment input m c
forall a. a -> WithEnvironment input m a
forall a b.
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m a
forall a b.
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
forall a b.
WithEnvironment input m (a -> b)
-> WithEnvironment input m a -> WithEnvironment input m b
forall a b c.
(a -> b -> c)
-> WithEnvironment input m a
-> WithEnvironment input m b
-> WithEnvironment input m c
forall input (m :: * -> *).
Applicative m =>
Functor (WithEnvironment input m)
forall input (m :: * -> *) a.
Applicative m =>
a -> WithEnvironment input m a
forall input (m :: * -> *) a b.
Applicative m =>
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m a
forall input (m :: * -> *) a b.
Applicative m =>
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
forall input (m :: * -> *) a b.
Applicative m =>
WithEnvironment input m (a -> b)
-> WithEnvironment input m a -> WithEnvironment input m b
forall input (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> WithEnvironment input m a
-> WithEnvironment input m b
-> WithEnvironment input m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m a
$c<* :: forall input (m :: * -> *) a b.
Applicative m =>
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m a
*> :: WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
$c*> :: forall input (m :: * -> *) a b.
Applicative m =>
WithEnvironment input m a
-> WithEnvironment input m b -> WithEnvironment input m b
liftA2 :: (a -> b -> c)
-> WithEnvironment input m a
-> WithEnvironment input m b
-> WithEnvironment input m c
$cliftA2 :: forall input (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> WithEnvironment input m a
-> WithEnvironment input m b
-> WithEnvironment input m c
<*> :: WithEnvironment input m (a -> b)
-> WithEnvironment input m a -> WithEnvironment input m b
$c<*> :: forall input (m :: * -> *) a b.
Applicative m =>
WithEnvironment input m (a -> b)
-> WithEnvironment input m a -> WithEnvironment input m b
pure :: a -> WithEnvironment input m a
$cpure :: forall input (m :: * -> *) a.
Applicative m =>
a -> WithEnvironment input m a
$cp1Applicative :: forall input (m :: * -> *).
Applicative m =>
Functor (WithEnvironment input m)
Applicative)

deriving instance Monad m => MonadReader (FormId -> m (Value input)) (WithEnvironment input m)

instance MonadTrans (WithEnvironment input) where
  lift :: m a -> WithEnvironment input m a
lift = ReaderT (FormId -> m (Value input)) m a
-> WithEnvironment input m a
forall input (m :: * -> *) a.
ReaderT (FormId -> m (Value input)) m a
-> WithEnvironment input m a
WithEnvironment (ReaderT (FormId -> m (Value input)) m a
 -> WithEnvironment input m a)
-> (m a -> ReaderT (FormId -> m (Value input)) m a)
-> m a
-> WithEnvironment input m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (FormId -> m (Value input)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance Monad m => Environment (WithEnvironment input m) input where
  environment :: FormId -> WithEnvironment input m (Value input)
environment FormId
fid = do
    FormId -> m (Value input)
f <- WithEnvironment input m (FormId -> m (Value input))
forall r (m :: * -> *). MonadReader r m => m r
ask
    m (Value input) -> WithEnvironment input m (Value input)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Value input) -> WithEnvironment input m (Value input))
-> m (Value input) -> WithEnvironment input m (Value input)
forall a b. (a -> b) -> a -> b
$ FormId -> m (Value input)
f FormId
fid

------------------------------------------------------------------------------
-- Utility functions
------------------------------------------------------------------------------

failDecodeMDF :: forall m input err a. (Applicative m, FormError input err) => input -> m (Either err a)
failDecodeMDF :: input -> m (Either err a)
failDecodeMDF = m (Either err a) -> input -> m (Either err a)
forall a b. a -> b -> a
const (m (Either err a) -> input -> m (Either err a))
-> m (Either err a) -> input -> m (Either err a)
forall a b. (a -> b) -> a -> b
$ Either err a -> m (Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err a -> m (Either err a))
-> Either err a -> m (Either err a)
forall a b. (a -> b) -> a -> b
$ err -> Either err a
forall a b. a -> Either a b
Left (err -> Either err a) -> err -> Either err a
forall a b. (a -> b) -> a -> b
$ CommonFormError input -> err
forall input err.
FormError input err =>
CommonFormError input -> err
commonFormError (CommonFormError input
forall input. CommonFormError input
MissingDefaultValue @input)

-- | Always succeed decoding
successDecode :: Applicative m => a -> (input -> m (Either err a))
successDecode :: a -> input -> m (Either err a)
successDecode = m (Either err a) -> input -> m (Either err a)
forall a b. a -> b -> a
const (m (Either err a) -> input -> m (Either err a))
-> (a -> m (Either err a)) -> a -> input -> m (Either err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either err a -> m (Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err a -> m (Either err a))
-> (a -> Either err a) -> a -> m (Either err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either err a
forall a b. b -> Either a b
Right

-- | Common operations on @Form@s

-- | Change the view of a form using a simple function
--
-- This is useful for wrapping a form inside of a \<fieldset\> or other markup element.
mapView :: (Functor m)
  => (view -> view') -- ^ Manipulator
  -> Form m input err view a -- ^ Initial form
  -> Form m input err view' a -- ^ Resulting form
mapView :: (view -> view')
-> Form m input err view a -> Form m input err view' a
mapView view -> 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, formFormlet :: forall (m :: * -> *) input err view a.
Form m input err view a
-> FormState m (View err view, Result err (Proved a))
formFormlet=FormState m (View err view, Result err (Proved a))
formFormlet'} =
  let formFormlet :: StateT FormRange m (View err view', Result err (Proved a))
formFormlet = ((View err view, Result err (Proved a))
 -> (View err view', Result err (Proved a)))
-> FormState m (View err view, Result err (Proved a))
-> StateT FormRange m (View err view', Result err (Proved a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((View err view -> View err view')
-> (View err view, Result err (Proved a))
-> (View err view', Result err (Proved a))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((view -> view') -> View err view -> View err view'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap view -> view'
f)) FormState m (View err view, Result err (Proved a))
formFormlet'
  in Form :: 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 {m a
StateT FormRange m (View err view', Result err (Proved a))
input -> m (Either err a)
formFormlet :: StateT FormRange m (View err view', Result err (Proved a))
formInitialValue :: m a
formDecodeInput :: input -> m (Either err a)
formFormlet :: StateT FormRange m (View err view', Result err (Proved a))
formInitialValue :: m a
formDecodeInput :: input -> m (Either err a)
..}

-- | Increment a form ID
incrementFormId :: FormId -> FormId
incrementFormId :: FormId -> FormId
incrementFormId = Int -> FormId -> FormId
add Int
1
  where
  add :: Int -> FormId -> FormId
add Int
i (FormId Text
p (Int
x :| [Int]
xs)) = Text -> NonEmpty Int -> FormId
FormId Text
p (NonEmpty Int -> FormId) -> NonEmpty Int -> FormId
forall a b. (a -> b) -> a -> b
$ (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int]
xs
  add Int
i (FormIdName Text
n Int
x) = Text -> Int -> FormId
FormIdName Text
n (Int -> FormId) -> Int -> FormId
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i

-- | Check if a 'FormId' is contained in a 'FormRange'
isInRange
  :: FormId -- ^ Id to check for
  -> FormRange -- ^ Range
  -> Bool -- ^ If the range contains the id
isInRange :: FormId -> FormRange -> Bool
isInRange FormId
a (FormRange FormId
b FormId
c) =
     FormId -> Int
formIdentifier FormId
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= FormId -> Int
formIdentifier FormId
b
  Bool -> Bool -> Bool
&& FormId -> Int
formIdentifier FormId
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< FormId -> Int
formIdentifier FormId
c

-- | Check if a 'FormRange' is contained in another 'FormRange'
isSubRange
  :: FormRange -- ^ Sub-range
  -> FormRange -- ^ Larger range
  -> Bool -- ^ If the sub-range is contained in the larger range
isSubRange :: FormRange -> FormRange -> Bool
isSubRange (FormRange FormId
a FormId
b) (FormRange FormId
c FormId
d) =
     FormId -> Int
formIdentifier FormId
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= FormId -> Int
formIdentifier FormId
c
  Bool -> Bool -> Bool
&& FormId -> Int
formIdentifier FormId
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= FormId -> Int
formIdentifier FormId
d

-- | Get a @FormId@ from the FormState
getFormId :: Monad m => FormState m FormId
getFormId :: FormState m FormId
getFormId = do
  FormRange FormId
x FormId
_ <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  FormId -> FormState m FormId
forall (f :: * -> *) a. Applicative f => a -> f a
pure FormId
x

-- | Utility function: Get the current range
getFormRange :: Monad m => FormState m FormRange
getFormRange :: FormState m FormRange
getFormRange = FormState m FormRange
forall s (m :: * -> *). MonadState s m => m s
get

-- | Get a @FormIdName@ from the FormState
getNamedFormId :: Monad m => Text -> FormState m FormId
getNamedFormId :: Text -> FormState m FormId
getNamedFormId Text
name = do
  FormRange FormId
x FormId
_ <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  FormId -> FormState m FormId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormId -> FormState m FormId) -> FormId -> FormState m FormId
forall a b. (a -> b) -> a -> b
$ Text -> Int -> FormId
FormIdName Text
name (Int -> FormId) -> Int -> FormId
forall a b. (a -> b) -> a -> b
$ FormId -> Int
formIdentifier FormId
x

-- | Turns a @FormId@ into a @FormRange@ by incrementing the base for the end Id
unitRange :: FormId -> FormRange
unitRange :: FormId -> FormRange
unitRange FormId
i = FormId -> FormId -> FormRange
FormRange FormId
i (FormId -> FormRange) -> FormId -> FormRange
forall a b. (a -> b) -> a -> b
$ FormId -> FormId
incrementFormId FormId
i

bracketState :: Monad m => FormState m a -> FormState m a
bracketState :: FormState m a -> FormState m a
bracketState FormState m a
k = do
  FormRange FormId
startF1 FormId
_ <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  a
res <- FormState m a
k
  FormRange FormId
_ FormId
endF2 <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  FormRange -> StateT FormRange m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (FormRange -> StateT FormRange m ())
-> FormRange -> StateT FormRange m ()
forall a b. (a -> b) -> a -> b
$ FormId -> FormId -> FormRange
FormRange FormId
startF1 FormId
endF2
  a -> FormState m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- | Utility function: increment the current 'FormId'.
incrementFormRange :: Monad m => FormState m ()
incrementFormRange :: FormState m ()
incrementFormRange = do
  FormRange FormId
_ FormId
endF1 <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
  FormRange -> FormState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (FormRange -> FormState m ()) -> FormRange -> FormState m ()
forall a b. (a -> b) -> a -> b
$ FormId -> FormRange
unitRange FormId
endF1

-- | Run a form
runForm :: Monad m
  => Text
  -> Form m input err view a
  -> m (View err view, Result err (Proved a))
runForm :: Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
runForm Text
prefix Form{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} =
  FormState m (View err view, Result err (Proved a))
-> FormRange -> m (View err view, Result err (Proved a))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT FormState m (View err view, Result err (Proved a))
formFormlet (FormRange -> m (View err view, Result err (Proved a)))
-> FormRange -> m (View err view, Result err (Proved a))
forall a b. (a -> b) -> a -> b
$ FormId -> FormRange
unitRange (FormId -> FormRange) -> FormId -> FormRange
forall a b. (a -> b) -> a -> b
$ Text -> NonEmpty Int -> FormId
FormId Text
prefix (Int -> NonEmpty Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0)

-- | Run a form, and unwrap the result
runForm_ :: (Monad m)
  => Text
  -> Form m input err view a
  -> m (view, Maybe a)
runForm_ :: Text -> Form m input err view a -> m (view, Maybe a)
runForm_ Text
prefix Form m input err view a
form = do
  (View err view
view', Result err (Proved a)
result) <- Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
forall (m :: * -> *) input err view a.
Monad m =>
Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
runForm Text
prefix Form m input err view a
form
  (view, Maybe a) -> m (view, Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((view, Maybe a) -> m (view, Maybe a))
-> (view, Maybe a) -> m (view, Maybe a)
forall a b. (a -> b) -> a -> b
$ case Result err (Proved a)
result of
    Error [(FormRange, err)]
e -> (View err view -> [(FormRange, err)] -> view
forall err v. View err v -> [(FormRange, err)] -> v
unView View err view
view' [(FormRange, err)]
e, Maybe a
forall a. Maybe a
Nothing)
    Ok Proved a
x -> (View err view -> [(FormRange, err)] -> view
forall err v. View err v -> [(FormRange, err)] -> v
unView View err view
view' [], a -> Maybe a
forall a. a -> Maybe a
Just (Proved a -> a
forall a. Proved a -> a
unProved Proved a
x))

-- | Evaluate a form
--
-- Returns:
--
-- [@Left view@] on failure. The @view@ will be produced by a @View err view@,
-- which can be modified with functions like 'withChildErrors'
-- for the sake of rendering errors.
--
-- [@Right a@] on success.
--
eitherForm :: (Monad m)
  => Text -- ^ Identifier for the form
  -> Form m input err view a -- ^ Form to run
  -> m (Either view a) -- ^ Result
eitherForm :: Text -> Form m input err view a -> m (Either view a)
eitherForm Text
id' Form m input err view a
form = do
  (View err view
view', Result err (Proved a)
result) <- Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
forall (m :: * -> *) input err view a.
Monad m =>
Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
runForm Text
id' Form m input err view a
form
  Either view a -> m (Either view a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either view a -> m (Either view a))
-> Either view a -> m (Either view a)
forall a b. (a -> b) -> a -> b
$ case Result err (Proved a)
result of
    Error [(FormRange, err)]
e -> view -> Either view a
forall a b. a -> Either a b
Left (View err view -> [(FormRange, err)] -> view
forall err v. View err v -> [(FormRange, err)] -> v
unView View err view
view' [(FormRange, err)]
e)
    Ok Proved a
x -> a -> Either view a
forall a b. b -> Either a b
Right (Proved a -> a
forall a. Proved a -> a
unProved Proved a
x)

-- | infix mapView: succinctly mix the @view@ dsl and the formlets dsl
-- e.g. @div_ [class_ "my cool form"] \@$ do (_ :: Form m input err view' a).@
infixr 0 @$
(@$) :: Monad m => (view -> view') -> Form m input err view a -> Form m input err view' a
@$ :: (view -> view')
-> Form m input err view a -> Form m input err view' a
(@$) = (view -> view')
-> Form m input err view a -> Form m input err view' a
forall (m :: * -> *) view view' input err a.
Functor m =>
(view -> view')
-> Form m input err view a -> Form m input err view' a
mapView

-- | Utility Function: turn a view and pure value into a successful 'FormState'
mkOk
  :: (Monad m)
  => FormId
  -> view
  -> a
  -> FormState m (View err view, Result err (Proved a))
mkOk :: FormId
-> view -> a -> FormState m (View err view, Result err (Proved a))
mkOk FormId
i view
view' a
val = (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'
  , 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
val
      }
  )

-- | Lift the errors into the result type. This will cause the form to always 'succeed'
formEither :: Monad m
  => Form m input err view a
  -> Form m input err view (Either [err] a)
formEither :: Form m input err view a -> Form m input err view (Either [err] a)
formEither 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} = Form :: 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
  { formDecodeInput :: input -> m (Either err (Either [err] a))
formDecodeInput = \input
input -> do
      Either err a
res <- input -> m (Either err a)
formDecodeInput input
input
      case Either err a
res of
        Left err
err -> Either err (Either [err] a) -> m (Either err (Either [err] a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err (Either [err] a) -> m (Either err (Either [err] a)))
-> Either err (Either [err] a) -> m (Either err (Either [err] a))
forall a b. (a -> b) -> a -> b
$ Either [err] a -> Either err (Either [err] a)
forall a b. b -> Either a b
Right (Either [err] a -> Either err (Either [err] a))
-> Either [err] a -> Either err (Either [err] a)
forall a b. (a -> b) -> a -> b
$ [err] -> Either [err] a
forall a b. a -> Either a b
Left [err
err]
        Right a
x -> Either err (Either [err] a) -> m (Either err (Either [err] a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err (Either [err] a) -> m (Either err (Either [err] a)))
-> Either err (Either [err] a) -> m (Either err (Either [err] a))
forall a b. (a -> b) -> a -> b
$ Either [err] a -> Either err (Either [err] a)
forall a b. b -> Either a b
Right (Either [err] a -> Either err (Either [err] a))
-> Either [err] a -> Either err (Either [err] a)
forall a b. (a -> b) -> a -> b
$ a -> Either [err] a
forall a b. b -> Either a b
Right a
x
  , formInitialValue :: m (Either [err] a)
formInitialValue = (a -> Either [err] a) -> m a -> m (Either [err] a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either [err] a
forall a b. b -> Either a b
Right m a
formInitialValue
  , formFormlet :: FormState m (View err view, Result err (Proved (Either [err] a)))
formFormlet = do
      FormRange
range <- StateT FormRange m FormRange
forall s (m :: * -> *). MonadState s m => m s
get
      (View err view
view', Result err (Proved a)
res') <- FormState m (View err view, Result err (Proved a))
formFormlet
      let res :: Either [err] a
res = case Result err (Proved a)
res' of
            Error [(FormRange, err)]
err -> [err] -> Either [err] a
forall a b. a -> Either a b
Left (((FormRange, err) -> err) -> [(FormRange, err)] -> [err]
forall a b. (a -> b) -> [a] -> [b]
map (FormRange, err) -> err
forall a b. (a, b) -> b
snd [(FormRange, err)]
err)
            Ok (Proved FormRange
_ a
x) -> a -> Either [err] a
forall a b. b -> Either a b
Right a
x
      (View err view, Result err (Proved (Either [err] a)))
-> FormState
     m (View err view, Result err (Proved (Either [err] a)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( View err view
view'
        , Proved (Either [err] a) -> Result err (Proved (Either [err] a))
forall e ok. ok -> Result e ok
Ok (Proved (Either [err] a) -> Result err (Proved (Either [err] a)))
-> Proved (Either [err] a) -> Result err (Proved (Either [err] a))
forall a b. (a -> b) -> a -> b
$ Proved :: forall a. FormRange -> a -> Proved a
Proved
            { pos :: FormRange
pos = FormRange
range
            , unProved :: Either [err] a
unProved = Either [err] a
res
            }
        )
  }

-- | Utility function: Get the current input
getFormInput :: Environment m input => FormState m (Value input)
getFormInput :: FormState m (Value input)
getFormInput = FormState m FormId
forall (m :: * -> *). Monad m => FormState m FormId
getFormId FormState m FormId
-> (FormId -> FormState m (Value input))
-> FormState m (Value input)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FormId -> FormState m (Value input)
forall (m :: * -> *) input.
Environment m input =>
FormId -> FormState m (Value input)
getFormInput'

-- | Utility function: Gets the input of an arbitrary 'FormId'.
getFormInput' :: Environment m input => FormId -> FormState m (Value input)
getFormInput' :: FormId -> FormState m (Value input)
getFormInput' FormId
fid = m (Value input) -> FormState m (Value input)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Value input) -> FormState m (Value input))
-> m (Value input) -> FormState m (Value input)
forall a b. (a -> b) -> a -> b
$ FormId -> m (Value input)
forall (m :: * -> *) input.
Environment m input =>
FormId -> m (Value input)
environment FormId
fid

-- | Select the errors for a certain range
retainErrors :: FormRange -> [(FormRange, e)] -> [e]
retainErrors :: FormRange -> [(FormRange, e)] -> [e]
retainErrors = (FormRange -> FormRange -> Bool)
-> FormRange -> [(FormRange, e)] -> [e]
forall e.
(FormRange -> FormRange -> Bool)
-> FormRange -> [(FormRange, e)] -> [e]
retainErrorsOn FormRange -> FormRange -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- | Select the errors originating from this form or from any of the children of
-- this form
retainChildErrors :: FormRange -> [(FormRange, e)] -> [e]
retainChildErrors :: FormRange -> [(FormRange, e)] -> [e]
retainChildErrors = (FormRange -> FormRange -> Bool)
-> FormRange -> [(FormRange, e)] -> [e]
forall e.
(FormRange -> FormRange -> Bool)
-> FormRange -> [(FormRange, e)] -> [e]
retainErrorsOn FormRange -> FormRange -> Bool
isSubRange

{-# INLINE retainErrorsOn #-}
retainErrorsOn :: (FormRange -> FormRange -> Bool) -> FormRange -> [(FormRange, e)] -> [e]
retainErrorsOn :: (FormRange -> FormRange -> Bool)
-> FormRange -> [(FormRange, e)] -> [e]
retainErrorsOn FormRange -> FormRange -> Bool
f FormRange
range = ((FormRange, e) -> e) -> [(FormRange, e)] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map (FormRange, e) -> e
forall a b. (a, b) -> b
snd ([(FormRange, e)] -> [e])
-> ([(FormRange, e)] -> [(FormRange, e)])
-> [(FormRange, e)]
-> [e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FormRange, e) -> Bool) -> [(FormRange, e)] -> [(FormRange, e)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FormRange -> FormRange -> Bool
`f` FormRange
range) (FormRange -> Bool)
-> ((FormRange, e) -> FormRange) -> (FormRange, e) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FormRange, e) -> FormRange
forall a b. (a, b) -> a
fst)

-- | Make a form which renders a @view@, accepts no input
-- and produces no output
view :: Monad m => view -> Form m input err view ()
view :: view -> Form m input err view ()
view view
html = (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
forall (m :: * -> *). Monad m => FormState m FormId
getFormId
  (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
html)
        , 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 -> FormId -> FormRange
FormRange FormId
i FormId
i
            , unProved :: ()
unProved = ()
            }
        )

-- | Lift a monad morphism from @m@ to @n@ into a monad morphism from @(Form m)@ to @(Form n)@
-- eg. @newtype@s, @lift@s
hoistForm :: (Monad f)
  => (forall x. m x -> f x)
  -> Form m input err view a
  -> Form f input err view a
hoistForm :: (forall x. m x -> f x)
-> Form m input err view a -> Form f input err view a
hoistForm forall x. m x -> f x
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} = Form :: 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
  { formDecodeInput :: input -> f (Either err a)
formDecodeInput = m (Either err a) -> f (Either err a)
forall x. m x -> f x
f (m (Either err a) -> f (Either err a))
-> (input -> m (Either err a)) -> input -> f (Either err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> m (Either err a)
formDecodeInput
  , formInitialValue :: f a
formInitialValue = m a -> f a
forall x. m x -> f x
f m a
formInitialValue
  , formFormlet :: FormState f (View err view, Result err (Proved a))
formFormlet = (m ((View err view, Result err (Proved a)), FormRange)
 -> f ((View err view, Result err (Proved a)), FormRange))
-> FormState m (View err view, Result err (Proved a))
-> FormState f (View err view, Result err (Proved a))
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT m ((View err view, Result err (Proved a)), FormRange)
-> f ((View err view, Result err (Proved a)), FormRange)
forall x. m x -> f x
f FormState m (View err view, Result err (Proved a))
formFormlet
  }

-- | Catch errors purely
catchFormError :: (Monad m)
  => ([err] -> a)
  -> Form m input err view a
  -> Form m input err view a
catchFormError :: ([err] -> a) -> Form m input err view a -> Form m input err view a
catchFormError [err] -> a
ferr 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
  FormId
i <- FormState m FormId
forall (m :: * -> *). Monad m => FormState m FormId
getFormId
  (View [(FormRange, err)] -> view
viewf, Result err (Proved a)
res) <- FormState m (View err view, Result err (Proved a))
formFormlet
  case Result err (Proved a)
res of
    Ok Proved a
_ -> FormState m (View err view, Result err (Proved a))
formFormlet
    Error [(FormRange, err)]
err -> 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 ([(FormRange, err)] -> view
viewf []) ([err] -> a
ferr ([err] -> a) -> [err] -> a
forall a b. (a -> b) -> a -> b
$ ((FormRange, err) -> err) -> [(FormRange, err)] -> [err]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FormRange, err) -> err
forall a b. (a, b) -> b
snd [(FormRange, err)]
err)

-- | Catch errors inside @Form@ / @m@
catchFormErrorM :: (Monad m)
  => Form m input err view a
  -> ([err] -> Form m input err view a)
  -> Form m input err view a
catchFormErrorM :: Form m input err view a
-> ([err] -> Form m input err view a) -> Form m input err view a
catchFormErrorM form :: Form m input err view a
form@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} [err] -> Form m input err view a
e = (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 err view
_, Result err (Proved a)
res0) <- 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
form
  case Result err (Proved a)
res0 of
    Ok 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
form
    Error [(FormRange, err)]
err -> 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
$ [err] -> Form m input err view a
e ([err] -> Form m input err view a)
-> [err] -> Form m input err view a
forall a b. (a -> b) -> a -> b
$ ((FormRange, err) -> err) -> [(FormRange, err)] -> [err]
forall a b. (a -> b) -> [a] -> [b]
map (FormRange, err) -> err
forall a b. (a, b) -> b
snd [(FormRange, err)]
err

-- | Map over the @Result@ and @View@ of a form
mapResult :: (Monad m)
  => (Result err (Proved a) -> Result err (Proved a))
  -> (View err view -> View err view)
  -> Form m input err view a
  -> Form m input err view a
mapResult :: (Result err (Proved a) -> Result err (Proved a))
-> (View err view -> View err view)
-> Form m input err view a
-> Form m input err view a
mapResult Result err (Proved a) -> Result err (Proved a)
fres View err view -> View err view
fview 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 err view
view', Result err (Proved a)
res) <- FormState m (View err view, Result err (Proved a))
formFormlet
  (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 (View err view -> View err view
fview View err view
view', Result err (Proved a) -> Result err (Proved a)
fres Result err (Proved a)
res)

-- | Run the form with no environment, return only the html.
-- This means that the values will always be their defaults
viewForm :: (Monad m)
  => Text -- ^ form prefix
  -> Form m input err view a -- ^ form to view
  -> m view
viewForm :: Text -> Form m input err view a -> m view
viewForm Text
prefix Form m input err view a
form = do
  (View err view
v, Result err (Proved a)
_) <- NoEnvironment Any m (View err view, Result err (Proved a))
-> m (View err view, Result err (Proved a))
forall input (m :: * -> *) a. NoEnvironment input m a -> m a
getNoEnvironment (NoEnvironment Any m (View err view, Result err (Proved a))
 -> m (View err view, Result err (Proved a)))
-> NoEnvironment Any m (View err view, Result err (Proved a))
-> m (View err view, Result err (Proved a))
forall a b. (a -> b) -> a -> b
$ Text
-> Form (NoEnvironment Any m) input err view a
-> NoEnvironment Any m (View err view, Result err (Proved a))
forall (m :: * -> *) input err view a.
Monad m =>
Text
-> Form m input err view a
-> m (View err view, Result err (Proved a))
runForm Text
prefix (Form (NoEnvironment Any m) input err view a
 -> NoEnvironment Any m (View err view, Result err (Proved a)))
-> Form (NoEnvironment Any m) input err view a
-> NoEnvironment Any m (View err view, Result err (Proved a))
forall a b. (a -> b) -> a -> b
$ (forall x. m x -> NoEnvironment Any m x)
-> Form m input err view a
-> Form (NoEnvironment Any m) input err view a
forall (f :: * -> *) (m :: * -> *) input err view a.
Monad f =>
(forall x. m x -> f x)
-> Form m input err view a -> Form f input err view a
hoistForm forall x. m x -> NoEnvironment Any m x
forall input (m :: * -> *) a. m a -> NoEnvironment input m a
NoEnvironment Form m input err view a
form
  view -> m view
forall (f :: * -> *) a. Applicative f => a -> f a
pure (View err view -> [(FormRange, err)] -> view
forall err v. View err v -> [(FormRange, err)] -> v
unView View err view
v [])

-- | lift the result of a decoding to a @Form@
pureRes :: (Monad m, Monoid view, FormError input err)
  => a
  -> Either err a
  -> Form m input err view a
pureRes :: a -> Either err a -> Form m input err view a
pureRes a
def Either err a
x' = case Either err a
x' of
  Right a
x -> (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 (a -> input -> m (Either err a)
forall (m :: * -> *) a input err.
Applicative m =>
a -> input -> m (Either err a)
successDecode a
x) (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (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
forall (m :: * -> *). Monad m => FormState m FormId
getFormId
    (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  ( View err view
forall a. Monoid a => a
mempty
          , 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 -> FormId -> FormRange
FormRange FormId
i FormId
i
              , unProved :: a
unProved = a
x
              }
          )
  Left err
e -> (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 (a -> input -> m (Either err a)
forall (m :: * -> *) a input err.
Applicative m =>
a -> input -> m (Either err a)
successDecode a
def) (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def) (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
forall (m :: * -> *). Monad m => FormState m FormId
getFormId
    (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 ( View err view
forall a. Monoid a => a
mempty
         , [(FormRange, err)] -> Result err (Proved a)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormId -> FormId -> FormRange
FormRange FormId
i FormId
i, err
e)]
         )

-- | @Form@ is a @MonadTrans@, but we can't have an instance of it because of the order and kind of its type variables
liftForm :: (Monad m, Monoid view) => m a -> Form m input err view a
liftForm :: m a -> Form m input err view a
liftForm m a
x = Form :: 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
  { formDecodeInput :: input -> m (Either err a)
formDecodeInput = m (Either err a) -> input -> m (Either err a)
forall a b. a -> b -> a
const ((a -> Either err a) -> m a -> m (Either err a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either err a
forall a b. b -> Either a b
Right m a
x)
  , formInitialValue :: m a
formInitialValue = m a
x
  , formFormlet :: FormState m (View err view, Result err (Proved a))
formFormlet = m a -> StateT FormRange m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
x StateT FormRange m a
-> (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
>>= a -> FormState m (View err view, Result err (Proved a))
forall (m :: * -> *) view a err.
(Monad m, Monoid view) =>
a -> FormState m (view, Result err (Proved a))
pureFormState
  }

-- | lift a value to a @Form@'s formlet
pureFormState :: (Monad m, Monoid view) => a -> FormState m (view, Result err (Proved a))
pureFormState :: a -> FormState m (view, Result err (Proved a))
pureFormState a
x = do
  FormId
i <- FormState m FormId
forall (m :: * -> *). Monad m => FormState m FormId
getFormId
  (view, Result err (Proved a))
-> FormState m (view, Result err (Proved a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure  ( view
forall a. Monoid a => a
mempty
        , 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 -> FormId -> FormRange
FormRange FormId
i FormId
i
            , unProved :: a
unProved = a
x
            }
        )