ditto 0.1.3.0 → 0.2

raw patch · 8 files changed

+262/−206 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ditto.cabal +1/−1
• src/Ditto/Backend.hs +25/−8
• src/Ditto/Core.hs +129/−140
• src/Ditto/Generalized.hs +16/−7
• src/Ditto/Generalized/Internal.hs +60/−15
• src/Ditto/Generalized/Named.hs +17/−7
• src/Ditto/Proof.hs +1/−1
• src/Ditto/Result.hs +13/−27

@@ -1,5 +1,5 @@ Name:          ditto-Version:       0.1.3.0+Version:       0.2 Synopsis:      ditto is a type-safe HTML form generation and validation library Description:   ditto follows in the footsteps of formlets and                digestive-functors <= 0.2. It provides a

@@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}  {- | This module contains two classes. 'FormInput' is a class which is parameterized over the @input@ type used to represent form data in different web frameworks. There should be one instance for each framework, such as Happstack, Snap, WAI, etc.@@ -32,19 +33,35 @@   :: (input -> String) -- ^ show 'input' in a format suitable for error messages   -> CommonFormError input -- ^ a 'CommonFormError'   -> String-commonFormErrorStr showInput cfe =-  case cfe of-    (InputMissing formId) -> "Input field missing for " ++ show formId-    (NoStringFound input) -> "Could not extract a string value from: " ++ showInput input-    (NoFileFound input) -> "Could not find a file associated with: " ++ showInput input-    (MultiFilesFound input) -> "Found multiple files associated with: " ++ showInput input-    (MultiStringsFound input) -> "Found multiple strings associated with: " ++ showInput input-    MissingDefaultValue -> "Missing default value."+commonFormErrorStr showInput cfe = case cfe of+  InputMissing formId -> "Input field missing for " ++ show formId+  NoStringFound input -> "Could not extract a string value from: " ++ showInput input+  NoFileFound input -> "Could not find a file associated with: " ++ showInput input+  MultiFilesFound input -> "Found multiple files associated with: " ++ showInput input+  MultiStringsFound input -> "Found multiple strings associated with: " ++ showInput input+  MissingDefaultValue -> "Missing default value." +-- | some default error messages for 'CommonFormError'+commonFormErrorText+  :: (input -> Text) -- ^ show 'input' in a format suitable for error messages+  -> CommonFormError input -- ^ a 'CommonFormError'+  -> Text+commonFormErrorText showInput cfe = case cfe of+  InputMissing formId -> "Input field missing for " <> (T.pack $ show formId)+  NoStringFound input -> "Could not extract a string value from: " <> showInput input+  NoFileFound input -> "Could not find a file associated with: " <> showInput input+  MultiFilesFound input -> "Found multiple files associated with: " <> showInput input+  MultiStringsFound input -> "Found multiple strings associated with: " <> showInput input+  MissingDefaultValue -> "Missing default value."+ -- | A Class to lift a 'CommonFormError' into an application-specific error type class FormError e where   type ErrorInputType e   commonFormError :: (CommonFormError (ErrorInputType e)) -> e++instance FormError Text where+  type ErrorInputType Text = Text+  commonFormError = commonFormErrorText id  -- | Class which all backends should implement. --

@@ -1,12 +1,15 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}  {- | This module defines the 'Form' type, its instances, core manipulation functions, and a bunch of helper utilities. -} module Ditto.Core where -import Control.Applicative (Applicative ((<*>), pure))+import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad.Reader (MonadReader (ask), ReaderT, runReaderT) import Control.Monad.State (MonadState (get, put), StateT, evalStateT) import Control.Monad.Trans (lift)@@ -15,22 +18,17 @@ import Data.Monoid (Monoid (mappend, mempty)) import Data.Text.Lazy (Text, unpack) import Ditto.Result (FormId (..), FormRange (..), Result (..), unitRange, zeroId)-import qualified Data.Semigroup as SG  ------------------------------------------------------------------------------ -- * Proved ------------------------------------------------------------------------------  -- | Proved records a value, the location that value came from, and something that was proved about the value.-data Proved a-  = Proved-      { pos :: FormRange-      , unProved :: a-      }-  deriving Show--instance Functor Proved where-  fmap f (Proved posi a) = Proved posi (f a)+data Proved a = Proved+  { pos :: FormRange+  , unProved :: a+  }+  deriving (Show, Functor)  -- | Utility Function: trivially prove nothing about () unitProved :: FormId -> Proved ()@@ -67,8 +65,7 @@   env <- ask   case env of     NoEnvironment -> pure Default-    Environment f ->-      lift $ lift $ f id'+    Environment f -> lift $ lift $ f id'  -- | Utility function: Get the current range --@@ -86,30 +83,26 @@   = Environment (FormId -> m (Value input))   | NoEnvironment -instance (SG.Semigroup input, Monad m) => SG.Semigroup (Environment m input) where-+instance (Semigroup input, Monad m) => Semigroup (Environment m input) where   NoEnvironment <> x = x   x <> NoEnvironment = x   (Environment env1) <> (Environment env2) =-    Environment $ \id' ->-      do-        r1 <- (env1 id')-        r2 <- (env2 id')-        case (r1, r2) of-          (Missing, Missing) -> pure Missing-          (Default, Missing) -> pure Default-          (Missing, Default) -> pure Default-          (Default, Default) -> pure Default-          (Found x, Found y) -> pure $ Found (x SG.<> y)-          (Found x, _) -> pure $ Found x-          (_, Found y) -> pure $ Found y+    Environment $ \id' -> do+      r1 <- (env1 id')+      r2 <- (env2 id')+      case (r1, r2) of+        (Missing, Missing) -> pure Missing+        (Default, Missing) -> pure Default+        (Missing, Default) -> pure Default+        (Default, Default) -> pure Default+        (Found x, Found y) -> pure $ Found (x <> y)+        (Found x, _) -> pure $ Found x+        (_, Found y) -> pure $ Found 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-+instance (Semigroup input, Monad m) => Monoid (Environment m input) where   mempty = NoEnvironment--  mappend = (SG.<>)+  mappend = (<>)  -- | Utility function: returns the current 'FormId'. This will only make sense -- if the form is not composed@@ -135,14 +128,9 @@ -- | 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-      { unView :: [(FormRange, error)] -> v-      }-  deriving (SG.Semigroup, Monoid)--instance Functor (View e) where-  fmap f (View g) = View $ f . g+newtype View err v+  = View { unView :: [(FormRange, err)] -> v }+  deriving (Semigroup, Monoid, Functor)  ------------------------------------------------------------------------------ -- * Form@@ -160,7 +148,7 @@ -- --   [@input@] A framework specific type for representing the raw key/value pairs from the form data -----   [@error@] A application specific type for error messages+--   [@err@] A application specific type for err messages -- --   [@view@] The type of data being generated for the view (HSP, Blaze Html, Heist, etc) --@@ -173,44 +161,8 @@ -- @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 a = Form {unForm :: FormState m input (View error view, m (Result error (Proved a)))}---- instance (Monad m) => Functor (Form m input view error) where---   fmap f (Form frm) =---     Form $ do---       (view1, mval) <- frm---       val <- lift $ lift $ mval---       case val of---         (Ok (Proved posi a)) -> pure (view1, pure $ Ok (Proved posi (f a)))---         (Error errs) -> pure (view1, pure $ Error errs)---- instance (Semigroup view, Monad m) => Applicative (Form m input error view) where---   pure a =---     Form $ do---       i <- getFormId---       pure (mempty, pure $ Ok (Proved (unitRange i) a))---   (Form frmF) <*> (Form frmA) =---     Form $ do---       ((view1, mfok), (view2, maok)) <----         bracketState $ do---           res1 <- frmF---           incFormId---           res2 <- frmA---           pure (res1, res2)---       fok <- lift $ lift $ mfok---       aok <- lift $ lift $ maok---       case (fok, aok) of---         (Error errs1, Error errs2) -> pure (view1 <> view2, pure $ Error $ errs1 ++ errs2)---         (Error errs1, _) -> pure (view1 <> view2, pure $ Error $ errs1)---         (_, Error errs2) -> pure (view1 <> view2, pure $ Error $ errs2)---         (Ok (Proved (FormRange x _) f), Ok (Proved (FormRange _ y) a)) ->---           pure---             ( view1 <> view2---             , pure $ Ok $ Proved---               { pos = FormRange x y---               , unProved = f a---               }---             )+newtype Form m input err view a = Form {unForm :: FormState m input (View err view, m (Result err (Proved a)))}+  deriving (Functor)  bracketState :: Monad m => FormState m input a -> FormState m input a bracketState k = do@@ -220,11 +172,7 @@   put $ FormRange startF1 endF2   pure res -instance (Functor m) => Functor (Form m input error view) where-  fmap f form =-    Form $ fmap (second (fmap (fmap (fmap f)))) (unForm form)--instance (Functor m, Monoid view, Monad m, x ~ ()) => Applicative (Form m input error view) where+instance (Functor m, Monoid view, Monad m) => Applicative (Form m input err view) where   pure a =     Form $ do       i <- getFormId@@ -236,7 +184,6 @@           }         ) -  -- this coud be defined in terms of <<*>> if we just changed the proof of frmF to (() -> ())   (Form frmF) <*> (Form frmA) =     Form $ do       ((view1, mfok), (view2, maok)) <-@@ -260,47 +207,88 @@               }             ) +instance (Monad m, Monoid view) => Alternative (Form m input err view) where+  empty = Form $ pure (mempty, pure $ Error mempty)+  formA <|> formB = Form $ do+    (_, mres0) <- unForm formA+    res0 <- lift $ lift mres0+    case res0 of+      Ok _ -> unForm formA+      Error _ -> unForm formB++instance Functor m => Bifunctor (Form m input err) where+  first = mapView+  second = fmap++instance (Monad m, Monoid view, Semigroup a) => Semigroup (Form m input err view a) where+  (<>) = liftA2 (<>)++instance (Monoid view, Monad m, Semigroup a) => Monoid (Form m input err view a) where+  mempty = Form $ pure (mempty, pure $ Error mempty)++-- | This provides a Monad instance which will stop rendering on err.+--   This instance isn't a part of @Form@ because of its undesirable behavior.+--   @-XApplicativeDo@ is generally preferred+newtype MForm m input err view a = MForm { runMForm :: Form m input err view a }+  deriving (Functor, Bifunctor, Alternative, Applicative)++instance (Monad m, Monoid view) => Monad (MForm m input err view) where+  (MForm formA) >>= formFunction = MForm $ Form $ do+    (view0, mfok) <- unForm formA+    fok :: Result err (Proved a) <- lift $ lift mfok+    case fok of+      Ok x -> do+        (view1, mfok1) <- unForm $ runMForm $ formFunction $ unProved x+        pure+          ( view0 <> view1+          , mfok1+          )+      Error errs -> pure (view0, pure $ Error errs) ++runAsMForm+  :: (Monad m)+  => Environment m input+  -> Text+  -> Form m input err view a+  -> m (View err view, m (Result err (Proved a)))+runAsMForm env prefix' = runForm env prefix' . runMForm . MForm+ -- ** Ways to evaluate a Form  -- | Run a form--- runForm   :: (Monad m)   => Environment m input   -> Text-  -> Form m input error view a-  -> m (View error view, m (Result error (Proved a)))+  -> Form m input err view a+  -> m (View err view, m (Result err (Proved a))) runForm env prefix' form =   evalStateT (runReaderT (unForm form) env) (unitRange (zeroId $ unpack prefix'))  -- | Run a form--- runForm'   :: (Monad m)   => Environment m input   -> Text-  -> Form m input error view a+  -> Form m input err view a   -> m (view, Maybe a)-runForm' env prefix form =-  do-    (view', mresult) <- runForm env prefix form-    result <- mresult-    pure $ case result of-      Error e -> (unView view' e, Nothing)-      Ok x -> (unView view' [], Just (unProved x))+runForm' env prefix form = do+  (view', mresult) <- runForm env prefix form+  result <- mresult+  pure $ case result of+    Error e -> (unView view' e, Nothing)+    Ok x -> (unView view' [], Just (unProved 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 a -- ^ form to view+  -> Form m input err view a -- ^ form to view   -> m view-viewForm prefix form =-  do-    (v, _) <- runForm NoEnvironment prefix form-    pure (unView v [])+viewForm prefix form = do+  (v, _) <- runForm NoEnvironment prefix form+  pure (unView v [])  -- | Evaluate a form --@@ -314,7 +302,7 @@   :: (Monad m)   => Environment m input -- ^ Input environment   -> Text -- ^ Identifier for the form-  -> Form m input error view a -- ^ Form to run+  -> Form m input err view a -- ^ Form to run   -> m (Either view a) -- ^ Result eitherForm env id' form = do   (view', mresult) <- runForm env id' form@@ -329,23 +317,22 @@ view   :: (Monad m)   => view -- ^ View to insert-  -> Form m input error view () -- ^ Resulting form-view view' =-  Form $ do-    i <- getFormId-    pure-      ( View (const view')-      , pure-        ( Ok-          ( Proved-            { pos = FormRange i i-            , unProved = ()-            }-          )+  -> Form m input err view () -- ^ Resulting form+view view' = Form $ do+  i <- getFormId+  pure+    ( View (const view')+    , pure+      ( Ok+        ( Proved+          { pos = FormRange i i+          , unProved = ()+          }         )       )+    ) --- | Append a unit form to the left. This is useful for adding labels or error+-- | Append a unit form to the left. This is useful for adding labels or err -- fields. -- -- The 'Forms' on the left and right hand side will share the same@@ -354,31 +341,28 @@ -- element. (++>)   :: (Monad m, Semigroup view)-  => Form m input error view ()-  -> Form m input error view a-  -> Form m input error view a-f1 ++> f2 =-  Form $ do-    -- Evaluate the form that matters first, so we have a correct range set-    (v2, r) <- unForm f2-    (v1, _) <- unForm f1-    pure (v1 <> v2, r)+  => Form m input err view z+  -> Form m input err view a+  -> Form m input err view a+f1 ++> f2 = Form $ do+  -- Evaluate the form that matters first, so we have a correct range set+  (v2, r) <- unForm f2+  (v1, _) <- unForm f1+  pure (v1 <> v2, r)  infixl 6 ++>  -- | Append a unit form to the right. See '++>'.--- (<++)   :: (Monad m, Semigroup view)-  => Form m input error view a-  -> Form m input error view ()-  -> Form m input error view a-f1 <++ f2 =-  Form $ do-    -- Evaluate the form that matters first, so we have a correct range set-    (v1, r) <- unForm f1-    (v2, _) <- unForm f2-    pure (v1 <> v2, r)+  => Form m input err view a+  -> Form m input err view z+  -> Form m input err view a+f1 <++ f2 = Form $ do+  -- Evaluate the form that matters first, so we have a correct range set+  (v1, r) <- unForm f1+  (v2, _) <- unForm f2+  pure (v1 <> v2, r)  infixr 5 <++ @@ -386,19 +370,24 @@ -- -- This is useful for wrapping a form inside of a \<fieldset\> or other markup element. mapView-  :: (Monad m, Functor m)+  :: (Functor m)   => (view -> view') -- ^ Manipulator-  -> Form m input error view a -- ^ Initial form-  -> Form m input error view' a -- ^ Resulting form+  -> Form m input err view a -- ^ Initial form+  -> Form m input err view' a -- ^ Resulting form mapView f = Form . fmap (first $ fmap f) . unForm +-- | infix mapView: succinct `foo @$ do ..`+infixr 0 @$+(@$) :: Monad 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 input (View error view, m (Result error (Proved a)))+  -> FormState m input (View err view, m (Result err (Proved a))) mkOk i view' val =   pure     ( View $ const $ view'

@@ -18,16 +18,24 @@ inputMaybe   :: (Monad m, FormError err)   => (input -> Either err a)-  -> (FormId -> a -> view)-  -> a+  -> (FormId -> Maybe a -> view)+  -> Maybe a   -> Form m input err view (Maybe a) inputMaybe = G.inputMaybe getFormId +-- | used to construct elements with optional initial values, which are still required+inputMaybeReq+  :: (Monad m, FormError err)+  => (input -> Either err a)+  -> (FormId -> Maybe a -> view)+  -> Maybe a+  -> Form m input err view a+inputMaybeReq = G.inputMaybeReq getFormId+ -- | used for elements like @\<input type=\"reset\"\>@ which take a value, but are never present in the form data set. inputNoData   :: (Monad m)-  => (FormId -> a -> view)-  -> a+  => (FormId -> view)   -> Form m input err view () inputNoData = G.inputNoData getFormId @@ -40,7 +48,7 @@  -- | used for groups of checkboxes, @\<select multiple=\"multiple\"\>@ boxes inputMulti-  :: forall m input err view a lbl. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m)+  :: forall m input err view a lbl. (FormError err, ErrorInputType err ~ input, FormInput input, Monad m)   => [(a, lbl)] -- ^ value, label, initially checked   -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view   -> (a -> Bool) -- ^ isChecked/isSelected initially@@ -49,7 +57,7 @@  -- | radio buttons, single @\<select\>@ boxes inputChoice-  :: forall a m err input lbl view. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m)+  :: forall a m err input lbl view. (FormError err, ErrorInputType err ~ input, FormInput input, Monad m)   => (a -> Bool) -- ^ is default   -> [(a, lbl)] -- ^ value, label   -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view@@ -58,7 +66,7 @@  -- | radio buttons, single @\<select\>@ boxes inputChoiceForms-  :: forall a m err input lbl view. (Functor m, Monad m, FormError err, ErrorInputType err ~ input, FormInput input)+  :: forall a m err input lbl view. (Monad m, FormError err, ErrorInputType err ~ input, FormInput input)   => a   -> [(Form m input err view a, lbl)] -- ^ value, label   -> (FormId -> [(FormId, Int, FormId, view, lbl, Bool)] -> view) -- ^ function which generates the view@@ -97,3 +105,4 @@   -> Form m input err view a   -> Form m input err view a withErrors = G.withErrors+

@@ -19,7 +19,7 @@ -- | used for constructing elements like @\<input type=\"text\"\>@, which pure a single input value. input   :: (Monad m, FormError err)-  => FormState m input FormId +  => FormState m input FormId   -> (input -> Either err a)   -> (FormId -> a -> view)   -> a@@ -40,7 +40,7 @@                 }               )           )-      Found x -> case fromInput x of +      Found x -> case fromInput x of         Right a -> pure           ( View $ const $ toView i a           , pure $@@ -60,13 +60,58 @@         , pure $ Error [(unitRange i, commonFormError (InputMissing i))]         ) +inputMaybeReq+  :: (Monad m, FormError err)+  => FormState m input FormId+  -> (input -> Either err a)+  -> (FormId -> Maybe a -> view)+  -> Maybe a+  -> Form m input err view a+inputMaybeReq i' fromInput toView initialValue =+  Form $ do+    i <- i'+    v <- getFormInput' i+    case v of+      Default ->+        pure+          ( View $ const $ toView i initialValue+          , case initialValue of +              Just x -> pure $+                Ok ( Proved+                       { pos = unitRange i+                       , unProved = x+                       }+                   )+              Nothing -> pure $ Error [(unitRange i, commonFormError MissingDefaultValue)]+          )+      Found x -> case fromInput x of+        Right a -> pure+          ( View $ const $ toView i (Just a)+          , pure $+            Ok+              ( Proved+                { pos = unitRange i+                , unProved = a+                }+              )+          )+        Left err -> pure+          ( View $ const $ toView i initialValue+          , pure $ Error [(unitRange i, err)]+          )+      Missing -> pure+        ( View $ const $ toView i initialValue+        , pure $ Error [(unitRange i, commonFormError (InputMissing i))]+        )++ -- | used for elements like @\<input type=\"submit\"\>@ which are not always present in the form submission data. inputMaybe   :: (Monad m, FormError err)   => FormState m input FormId   -> (input -> Either err a)-  -> (FormId -> a -> view)-  -> a+  -> (FormId -> Maybe a -> view)+  -> Maybe a   -> Form m input err view (Maybe a) inputMaybe i' fromInput toView initialValue =   Form $ do@@ -79,13 +124,13 @@             Ok               ( Proved                 { pos = unitRange i-                , unProved = Just initialValue+                , unProved = initialValue                 }               )           )       Found x -> case fromInput x of         Right a -> pure-          ( View $ const $ toView i a+          ( View $ const $ toView i (Just a)           , pure $             Ok               ( Proved@@ -113,14 +158,13 @@ inputNoData   :: (Monad m)   => FormState m input FormId-  -> (FormId -> a -> view)-  -> a+  -> (FormId -> view)   -> Form m input err view ()-inputNoData i' toView a =+inputNoData i' toView =   Form $ do     i <- i'     pure-      ( View $ const $ toView i a+      ( View $ const $ toView i       , pure $         Ok           ( Proved@@ -173,7 +217,7 @@  -- | used for groups of checkboxes, @\<select multiple=\"multiple\"\>@ boxes inputMulti-  :: forall m input err view a lbl. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m)+  :: forall m input err view a lbl. (FormError err, ErrorInputType err ~ input, FormInput input, Monad m)   => FormState m input FormId   -> [(a, lbl)] -- ^ value, label, initially checked   -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view@@ -230,7 +274,7 @@  -- | radio buttons, single @\<select\>@ boxes inputChoice-  :: forall a m err input lbl view. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m)+  :: forall a m err input lbl view. (FormError err, ErrorInputType err ~ input, FormInput input, Monad m)   => FormState m input FormId   -> (a -> Bool) -- ^ is default   -> [(a, lbl)] -- ^ value, label@@ -305,7 +349,7 @@  -- | radio buttons, single @\<select\>@ boxes inputChoiceForms-  :: forall a m err input lbl view. (Functor m, Monad m, FormError err, ErrorInputType err ~ input, FormInput input)+  :: forall a m err input lbl view. (Monad m, FormError err, ErrorInputType err ~ input, FormInput input)   => FormState m input FormId   -> a   -> [(Form m input err view a, lbl)] -- ^ value, label@@ -480,10 +524,11 @@   (View v, r) <- unForm form   range <- getFormRange   pure-    ( View -        (\x -> +    ( View+        (\x ->           let errs = retainChildErrors range x           in f (v x) errs         )     , r     )+

@@ -15,13 +15,24 @@ input :: (Monad m, FormError err) => String -> (input -> Either err a) -> (FormId -> a -> view) -> a -> Form m input err view a input name = G.input (getNamedFormId name) ++-- | used to construct elements with optional initial values, which are still required+inputMaybeReq+  :: (Monad m, FormError err)+  => String+  -> (input -> Either err a)+  -> (FormId -> Maybe a -> view)+  -> Maybe a+  -> Form m input err view a+inputMaybeReq name = G.inputMaybeReq (getNamedFormId name)+ -- | used for elements like @\<input type=\"submit\"\>@ which are not always present in the form submission data. inputMaybe   :: (Monad m, FormError err)   => String   -> (input -> Either err a)-  -> (FormId -> a -> view)-  -> a+  -> (FormId -> Maybe a -> view)+  -> Maybe a   -> Form m input err view (Maybe a) inputMaybe name = G.inputMaybe (getNamedFormId name) @@ -29,8 +40,7 @@ inputNoData   :: (Monad m)   => String-  -> (FormId -> a -> view)-  -> a+  -> (FormId -> view)   -> Form m input err view () inputNoData name = G.inputNoData (getNamedFormId name) @@ -44,7 +54,7 @@  -- | used for groups of checkboxes, @\<select multiple=\"multiple\"\>@ boxes inputMulti-  :: forall m input err view a lbl. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m)+  :: forall m input err view a lbl. (FormError err, ErrorInputType err ~ input, FormInput input, Monad m)   => String   -> [(a, lbl)] -- ^ value, label, initially checked   -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view@@ -54,7 +64,7 @@  -- | radio buttons, single @\<select\>@ boxes inputChoice-  :: forall a m err input lbl view. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m)+  :: forall a m err input lbl view. (FormError err, ErrorInputType err ~ input, FormInput input, Monad m)   => String   -> (a -> Bool) -- ^ is default   -> [(a, lbl)] -- ^ value, label@@ -64,7 +74,7 @@  -- | radio buttons, single @\<select\>@ boxes inputChoiceForms-  :: forall a m err input lbl view. (Functor m, Monad m, FormError err, ErrorInputType err ~ input, FormInput input)+  :: forall a m err input lbl view. (Monad m, FormError err, ErrorInputType err ~ input, FormInput input)   => String   -> a   -> [(Form m input err view a, lbl)] -- ^ value, label

@@ -10,9 +10,9 @@ module Ditto.Proof where  import Control.Monad.Trans (lift)-import Numeric (readDec, readFloat, readSigned) import Ditto.Core (Form (..), Proved (..)) import Ditto.Result (Result (..))+import Numeric (readDec, readFloat, readSigned)  -- | A 'Proof' attempts to prove something about a value. --

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveFunctor #-}+ -- | Module for the core result type, and related functions -- module Ditto.Result@@ -22,25 +24,18 @@ import qualified Data.List.NonEmpty as NE  -- | Type for failing computations--- data Result e ok   = Error [(FormRange, e)]   | Ok ok-  deriving (Show, Eq)--instance Functor (Result e) where-  fmap _ (Error x) = Error x-  fmap f (Ok x) = Ok (f x)+  deriving (Show, Eq, Functor)  instance Monad (Result e) where   return = Ok-   Error x >>= _ = Error x   Ok x >>= f = f x  instance Applicative (Result e) where   pure = Ok-   Error x <*> Error y = Error $ x ++ y   Error x <*> Ok _ = Error x   Ok _ <*> Error y = Error y@@ -52,24 +47,18 @@ getResult (Ok r) = Just r  -- | An ID used to identify forms--- data FormId   = FormId-      { -- | Global prefix for the form-        formPrefix :: String-      , -- | Stack indicating field. Head is most specific to this item-        formIdList :: NonEmpty Int-      }-  | FormIdCustom String Int+      String -- ^ Global prefix for the form+      (NonEmpty Int) -- ^ Stack indicating field. Head is most specific to this item+  | FormIdCustom +      String -- ^ Local name of the input+      Int -- ^ Index of the input   deriving (Eq, Ord)  -- | The zero ID, i.e. the first ID that is usable--- zeroId :: String -> FormId-zeroId p = FormId-  { formPrefix = p-  , formIdList = pure 0-  }+zeroId prefix = FormId prefix (pure 0)  -- | map a function over the @NonEmpty Int@ inside a 'FormId' mapId :: (NonEmpty Int -> NonEmpty Int) -> FormId -> FormId@@ -78,22 +67,23 @@  instance Show FormId where   show (FormId p xs) =-    p ++ "-fval-" ++ (intercalate "." $ reverse $ map show $ NE.toList xs)+    p ++ "-fval-" ++ (intercalate "." $ reverseMap show $ NE.toList xs)   show (FormIdCustom x _) = x +reverseMap :: Foldable t => (a -> b) -> t a -> [b]+reverseMap f = foldl (\as a -> f a : as ) []+ -- | get the head 'Int' from a 'FormId' formId :: FormId -> Int formId (FormId _ (x :| _)) = x formId (FormIdCustom _ x) = x  -- | A range of ID's to specify a group of forms--- data FormRange   = FormRange FormId FormId   deriving (Eq, Show)  -- | Increment a form ID--- incrementFormId :: FormId -> FormId incrementFormId (FormId p (x :| xs)) = FormId p $ (x + 1) :| xs incrementFormId x@FormIdCustom{} = x@@ -103,7 +93,6 @@ unitRange i = FormRange i $ incrementFormId i  -- | Check if a 'FormId' is contained in a 'FormRange'--- isInRange   :: FormId -- ^ Id to check for   -> FormRange -- ^ Range@@ -111,7 +100,6 @@ isInRange a (FormRange b c) = formId a >= formId b && formId a < formId c  -- | Check if a 'FormRange' is contained in another 'FormRange'--- isSubRange   :: FormRange -- ^ Sub-range   -> FormRange -- ^ Larger range@@ -122,12 +110,10 @@     formId d  -- | Select the errors for a certain range--- retainErrors :: FormRange -> [(FormRange, e)] -> [e] retainErrors range = map snd . filter ((== range) . fst)  -- | Select the errors originating from this form or from any of the children of -- this form--- retainChildErrors :: FormRange -> [(FormRange, e)] -> [e] retainChildErrors range = map snd . filter ((`isSubRange` range) . fst)