{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}
{- |
This module defines the 'Form' type, its instances, core manipulation functions, and a bunch of helper utilities.
-}
module Text.Reform.Core where

import Control.Applicative         (Applicative(pure, (<*>)))
import Control.Applicative.Indexed (IndexedApplicative(ipure, (<<*>>)), IndexedFunctor (imap))
import Control.Arrow               (first, second)
import Control.Monad.Reader        (MonadReader(ask), ReaderT, runReaderT)
import Control.Monad.State         (MonadState(get,put), StateT, evalStateT)
import Control.Monad.Trans         (lift)
import Data.Monoid                 (Monoid(mempty, mappend))
import qualified Data.Semigroup    as SG
import Data.Text.Lazy              (Text, unpack)
import Text.Reform.Result          (FormId(..), FormRange(..), Result(..), unitRange, zeroId)

------------------------------------------------------------------------------
-- * Proved
------------------------------------------------------------------------------

-- | Proved records a value, the location that value came from, and something that was proved about the value.
data Proved proofs a =
    Proved { Proved proofs a -> proofs
proofs   :: proofs
           , Proved proofs a -> FormRange
pos      :: FormRange
           , Proved proofs a -> a
unProved :: a
           }
    deriving Int -> Proved proofs a -> ShowS
[Proved proofs a] -> ShowS
Proved proofs a -> String
(Int -> Proved proofs a -> ShowS)
-> (Proved proofs a -> String)
-> ([Proved proofs a] -> ShowS)
-> Show (Proved proofs a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall proofs a.
(Show proofs, Show a) =>
Int -> Proved proofs a -> ShowS
forall proofs a.
(Show proofs, Show a) =>
[Proved proofs a] -> ShowS
forall proofs a. (Show proofs, Show a) => Proved proofs a -> String
showList :: [Proved proofs a] -> ShowS
$cshowList :: forall proofs a.
(Show proofs, Show a) =>
[Proved proofs a] -> ShowS
show :: Proved proofs a -> String
$cshow :: forall proofs a. (Show proofs, Show a) => Proved proofs a -> String
showsPrec :: Int -> Proved proofs a -> ShowS
$cshowsPrec :: forall proofs a.
(Show proofs, Show a) =>
Int -> Proved proofs a -> ShowS
Show

instance Functor (Proved ()) where
    fmap :: (a -> b) -> Proved () a -> Proved () b
fmap a -> b
f (Proved () FormRange
pos a
a) = () -> FormRange -> b -> Proved () b
forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved () FormRange
pos (a -> b
f a
a)

-- | Utility Function: trivially prove nothing about ()
unitProved :: FormId -> Proved () ()
unitProved :: FormId -> Proved () ()
unitProved FormId
formId =
    Proved :: forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved { proofs :: ()
proofs   = ()
           , pos :: FormRange
pos      = FormId -> FormRange
unitRange FormId
formId
           , unProved :: ()
unProved = ()
           }

------------------------------------------------------------------------------
-- * FormState
------------------------------------------------------------------------------

-- | inner state used by 'Form'.
type FormState m input = ReaderT (Environment m input) (StateT FormRange m)

-- | used to represent whether a value was found in the form
-- submission data, missing from the form submission data, or expected
-- that the default value should be used
data Value a
    = Default
    | Missing
    | Found a

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

-- | Utility function: Gets the input of an arbitrary 'FormId'.
--
getFormInput' :: Monad m => FormId -> FormState m input (Value input)
getFormInput' :: FormId -> FormState m input (Value input)
getFormInput' FormId
id' = do
    Environment m input
env <- ReaderT
  (Environment m input) (StateT FormRange m) (Environment m input)
forall r (m :: * -> *). MonadReader r m => m r
ask
    case Environment m input
env of
      Environment m input
NoEnvironment -> Value input -> FormState m input (Value input)
forall (m :: * -> *) a. Monad m => a -> m a
return Value input
forall a. Value a
Default
      Environment FormId -> m (Value input)
f ->
          StateT FormRange m (Value input) -> FormState m input (Value input)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT FormRange m (Value input)
 -> FormState m input (Value input))
-> StateT FormRange m (Value input)
-> FormState m input (Value input)
forall a b. (a -> b) -> a -> b
$ m (Value input) -> StateT FormRange m (Value input)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Value input) -> StateT FormRange m (Value input))
-> m (Value input) -> StateT FormRange m (Value input)
forall a b. (a -> b) -> a -> b
$ FormId -> m (Value input)
f FormId
id'

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

-- | The environment is where you get the actual input per form.
--
-- The 'NoEnvironment' constructor is typically used when generating a
-- view for a GET request, where no data has yet been submitted. This
-- will cause the input elements to use their supplied default values.
--
-- Note that 'NoEnviroment' is different than supplying an empty environment.
data Environment m input
    = Environment (FormId -> m (Value input))
    | NoEnvironment

instance (SG.Semigroup input, Monad m) => SG.Semigroup (Environment m input) where
    Environment m input
NoEnvironment <> :: Environment m input -> Environment m input -> Environment m input
<> Environment m input
x = Environment m input
x
    Environment m input
x <> Environment m input
NoEnvironment = Environment m input
x
    (Environment FormId -> m (Value input)
env1) <> (Environment FormId -> m (Value input)
env2) =
        (FormId -> m (Value input)) -> Environment m input
forall (m :: * -> *) input.
(FormId -> m (Value input)) -> Environment m input
Environment ((FormId -> m (Value input)) -> Environment m input)
-> (FormId -> m (Value input)) -> Environment m input
forall a b. (a -> b) -> a -> b
$ \FormId
id' ->
            do Value input
r1 <- (FormId -> m (Value input)
env1 FormId
id')
               Value input
r2 <- (FormId -> m (Value input)
env2 FormId
id')
               case (Value input
r1, Value input
r2) of
                 (Value input
Missing, Value input
Missing) -> Value input -> m (Value input)
forall (m :: * -> *) a. Monad m => a -> m a
return Value input
forall a. Value a
Missing
                 (Value input
Default, Value input
Missing) -> Value input -> m (Value input)
forall (m :: * -> *) a. Monad m => a -> m a
return Value input
forall a. Value a
Default
                 (Value input
Missing, Value input
Default) -> Value input -> m (Value input)
forall (m :: * -> *) a. Monad m => a -> m a
return Value input
forall a. Value a
Default
                 (Found input
x, Found input
y) -> Value input -> m (Value input)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value input -> m (Value input)) -> Value input -> m (Value input)
forall a b. (a -> b) -> a -> b
$ input -> Value input
forall a. a -> Value a
Found (input
x input -> input -> input
forall a. Semigroup a => a -> a -> a
SG.<> input
y)
                 (Found input
x, Value input
_      ) -> Value input -> m (Value input)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value input -> m (Value input)) -> Value input -> m (Value input)
forall a b. (a -> b) -> a -> b
$ input -> Value input
forall a. a -> Value a
Found input
x
                 (Value input
_      , Found input
y) -> Value input -> m (Value input)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value input -> m (Value input)) -> Value input -> m (Value input)
forall a b. (a -> b) -> a -> b
$ input -> Value input
forall a. a -> Value a
Found input
y

-- | Not quite sure when this is useful and so hard to say if the rules for combining things with Missing/Default are correct
instance (SG.Semigroup input, Monad m) => Monoid (Environment m input) where
    mempty :: Environment m input
mempty = Environment m input
forall (m :: * -> *) input. Environment m input
NoEnvironment
    mappend :: Environment m input -> Environment m input -> Environment m input
mappend = Environment m input -> Environment m input -> Environment m input
forall a. Semigroup a => a -> a -> a
(SG.<>)

-- | Utility function: returns the current 'FormId'. This will only make sense
-- if the form is not composed
--
getFormId :: Monad m => FormState m i FormId
getFormId :: FormState m i FormId
getFormId = do
    FormRange FormId
x FormId
_ <- ReaderT (Environment m i) (StateT FormRange m) FormRange
forall s (m :: * -> *). MonadState s m => m s
get
    FormId -> FormState m i FormId
forall (m :: * -> *) a. Monad m => a -> m a
return FormId
x

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

-- | A view represents a visual representation of a form. It is composed of a
-- function which takes a list of all errors and then produces a new view
--
newtype View error v = View
    { View error v -> [(FormRange, error)] -> v
unView :: [(FormRange, error)] -> v
    } deriving (b -> View error v -> View error v
NonEmpty (View error v) -> View error v
View error v -> View error v -> View error v
(View error v -> View error v -> View error v)
-> (NonEmpty (View error v) -> View error v)
-> (forall b. Integral b => b -> View error v -> View error v)
-> Semigroup (View error v)
forall b. Integral b => b -> View error v -> View error v
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall error v.
Semigroup v =>
NonEmpty (View error v) -> View error v
forall error v.
Semigroup v =>
View error v -> View error v -> View error v
forall error v b.
(Semigroup v, Integral b) =>
b -> View error v -> View error v
stimes :: b -> View error v -> View error v
$cstimes :: forall error v b.
(Semigroup v, Integral b) =>
b -> View error v -> View error v
sconcat :: NonEmpty (View error v) -> View error v
$csconcat :: forall error v.
Semigroup v =>
NonEmpty (View error v) -> View error v
<> :: View error v -> View error v -> View error v
$c<> :: forall error v.
Semigroup v =>
View error v -> View error v -> View error v
SG.Semigroup, Semigroup (View error v)
View error v
Semigroup (View error v)
-> View error v
-> (View error v -> View error v -> View error v)
-> ([View error v] -> View error v)
-> Monoid (View error v)
[View error v] -> View error v
View error v -> View error v -> View error v
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall error v. Monoid v => Semigroup (View error v)
forall error v. Monoid v => View error v
forall error v. Monoid v => [View error v] -> View error v
forall error v.
Monoid v =>
View error v -> View error v -> View error v
mconcat :: [View error v] -> View error v
$cmconcat :: forall error v. Monoid v => [View error v] -> View error v
mappend :: View error v -> View error v -> View error v
$cmappend :: forall error v.
Monoid v =>
View error v -> View error v -> View error v
mempty :: View error v
$cmempty :: forall error v. Monoid v => View error v
$cp1Monoid :: forall error v. Monoid v => Semigroup (View error v)
Monoid)

instance Functor (View e) where
    fmap :: (a -> b) -> View e a -> View e b
fmap a -> b
f (View [(FormRange, e)] -> a
g) = ([(FormRange, e)] -> b) -> View e b
forall error v. ([(FormRange, error)] -> v) -> View error v
View (([(FormRange, e)] -> b) -> View e b)
-> ([(FormRange, e)] -> b) -> View e b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> ([(FormRange, e)] -> a) -> [(FormRange, e)] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FormRange, e)] -> a
g

------------------------------------------------------------------------------
-- * Form
------------------------------------------------------------------------------

-- | a 'Form' contains a 'View' combined with a validation function
-- which will attempt to extract a value from submitted form data.
--
-- It is highly parameterized, allowing it work in a wide variety of
-- different configurations. You will likely want to make a type alias
-- that is specific to your application to make type signatures more
-- manageable.
--
--   [@m@] A monad which can be used by the validator
--
--   [@input@] A framework specific type for representing the raw key/value pairs from the form data
--
--   [@error@] A application specific type for error messages
--
--   [@view@] The type of data being generated for the view (HSP, Blaze Html, Heist, etc)
--
--   [@proof@] A type which names what has been proved about the return value. @()@ means nothing has been proved.
--
--   [@a@] Value return by form when it is successfully decoded, validated, etc.
--
--
-- This type is very similar to the 'Form' type from
-- @digestive-functors <= 0.2@. If @proof@ is @()@, then 'Form' is an
-- applicative functor and can be used almost exactly like
-- @digestive-functors <= 0.2@.
newtype Form m input error view proof a = Form { Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
unForm :: FormState m input (View error view, m (Result error (Proved proof a))) }

instance (Monad m) => IndexedFunctor (Form m input view error) where
    imap :: (x -> y)
-> (a -> b)
-> Form m input view error x a
-> Form m input view error y b
imap x -> y
f a -> b
g (Form FormState m input (View view error, m (Result view (Proved x a)))
frm) =
        FormState m input (View view error, m (Result view (Proved y b)))
-> Form m input view error y b
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState m input (View view error, m (Result view (Proved y b)))
 -> Form m input view error y b)
-> FormState
     m input (View view error, m (Result view (Proved y b)))
-> Form m input view error y b
forall a b. (a -> b) -> a -> b
$ do (View view error
view, m (Result view (Proved x a))
mval) <- FormState m input (View view error, m (Result view (Proved x a)))
frm
                  Result view (Proved x a)
val <- StateT FormRange m (Result view (Proved x a))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result view (Proved x a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT FormRange m (Result view (Proved x a))
 -> ReaderT
      (Environment m input)
      (StateT FormRange m)
      (Result view (Proved x a)))
-> StateT FormRange m (Result view (Proved x a))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result view (Proved x a))
forall a b. (a -> b) -> a -> b
$ m (Result view (Proved x a))
-> StateT FormRange m (Result view (Proved x a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Result view (Proved x a))
 -> StateT FormRange m (Result view (Proved x a)))
-> m (Result view (Proved x a))
-> StateT FormRange m (Result view (Proved x a))
forall a b. (a -> b) -> a -> b
$ m (Result view (Proved x a))
mval
                  case Result view (Proved x a)
val of
                    (Ok (Proved x
p FormRange
pos a
a)) -> (View view error, m (Result view (Proved y b)))
-> FormState
     m input (View view error, m (Result view (Proved y b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View view error
view, Result view (Proved y b) -> m (Result view (Proved y b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result view (Proved y b) -> m (Result view (Proved y b)))
-> Result view (Proved y b) -> m (Result view (Proved y b))
forall a b. (a -> b) -> a -> b
$ Proved y b -> Result view (Proved y b)
forall e ok. ok -> Result e ok
Ok (y -> FormRange -> b -> Proved y b
forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved (x -> y
f x
p) FormRange
pos (a -> b
g a
a)))
                    (Error [(FormRange, view)]
errs)          -> (View view error, m (Result view (Proved y b)))
-> FormState
     m input (View view error, m (Result view (Proved y b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View view error
view, Result view (Proved y b) -> m (Result view (Proved y b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result view (Proved y b) -> m (Result view (Proved y b)))
-> Result view (Proved y b) -> m (Result view (Proved y b))
forall a b. (a -> b) -> a -> b
$ [(FormRange, view)] -> Result view (Proved y b)
forall e ok. [(FormRange, e)] -> Result e ok
Error [(FormRange, view)]
errs)

instance (Monoid view, Monad m) => IndexedApplicative (Form m input error view) where
    ipure :: x -> a -> Form m input error view x a
ipure x
p a
a = FormState m input (View error view, m (Result error (Proved x a)))
-> Form m input error view x a
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState m input (View error view, m (Result error (Proved x a)))
 -> Form m input error view x a)
-> FormState
     m input (View error view, m (Result error (Proved x a)))
-> Form m input error view x a
forall a b. (a -> b) -> a -> b
$ do FormId
i <- FormState m input FormId
forall (m :: * -> *) i. Monad m => FormState m i FormId
getFormId
                          (View error view, m (Result error (Proved x a)))
-> FormState
     m input (View error view, m (Result error (Proved x a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
forall a. Monoid a => a
mempty, Result error (Proved x a) -> m (Result error (Proved x a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved x a) -> m (Result error (Proved x a)))
-> Result error (Proved x a) -> m (Result error (Proved x a))
forall a b. (a -> b) -> a -> b
$ Proved x a -> Result error (Proved x a)
forall e ok. ok -> Result e ok
Ok (x -> FormRange -> a -> Proved x a
forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved x
p (FormId -> FormRange
unitRange FormId
i) a
a))

    (Form FormState
  m
  input
  (View error view, m (Result error (Proved (x -> y) (a -> b))))
frmF) <<*>> :: Form m input error view (x -> y) (a -> b)
-> Form m input error view x a -> Form m input error view y b
<<*>> (Form FormState m input (View error view, m (Result error (Proved x a)))
frmA) =
        FormState m input (View error view, m (Result error (Proved y b)))
-> Form m input error view y b
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState m input (View error view, m (Result error (Proved y b)))
 -> Form m input error view y b)
-> FormState
     m input (View error view, m (Result error (Proved y b)))
-> Form m input error view y b
forall a b. (a -> b) -> a -> b
$ do ((View error view
view1, m (Result error (Proved (x -> y) (a -> b)))
mfok), (View error view
view2, m (Result error (Proved x a))
maok)) <- FormState
  m
  input
  ((View error view, m (Result error (Proved (x -> y) (a -> b)))),
   (View error view, m (Result error (Proved x a))))
-> FormState
     m
     input
     ((View error view, m (Result error (Proved (x -> y) (a -> b)))),
      (View error view, m (Result error (Proved x a))))
forall (m :: * -> *) input a.
Monad m =>
FormState m input a -> FormState m input a
bracketState (FormState
   m
   input
   ((View error view, m (Result error (Proved (x -> y) (a -> b)))),
    (View error view, m (Result error (Proved x a))))
 -> FormState
      m
      input
      ((View error view, m (Result error (Proved (x -> y) (a -> b)))),
       (View error view, m (Result error (Proved x a)))))
-> FormState
     m
     input
     ((View error view, m (Result error (Proved (x -> y) (a -> b)))),
      (View error view, m (Result error (Proved x a))))
-> FormState
     m
     input
     ((View error view, m (Result error (Proved (x -> y) (a -> b)))),
      (View error view, m (Result error (Proved x a))))
forall a b. (a -> b) -> a -> b
$
                    do (View error view, m (Result error (Proved (x -> y) (a -> b))))
res1 <- FormState
  m
  input
  (View error view, m (Result error (Proved (x -> y) (a -> b))))
frmF
                       FormState m input ()
forall (m :: * -> *) i. Monad m => FormState m i ()
incFormId
                       (View error view, m (Result error (Proved x a)))
res2 <- FormState m input (View error view, m (Result error (Proved x a)))
frmA
                       ((View error view, m (Result error (Proved (x -> y) (a -> b)))),
 (View error view, m (Result error (Proved x a))))
-> FormState
     m
     input
     ((View error view, m (Result error (Proved (x -> y) (a -> b)))),
      (View error view, m (Result error (Proved x a))))
forall (m :: * -> *) a. Monad m => a -> m a
return ((View error view, m (Result error (Proved (x -> y) (a -> b))))
res1, (View error view, m (Result error (Proved x a)))
res2)
                  Result error (Proved (x -> y) (a -> b))
fok <- StateT FormRange m (Result error (Proved (x -> y) (a -> b)))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result error (Proved (x -> y) (a -> b)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT FormRange m (Result error (Proved (x -> y) (a -> b)))
 -> ReaderT
      (Environment m input)
      (StateT FormRange m)
      (Result error (Proved (x -> y) (a -> b))))
-> StateT FormRange m (Result error (Proved (x -> y) (a -> b)))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result error (Proved (x -> y) (a -> b)))
forall a b. (a -> b) -> a -> b
$ m (Result error (Proved (x -> y) (a -> b)))
-> StateT FormRange m (Result error (Proved (x -> y) (a -> b)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Result error (Proved (x -> y) (a -> b)))
 -> StateT FormRange m (Result error (Proved (x -> y) (a -> b))))
-> m (Result error (Proved (x -> y) (a -> b)))
-> StateT FormRange m (Result error (Proved (x -> y) (a -> b)))
forall a b. (a -> b) -> a -> b
$ m (Result error (Proved (x -> y) (a -> b)))
mfok
                  Result error (Proved x a)
aok <- StateT FormRange m (Result error (Proved x a))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result error (Proved x a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT FormRange m (Result error (Proved x a))
 -> ReaderT
      (Environment m input)
      (StateT FormRange m)
      (Result error (Proved x a)))
-> StateT FormRange m (Result error (Proved x a))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result error (Proved x a))
forall a b. (a -> b) -> a -> b
$ m (Result error (Proved x a))
-> StateT FormRange m (Result error (Proved x a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Result error (Proved x a))
 -> StateT FormRange m (Result error (Proved x a)))
-> m (Result error (Proved x a))
-> StateT FormRange m (Result error (Proved x a))
forall a b. (a -> b) -> a -> b
$ m (Result error (Proved x a))
maok
                  case (Result error (Proved (x -> y) (a -> b))
fok, Result error (Proved x a)
aok) of
                     (Error [(FormRange, error)]
errs1, Error [(FormRange, error)]
errs2) -> (View error view, m (Result error (Proved y b)))
-> FormState
     m input (View error view, m (Result error (Proved y b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
view1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
view2, Result error (Proved y b) -> m (Result error (Proved y b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved y b) -> m (Result error (Proved y b)))
-> Result error (Proved y b) -> m (Result error (Proved y b))
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)] -> Result error (Proved y b)
forall e ok. [(FormRange, e)] -> Result e ok
Error ([(FormRange, error)] -> Result error (Proved y b))
-> [(FormRange, error)] -> Result error (Proved y b)
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)]
errs1 [(FormRange, error)]
-> [(FormRange, error)] -> [(FormRange, error)]
forall a. [a] -> [a] -> [a]
++ [(FormRange, error)]
errs2)
                     (Error [(FormRange, error)]
errs1, Result error (Proved x a)
_)           -> (View error view, m (Result error (Proved y b)))
-> FormState
     m input (View error view, m (Result error (Proved y b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
view1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
view2, Result error (Proved y b) -> m (Result error (Proved y b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved y b) -> m (Result error (Proved y b)))
-> Result error (Proved y b) -> m (Result error (Proved y b))
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)] -> Result error (Proved y b)
forall e ok. [(FormRange, e)] -> Result e ok
Error ([(FormRange, error)] -> Result error (Proved y b))
-> [(FormRange, error)] -> Result error (Proved y b)
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)]
errs1)
                     (Result error (Proved (x -> y) (a -> b))
_          , Error [(FormRange, error)]
errs2) -> (View error view, m (Result error (Proved y b)))
-> FormState
     m input (View error view, m (Result error (Proved y b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
view1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
view2, Result error (Proved y b) -> m (Result error (Proved y b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved y b) -> m (Result error (Proved y b)))
-> Result error (Proved y b) -> m (Result error (Proved y b))
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)] -> Result error (Proved y b)
forall e ok. [(FormRange, e)] -> Result e ok
Error ([(FormRange, error)] -> Result error (Proved y b))
-> [(FormRange, error)] -> Result error (Proved y b)
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)]
errs2)
                     (Ok (Proved x -> y
p (FormRange FormId
x FormId
_) a -> b
f), Ok (Proved x
q (FormRange FormId
_ FormId
y) a
a)) ->
                         (View error view, m (Result error (Proved y b)))
-> FormState
     m input (View error view, m (Result error (Proved y b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
view1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
view2, Result error (Proved y b) -> m (Result error (Proved y b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved y b) -> m (Result error (Proved y b)))
-> Result error (Proved y b) -> m (Result error (Proved y b))
forall a b. (a -> b) -> a -> b
$ Proved y b -> Result error (Proved y b)
forall e ok. ok -> Result e ok
Ok (Proved y b -> Result error (Proved y b))
-> Proved y b -> Result error (Proved y b)
forall a b. (a -> b) -> a -> b
$ Proved :: forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved { proofs :: y
proofs   = x -> y
p x
q
                                                                           , pos :: FormRange
pos      = FormId -> FormId -> FormRange
FormRange FormId
x FormId
y
                                                                           , unProved :: b
unProved = a -> b
f a
a
                                                                           })

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


instance (Functor m) => Functor (Form m input error view ()) where
    fmap :: (a -> b)
-> Form m input error view () a -> Form m input error view () b
fmap a -> b
f Form m input error view () a
form =
        FormState m input (View error view, m (Result error (Proved () b)))
-> Form m input error view () b
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState
   m input (View error view, m (Result error (Proved () b)))
 -> Form m input error view () b)
-> FormState
     m input (View error view, m (Result error (Proved () b)))
-> Form m input error view () b
forall a b. (a -> b) -> a -> b
$ ((View error view, m (Result error (Proved () a)))
 -> (View error view, m (Result error (Proved () b))))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (View error view, m (Result error (Proved () a)))
-> FormState
     m input (View error view, m (Result error (Proved () b)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m (Result error (Proved () a)) -> m (Result error (Proved () b)))
-> (View error view, m (Result error (Proved () a)))
-> (View error view, m (Result error (Proved () b)))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Result error (Proved () a) -> Result error (Proved () b))
-> m (Result error (Proved () a)) -> m (Result error (Proved () b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Proved () a -> Proved () b)
-> Result error (Proved () a) -> Result error (Proved () b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Proved () a -> Proved () b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)))) (Form m input error view () a
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (View error view, m (Result error (Proved () a)))
forall (m :: * -> *) input error view proof a.
Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
unForm Form m input error view () a
form)


instance (Functor m, Monoid view, Monad m) => Applicative (Form m input error view ()) where
    pure :: a -> Form m input error view () a
pure a
a =
      FormState m input (View error view, m (Result error (Proved () a)))
-> Form m input error view () a
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState
   m input (View error view, m (Result error (Proved () a)))
 -> Form m input error view () a)
-> FormState
     m input (View error view, m (Result error (Proved () a)))
-> Form m input error view () a
forall a b. (a -> b) -> a -> b
$
        do FormId
i <- FormState m input FormId
forall (m :: * -> *) i. Monad m => FormState m i FormId
getFormId
           (View error view, m (Result error (Proved () a)))
-> FormState
     m input (View error view, m (Result error (Proved () a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (([(FormRange, error)] -> view) -> View error view
forall error v. ([(FormRange, error)] -> v) -> View error v
View (([(FormRange, error)] -> view) -> View error view)
-> ([(FormRange, error)] -> view) -> View error view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, error)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, error)] -> view)
-> view -> [(FormRange, error)] -> view
forall a b. (a -> b) -> a -> b
$ view
forall a. Monoid a => a
mempty, Result error (Proved () a) -> m (Result error (Proved () a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved () a) -> m (Result error (Proved () a)))
-> Result error (Proved () a) -> m (Result error (Proved () a))
forall a b. (a -> b) -> a -> b
$ Proved () a -> Result error (Proved () a)
forall e ok. ok -> Result e ok
Ok (Proved () a -> Result error (Proved () a))
-> Proved () a -> Result error (Proved () a)
forall a b. (a -> b) -> a -> b
$ Proved :: forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved { proofs :: ()
proofs    = ()
                                                               , pos :: FormRange
pos       = FormId -> FormId -> FormRange
FormRange FormId
i FormId
i
                                                               , unProved :: a
unProved  = a
a
                                                               })
    -- this coud be defined in terms of <<*>> if we just changed the proof of frmF to (() -> ())
    (Form FormState
  m input (View error view, m (Result error (Proved () (a -> b))))
frmF) <*> :: Form m input error view () (a -> b)
-> Form m input error view () a -> Form m input error view () b
<*> (Form FormState m input (View error view, m (Result error (Proved () a)))
frmA) =
       FormState m input (View error view, m (Result error (Proved () b)))
-> Form m input error view () b
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState
   m input (View error view, m (Result error (Proved () b)))
 -> Form m input error view () b)
-> FormState
     m input (View error view, m (Result error (Proved () b)))
-> Form m input error view () b
forall a b. (a -> b) -> a -> b
$
         do ((View error view
view1, m (Result error (Proved () (a -> b)))
mfok), (View error view
view2, m (Result error (Proved () a))
maok)) <- FormState
  m
  input
  ((View error view, m (Result error (Proved () (a -> b)))),
   (View error view, m (Result error (Proved () a))))
-> FormState
     m
     input
     ((View error view, m (Result error (Proved () (a -> b)))),
      (View error view, m (Result error (Proved () a))))
forall (m :: * -> *) input a.
Monad m =>
FormState m input a -> FormState m input a
bracketState (FormState
   m
   input
   ((View error view, m (Result error (Proved () (a -> b)))),
    (View error view, m (Result error (Proved () a))))
 -> FormState
      m
      input
      ((View error view, m (Result error (Proved () (a -> b)))),
       (View error view, m (Result error (Proved () a)))))
-> FormState
     m
     input
     ((View error view, m (Result error (Proved () (a -> b)))),
      (View error view, m (Result error (Proved () a))))
-> FormState
     m
     input
     ((View error view, m (Result error (Proved () (a -> b)))),
      (View error view, m (Result error (Proved () a))))
forall a b. (a -> b) -> a -> b
$
              do (View error view, m (Result error (Proved () (a -> b))))
res1 <- FormState
  m input (View error view, m (Result error (Proved () (a -> b))))
frmF
                 FormState m input ()
forall (m :: * -> *) i. Monad m => FormState m i ()
incFormId
                 (View error view, m (Result error (Proved () a)))
res2 <- FormState m input (View error view, m (Result error (Proved () a)))
frmA
                 ((View error view, m (Result error (Proved () (a -> b)))),
 (View error view, m (Result error (Proved () a))))
-> FormState
     m
     input
     ((View error view, m (Result error (Proved () (a -> b)))),
      (View error view, m (Result error (Proved () a))))
forall (m :: * -> *) a. Monad m => a -> m a
return ((View error view, m (Result error (Proved () (a -> b))))
res1, (View error view, m (Result error (Proved () a)))
res2)
            Result error (Proved () (a -> b))
fok <- StateT FormRange m (Result error (Proved () (a -> b)))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result error (Proved () (a -> b)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT FormRange m (Result error (Proved () (a -> b)))
 -> ReaderT
      (Environment m input)
      (StateT FormRange m)
      (Result error (Proved () (a -> b))))
-> StateT FormRange m (Result error (Proved () (a -> b)))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result error (Proved () (a -> b)))
forall a b. (a -> b) -> a -> b
$ m (Result error (Proved () (a -> b)))
-> StateT FormRange m (Result error (Proved () (a -> b)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Result error (Proved () (a -> b)))
 -> StateT FormRange m (Result error (Proved () (a -> b))))
-> m (Result error (Proved () (a -> b)))
-> StateT FormRange m (Result error (Proved () (a -> b)))
forall a b. (a -> b) -> a -> b
$ m (Result error (Proved () (a -> b)))
mfok
            Result error (Proved () a)
aok <- StateT FormRange m (Result error (Proved () a))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result error (Proved () a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT FormRange m (Result error (Proved () a))
 -> ReaderT
      (Environment m input)
      (StateT FormRange m)
      (Result error (Proved () a)))
-> StateT FormRange m (Result error (Proved () a))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (Result error (Proved () a))
forall a b. (a -> b) -> a -> b
$ m (Result error (Proved () a))
-> StateT FormRange m (Result error (Proved () a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Result error (Proved () a))
 -> StateT FormRange m (Result error (Proved () a)))
-> m (Result error (Proved () a))
-> StateT FormRange m (Result error (Proved () a))
forall a b. (a -> b) -> a -> b
$ m (Result error (Proved () a))
maok
            case (Result error (Proved () (a -> b))
fok, Result error (Proved () a)
aok) of
              (Error [(FormRange, error)]
errs1, Error [(FormRange, error)]
errs2) -> (View error view, m (Result error (Proved () b)))
-> FormState
     m input (View error view, m (Result error (Proved () b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
view1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
view2, Result error (Proved () b) -> m (Result error (Proved () b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved () b) -> m (Result error (Proved () b)))
-> Result error (Proved () b) -> m (Result error (Proved () b))
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)] -> Result error (Proved () b)
forall e ok. [(FormRange, e)] -> Result e ok
Error ([(FormRange, error)] -> Result error (Proved () b))
-> [(FormRange, error)] -> Result error (Proved () b)
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)]
errs1 [(FormRange, error)]
-> [(FormRange, error)] -> [(FormRange, error)]
forall a. [a] -> [a] -> [a]
++ [(FormRange, error)]
errs2)
              (Error [(FormRange, error)]
errs1, Result error (Proved () a)
_)           -> (View error view, m (Result error (Proved () b)))
-> FormState
     m input (View error view, m (Result error (Proved () b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
view1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
view2, Result error (Proved () b) -> m (Result error (Proved () b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved () b) -> m (Result error (Proved () b)))
-> Result error (Proved () b) -> m (Result error (Proved () b))
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)] -> Result error (Proved () b)
forall e ok. [(FormRange, e)] -> Result e ok
Error ([(FormRange, error)] -> Result error (Proved () b))
-> [(FormRange, error)] -> Result error (Proved () b)
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)]
errs1)
              (Result error (Proved () (a -> b))
_          , Error [(FormRange, error)]
errs2) -> (View error view, m (Result error (Proved () b)))
-> FormState
     m input (View error view, m (Result error (Proved () b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
view1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
view2, Result error (Proved () b) -> m (Result error (Proved () b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved () b) -> m (Result error (Proved () b)))
-> Result error (Proved () b) -> m (Result error (Proved () b))
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)] -> Result error (Proved () b)
forall e ok. [(FormRange, e)] -> Result e ok
Error ([(FormRange, error)] -> Result error (Proved () b))
-> [(FormRange, error)] -> Result error (Proved () b)
forall a b. (a -> b) -> a -> b
$ [(FormRange, error)]
errs2)
              (Ok (Proved ()
p (FormRange FormId
x FormId
_) a -> b
f), Ok (Proved ()
q (FormRange FormId
_ FormId
y) a
a)) ->
                  (View error view, m (Result error (Proved () b)))
-> FormState
     m input (View error view, m (Result error (Proved () b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
view1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
view2, Result error (Proved () b) -> m (Result error (Proved () b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved () b) -> m (Result error (Proved () b)))
-> Result error (Proved () b) -> m (Result error (Proved () b))
forall a b. (a -> b) -> a -> b
$ Proved () b -> Result error (Proved () b)
forall e ok. ok -> Result e ok
Ok (Proved () b -> Result error (Proved () b))
-> Proved () b -> Result error (Proved () b)
forall a b. (a -> b) -> a -> b
$ Proved :: forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved { proofs :: ()
proofs   = ()
                                                                      , pos :: FormRange
pos      = FormId -> FormId -> FormRange
FormRange FormId
x FormId
y
                                                                      , unProved :: b
unProved = a -> b
f a
a
                                                                      })

-- ** Ways to evaluate a Form

-- | Run a form
--
runForm :: (Monad m) =>
           Environment m input
        -> Text
        -> Form m input error view proof a
        -> m (View error view, m (Result error (Proved proof a)))
runForm :: Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
runForm Environment m input
env Text
prefix' Form m input error view proof a
form =
    StateT
  FormRange m (View error view, m (Result error (Proved proof a)))
-> FormRange
-> m (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT
  (Environment m input)
  (StateT FormRange m)
  (View error view, m (Result error (Proved proof a)))
-> Environment m input
-> StateT
     FormRange m (View error view, m (Result error (Proved proof a)))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Form m input error view proof a
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) input error view proof a.
Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
unForm Form m input error view proof a
form) Environment m input
env) (FormId -> FormRange
unitRange (String -> FormId
zeroId (String -> FormId) -> String -> FormId
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
prefix'))

-- | Run a form
--
runForm' :: (Monad m) =>
            Environment m input
         -> Text
        -> Form m input error view proof a
        -> m (view , Maybe a)
runForm' :: Environment m input
-> Text -> Form m input error view proof a -> m (view, Maybe a)
runForm' Environment m input
env Text
prefix Form m input error view proof a
form =
    do (View error view
view', m (Result error (Proved proof a))
mresult) <- Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) input error view proof a.
Monad m =>
Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
runForm Environment m input
env Text
prefix Form m input error view proof a
form
       Result error (Proved proof a)
result <- m (Result error (Proved proof a))
mresult
       (view, Maybe a) -> m (view, Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((view, Maybe a) -> m (view, Maybe a))
-> (view, Maybe a) -> m (view, Maybe a)
forall a b. (a -> b) -> a -> b
$ case Result error (Proved proof a)
result of
                  Error [(FormRange, error)]
e  -> (View error view -> [(FormRange, error)] -> view
forall error v. View error v -> [(FormRange, error)] -> v
unView View error view
view' [(FormRange, error)]
e , Maybe a
forall a. Maybe a
Nothing)
                  Ok Proved proof a
x     -> (View error view -> [(FormRange, error)] -> view
forall error v. View error v -> [(FormRange, error)] -> v
unView View error view
view' [], a -> Maybe a
forall a. a -> Maybe a
Just (Proved proof a -> a
forall proofs a. Proved proofs a -> a
unProved Proved proof a
x))

-- | Just evaluate the form to a view. This usually maps to a GET request in the
-- browser.
--
viewForm :: (Monad m) =>
            Text                          -- ^ form prefix
         -> Form m input error view proof a -- ^ form to view
         -> m view
viewForm :: Text -> Form m input error view proof a -> m view
viewForm Text
prefix Form m input error view proof a
form =
    do (View error view
v, m (Result error (Proved proof a))
_) <- Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) input error view proof a.
Monad m =>
Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
runForm Environment m input
forall (m :: * -> *) input. Environment m input
NoEnvironment Text
prefix Form m input error view proof a
form
       view -> m view
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view -> [(FormRange, error)] -> view
forall error v. View error v -> [(FormRange, error)] -> v
unView View error view
v [])

-- | Evaluate a form
--
-- Returns:
--
-- [@Left view@] on failure. The @view@ will have already been applied to the errors.
--
-- [@Right a@] on success.
--
eitherForm :: (Monad m) =>
              Environment m input             -- ^ Input environment
           -> Text                          -- ^ Identifier for the form
           -> Form m input error view proof a -- ^ Form to run
           -> m (Either view a)               -- ^ Result
eitherForm :: Environment m input
-> Text -> Form m input error view proof a -> m (Either view a)
eitherForm Environment m input
env Text
id' Form m input error view proof a
form = do
    (View error view
view', m (Result error (Proved proof a))
mresult) <- Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) input error view proof a.
Monad m =>
Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
runForm Environment m input
env Text
id' Form m input error view proof a
form
    Result error (Proved proof a)
result <- m (Result error (Proved proof a))
mresult
    Either view a -> m (Either view a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either view a -> m (Either view a))
-> Either view a -> m (Either view a)
forall a b. (a -> b) -> a -> b
$ case Result error (Proved proof a)
result of
        Error [(FormRange, error)]
e  -> view -> Either view a
forall a b. a -> Either a b
Left (view -> Either view a) -> view -> Either view a
forall a b. (a -> b) -> a -> b
$ View error view -> [(FormRange, error)] -> view
forall error v. View error v -> [(FormRange, error)] -> v
unView View error view
view' [(FormRange, error)]
e
        Ok Proved proof a
x     -> a -> Either view a
forall a b. b -> Either a b
Right (Proved proof a -> a
forall proofs a. Proved proofs a -> a
unProved Proved proof a
x)

-- | create a 'Form' from some @view@.
--
-- This is typically used to turn markup like @\<br\>@ into a 'Form'.
view :: (Monad m) =>
        view                           -- ^ View to insert
     -> Form m input error view () ()  -- ^ Resulting form
view :: view -> Form m input error view () ()
view view
view' =
  FormState
  m input (View error view, m (Result error (Proved () ())))
-> Form m input error view () ()
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState
   m input (View error view, m (Result error (Proved () ())))
 -> Form m input error view () ())
-> FormState
     m input (View error view, m (Result error (Proved () ())))
-> Form m input error view () ()
forall a b. (a -> b) -> a -> b
$
    do FormId
i <- FormState m input FormId
forall (m :: * -> *) i. Monad m => FormState m i FormId
getFormId
       (View error view, m (Result error (Proved () ())))
-> FormState
     m input (View error view, m (Result error (Proved () ())))
forall (m :: * -> *) a. Monad m => a -> m a
return ( ([(FormRange, error)] -> view) -> View error view
forall error v. ([(FormRange, error)] -> v) -> View error v
View (view -> [(FormRange, error)] -> view
forall a b. a -> b -> a
const view
view')
              , Result error (Proved () ()) -> m (Result error (Proved () ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Proved () () -> Result error (Proved () ())
forall e ok. ok -> Result e ok
Ok (Proved :: forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved { proofs :: ()
proofs   = ()
                                   , pos :: FormRange
pos      = FormId -> FormId -> FormRange
FormRange FormId
i FormId
i
                                   , unProved :: ()
unProved = ()
                                   })))

-- | Append a unit form to the left. This is useful for adding labels or error
-- fields.
--
-- The 'Forms' on the left and right hand side will share the same
-- 'FormId'. This is useful for elements like @\<label
-- for=\"someid\"\>@, which need to refer to the id of another
-- element.
(++>) :: (Monad m, Monoid view)
      => Form m input error view () ()
      -> Form m input error view proof a
      -> Form m input error view proof a
Form m input error view () ()
f1 ++> :: Form m input error view () ()
-> Form m input error view proof a
-> Form m input error view proof a
++> Form m input error view proof a
f2 = FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState
   m input (View error view, m (Result error (Proved proof a)))
 -> Form m input error view proof a)
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
forall a b. (a -> b) -> a -> b
$ do
    -- Evaluate the form that matters first, so we have a correct range set
    (View error view
v2, m (Result error (Proved proof a))
r) <- Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) input error view proof a.
Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
unForm Form m input error view proof a
f2
    (View error view
v1, m (Result error (Proved () ()))
_) <- Form m input error view () ()
-> FormState
     m input (View error view, m (Result error (Proved () ())))
forall (m :: * -> *) input error view proof a.
Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
unForm Form m input error view () ()
f1
    (View error view, m (Result error (Proved proof a)))
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
v1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
v2, m (Result error (Proved proof a))
r)

infixl 6 ++>

-- | Append a unit form to the right. See '++>'.
--
(<++) :: (Monad m, Monoid view)
      => Form m input error view proof a
      -> Form m input error view () ()
      -> Form m input error view proof a
Form m input error view proof a
f1 <++ :: Form m input error view proof a
-> Form m input error view () () -> Form m input error view proof a
<++ Form m input error view () ()
f2 = FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState
   m input (View error view, m (Result error (Proved proof a)))
 -> Form m input error view proof a)
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
forall a b. (a -> b) -> a -> b
$ do
    -- Evaluate the form that matters first, so we have a correct range set
    (View error view
v1, m (Result error (Proved proof a))
r) <- Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) input error view proof a.
Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
unForm Form m input error view proof a
f1
    (View error view
v2, m (Result error (Proved () ()))
_) <- Form m input error view () ()
-> FormState
     m input (View error view, m (Result error (Proved () ())))
forall (m :: * -> *) input error view proof a.
Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
unForm Form m input error view () ()
f2
    (View error view, m (Result error (Proved proof a)))
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (View error view
v1 View error view -> View error view -> View error view
forall a. Monoid a => a -> a -> a
`mappend` View error view
v2, m (Result error (Proved proof a))
r)

infixr 5 <++

-- | 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 :: (Monad m, Functor m)
        => (view -> view')        -- ^ Manipulator
        -> Form m input error view  proof a  -- ^ Initial form
        -> Form m input error view' proof a  -- ^ Resulting form
mapView :: (view -> view')
-> Form m input error view proof a
-> Form m input error view' proof a
mapView view -> view'
f = FormState
  m input (View error view', m (Result error (Proved proof a)))
-> Form m input error view' proof a
forall (m :: * -> *) input error view proof a.
FormState
  m input (View error view, m (Result error (Proved proof a)))
-> Form m input error view proof a
Form (FormState
   m input (View error view', m (Result error (Proved proof a)))
 -> Form m input error view' proof a)
-> (Form m input error view proof a
    -> FormState
         m input (View error view', m (Result error (Proved proof a))))
-> Form m input error view proof a
-> Form m input error view' proof a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((View error view, m (Result error (Proved proof a)))
 -> (View error view', m (Result error (Proved proof a))))
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (View error view, m (Result error (Proved proof a)))
-> FormState
     m input (View error view', m (Result error (Proved proof a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((View error view -> View error view')
-> (View error view, m (Result error (Proved proof a)))
-> (View error view', m (Result error (Proved proof a)))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((View error view -> View error view')
 -> (View error view, m (Result error (Proved proof a)))
 -> (View error view', m (Result error (Proved proof a))))
-> (View error view -> View error view')
-> (View error view, m (Result error (Proved proof a)))
-> (View error view', m (Result error (Proved proof a)))
forall a b. (a -> b) -> a -> b
$ (view -> view') -> View error view -> View error view'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap view -> view'
f) (ReaderT
   (Environment m input)
   (StateT FormRange m)
   (View error view, m (Result error (Proved proof a)))
 -> FormState
      m input (View error view', m (Result error (Proved proof a))))
-> (Form m input error view proof a
    -> ReaderT
         (Environment m input)
         (StateT FormRange m)
         (View error view, m (Result error (Proved proof a))))
-> Form m input error view proof a
-> FormState
     m input (View error view', m (Result error (Proved proof a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Form m input error view proof a
-> ReaderT
     (Environment m input)
     (StateT FormRange m)
     (View error view, m (Result error (Proved proof a)))
forall (m :: * -> *) input error view proof a.
Form m input error view proof a
-> FormState
     m input (View error view, m (Result error (Proved proof a)))
unForm

-- | Utility Function: turn a view and return value into a successful 'FormState'
mkOk :: (Monad m) =>
         FormId
      -> view
      -> a
      -> FormState m input (View error view, m (Result error (Proved () a)))
mkOk :: FormId
-> view
-> a
-> FormState
     m input (View error view, m (Result error (Proved () a)))
mkOk FormId
i view
view a
val =
    (View error view, m (Result error (Proved () a)))
-> FormState
     m input (View error view, m (Result error (Proved () a)))
forall (m :: * -> *) a. Monad m => a -> m a
return ( ([(FormRange, error)] -> view) -> View error view
forall error v. ([(FormRange, error)] -> v) -> View error v
View (([(FormRange, error)] -> view) -> View error view)
-> ([(FormRange, error)] -> view) -> View error view
forall a b. (a -> b) -> a -> b
$ view -> [(FormRange, error)] -> view
forall a b. a -> b -> a
const (view -> [(FormRange, error)] -> view)
-> view -> [(FormRange, error)] -> view
forall a b. (a -> b) -> a -> b
$ view
view
           , Result error (Proved () a) -> m (Result error (Proved () a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result error (Proved () a) -> m (Result error (Proved () a)))
-> Result error (Proved () a) -> m (Result error (Proved () a))
forall a b. (a -> b) -> a -> b
$ Proved () a -> Result error (Proved () a)
forall e ok. ok -> Result e ok
Ok (Proved :: forall proofs a. proofs -> FormRange -> a -> Proved proofs a
Proved { proofs :: ()
proofs   = ()
                                 , pos :: FormRange
pos      = FormId -> FormRange
unitRange FormId
i
                                 , unProved :: a
unProved = a
val
                                 })
           )