ditto 0.4 → 0.4.1

raw patch · 9 files changed

+255/−280 lines, 9 filesdep −semigroupsdep −torsordep ~containersdep ~mtldep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: semigroups, torsor

Dependency ranges changed: containers, mtl, text

API changes (from Hackage documentation)

Files

• LICENSE +2/−1
• ditto.cabal +27/−28
• src/Ditto.hs +2/−1
• src/Ditto/Backend.hs +11/−11
• src/Ditto/Core.hs +132/−133
• src/Ditto/Generalized/Internal.hs +39/−55
• src/Ditto/Generalized/Named.hs +0/−1
• src/Ditto/Proof.hs +25/−30
• src/Ditto/Types.hs +17/−20

@@ -1,4 +1,5 @@-Copyright (c)2012, Jeremy Shaw+Copyright (c) 2012, Jeremy Shaw+Copyright (c) 2019, Zachary Churchill  All rights reserved. 

@@ -1,28 +1,29 @@-Name:          ditto-Version:       0.4-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-               type-safe and composable method for generating-               an HTML form that includes validation.-License:       BSD3-License-file:  LICENSE-Author:        Jeremy Shaw, Jasper Van der Jeugt <m@jaspervdj.be>-Maintainer:    Zachary Churchill <zacharyachurchill@gmail.com>-Copyright:     2012 Jeremy Shaw, Jasper Van der Jeugt, SeeReason Partners LLC,-               2019 Zachary Churchill-Category:      Web-Build-type:    Simple-Cabal-version: >=1.6-tested-with:   GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.6.3+cabal-version: 3.0+name: ditto+version: 0.4.1+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+  type-safe and composable method for generating+  an HTML form that includes validation.+license: BSD-3-Clause+license-file: LICENSE+author: Zachary Churchill <zacharyachurchill@gmail.com>+maintainer: Zachary Churchill <zacharyachurchill@gmail.com>+copyright:+  2012 Jeremy Shaw, Jasper Van der Jeugt, SeeReason Partners LLC,+  2019 Zachary Churchill+category: Web+build-type: Simple  source-repository head-    type:     git-    location: https://github.com/goolord/ditto.git+  type: git+  location: https://github.com/goolord/ditto.git  library   ghc-options: -Wall-  exposed-modules: +  exposed-modules:     Ditto     Ditto.Core     Ditto.Types@@ -32,12 +33,10 @@     Ditto.Generalized.Unnamed   other-modules:     Ditto.Generalized.Internal-  build-depends:       +  build-depends:       base       >= 4    && < 5-    , containers >= 0.4  && < 0.7-    , mtl        >= 2.0  && < 2.3-    , semigroups >= 0.16 && < 0.20-    , text       >= 0.11 && < 1.3-    , torsor     <  0.2-  hs-source-dirs:      src-+    , containers >= 0.4  && < 1.0+    , mtl        >= 2.0  && < 3.0+    , text       >= 0.11 && < 3.0+  hs-source-dirs: src+  default-language: Haskell2010

@@ -1,5 +1,5 @@ -- | Reexports important modules of @ditto@-module Ditto +module Ditto   ( module P   ) where @@ -7,3 +7,4 @@ import Ditto.Core as P import Ditto.Proof as P import Ditto.Types as P+

@@ -1,4 +1,4 @@-{-# LANGUAGE +{-# LANGUAGE     MultiParamTypeClasses   , TypeFamilies   , OverloadedStrings@@ -36,12 +36,12 @@   :: (input -> String) -- ^ show 'input' in a format suitable for error messages   -> CommonFormError input -- ^ a 'CommonFormError'   -> String-commonFormErrorStr showInput cfe = case cfe of+commonFormErrorStr encodeInput cfe = case cfe of   InputMissing formId -> "Input field missing for " ++ (T.unpack . encodeFormId) 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+  NoStringFound input -> "Could not extract a string value from: " ++ encodeInput input+  NoFileFound input -> "Could not find a file associated with: " ++ encodeInput input+  MultiFilesFound input -> "Found multiple files associated with: " ++ encodeInput input+  MultiStringsFound input -> "Found multiple strings associated with: " ++ encodeInput input   MissingDefaultValue -> "Missing default value."  -- | some default error messages for 'CommonFormError'@@ -49,12 +49,12 @@   :: (input -> Text) -- ^ show 'input' in a format suitable for error messages   -> CommonFormError input -- ^ a 'CommonFormError'   -> Text-commonFormErrorText showInput cfe = case cfe of+commonFormErrorText encodeInput cfe = case cfe of   InputMissing formId -> "Input field missing for " <> encodeFormId 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+  NoStringFound input -> "Could not extract a string value from: " <> encodeInput input+  NoFileFound input -> "Could not find a file associated with: " <> encodeInput input+  MultiFilesFound input -> "Found multiple files associated with: " <> encodeInput input+  MultiStringsFound input -> "Found multiple strings associated with: " <> encodeInput input   MissingDefaultValue -> "Missing default value."  -- | A Class to lift a 'CommonFormError' into an application-specific error type

@@ -1,24 +1,21 @@-{-# LANGUAGE +{-# LANGUAGE     DeriveFunctor   , FlexibleInstances   , FunctionalDependencies   , GeneralizedNewtypeDeriving+  , LambdaCase   , NamedFieldPuns   , OverloadedStrings   , RankNTypes+  , RecordWildCards   , ScopedTypeVariables   , StandaloneDeriving-  , TypeFamilies-  , LiberalTypeSynonyms-  , TypeSynonymInstances-  , UndecidableInstances-  , DataKinds-  , KindSignatures+  , TypeApplications #-} --- | The core module for @ditto@. +-- | The core module for @ditto@. ----- This module provides the @Form@ type and helper functions +-- 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@@ -45,7 +42,6 @@   , getNamedFormId   , incrementFormId   , isInRange-  , mapFormMonad   , mapResult   , mapView   , mkOk@@ -65,11 +61,10 @@ import Control.Monad.Reader import Control.Monad.State.Lazy import Data.Bifunctor+import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text)-import Ditto.Types import Ditto.Backend-import Torsor-+import Ditto.Types ------------------------------------------------------------------------------ -- Form types ------------------------------------------------------------------------------@@ -78,50 +73,42 @@ type FormState m = StateT FormRange m  -- | @ditto@'s representation of a formlet-data Form m input err view a = Form +--+-- It's reccommended to use @ApplicativeDo@ where possible when constructing forms+data Form m input err view a = Form   { formDecodeInput :: input -> m (Either err a) -- ^ Decode the value from the input   , formInitialValue :: m a -- ^ The initial value-  , formFormlet :: FormState m (View err view, Result err (Proved a)) -- ^ A @FormState@ which produced a @View@ and a @Result@+  , formFormlet :: FormState m (View err view, Result err (Proved a)) -- ^ A @FormState@ which produces a @View@ and a @Result@   } deriving (Functor)  instance (Monad m, Monoid view) => Applicative (Form m input err view) where -  pure x = Form (successDecode x) (pure x) $ do-    i <- getFormId-    pure  ( mempty-          , Ok $ Proved-              { pos = FormRange i i-              , unProved = x-              }-          )+  pure x = Form (successDecode x) (pure x) (pureFormState x) -  (Form df ivF frmF) <*> (Form da ivA frmA) =-    Form -      ( \inp -> do -        f <- df inp-        x <- da inp-        pure (f <*> x) ) -      (ivF <*> ivA) -      ( do+  (Form df ivF frmF) <*> (Form da ivA frmA) = Form+    { formDecodeInput = \inp -> liftA2 (<*>) (df inp) (da inp)+    , formInitialValue = ivF <*> ivA+    , formFormlet = do         ((view1, fok), (view2, aok)) <-           bracketState $ do             res1 <- frmF             incrementFormRange             res2 <- frmA             pure (res1, res2)+        let view' = view1 <> view2         case (fok, aok) of-          (Error errs1, Error errs2) -> pure (view1 <> view2, Error $ errs1 ++ errs2)-          (Error errs1, _) -> pure (view1 <> view2, Error errs1)-          (_, Error errs2) -> pure (view1 <> view2, Error errs2)-          (Ok (Proved (FormRange x _) f), Ok (Proved (FormRange _ y) a)) ->+          (Error errs1, Error errs2) -> pure (view', Error $ errs1 ++ errs2)+          (Error errs1, _) -> pure (view', Error errs1)+          (_, Error errs2) -> pure (view', Error errs2)+          (Ok (Proved (FormRange l _) f), Ok (Proved (FormRange _ r) a)) ->             pure-              ( view1 <> view2+              ( view'               , Ok $ Proved-                { pos = FormRange x y+                { pos = FormRange l r                 , unProved = f a                 }               )-      )+    }    f1 *> f2 = Form (formDecodeInput f2) (formInitialValue f2) $ do     -- Evaluate the form that matters first, so we have a correct range set@@ -137,36 +124,34 @@  instance (Environment m input, Monoid view, FormError input err) => Monad (Form m input err view) where   form >>= f =-    let mres = fmap snd $ runForm "" form +    let mres = snd <$> runForm "" form     in Form-      (\input -> do-        res <- mres-        case res of-          Error {} -> do-            iv <- formInitialValue form-            formDecodeInput (f iv) input-          Ok (Proved _ x) -> formDecodeInput (f x) input-      ) -      (do -        res <- mres-        case res of-          Error {} -> do-            iv <- formInitialValue form-            formInitialValue $ f iv-          Ok (Proved _ x) -> formInitialValue (f x)-      )-      (do-        (View viewF0, res0) <- formFormlet form-        case res0 of-          Error errs0 -> do -            iv <- lift $ formInitialValue form-            (View viewF, res) <- formFormlet $ f iv-            let errs = case res of-                  Error es -> es-                  Ok {} -> []-            pure (View $ const $ viewF0 errs0 <> viewF errs, Error (errs0 <> errs))-          Ok (Proved _ x) -> fmap (first (\(View v) -> View $ \e -> viewF0 [] <> v e)) $ formFormlet (f x)-      )+      { formDecodeInput = \input -> do+          mres >>= \case+            Error {} -> do+              iv <- formInitialValue form+              formDecodeInput (f iv) input+            Ok (Proved _ x) -> formDecodeInput (f x) input+      , formInitialValue = do+          mres >>= \case+            Error {} -> do+              iv <- formInitialValue form+              formInitialValue $ f iv+            Ok (Proved _ x) -> formInitialValue (f x)+      , formFormlet = do+          (View viewF0, res0) <- formFormlet form+          case res0 of+            Error errs0 -> do+              iv <- lift $ formInitialValue form+              (View viewF, res) <- formFormlet $ f iv+              let errs = case res of+                    Error es -> es+                    Ok {} -> []+              pure (View $ const $ viewF0 errs0 <> viewF errs, Error (errs0 <> errs))+            Ok (Proved _ x) ->+                  first (\(View v) -> View $ \e -> viewF0 [] <> v e)+              <$> formFormlet (f x)+      }   return = pure   (>>) = (*>) -- way more efficient than the default @@ -184,7 +169,7 @@ errorInitialValue = "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 +  empty = Form     failDecodeMDF     (error errorInitialValue)     (pure (mempty, Error []))@@ -211,7 +196,7 @@  -- | @environment@ which will always return the initial value noEnvironment :: Applicative m => FormId -> m (Value input)-noEnvironment = const (pure Default)+noEnvironment = const $ pure Default  -- | Run the form, but with a given @environment@ function newtype WithEnvironment input m a = WithEnvironment { getWithEnvironment :: ReaderT (FormId -> m (Value input)) m a }@@ -232,12 +217,7 @@ ------------------------------------------------------------------------------  failDecodeMDF :: forall m input err a. (Applicative m, FormError input err) => input -> m (Either err a)-failDecodeMDF = const $ pure $ Left err-  where-  mdf :: CommonFormError input-  mdf = MissingDefaultValue-  err :: err-  err = commonFormError mdf+failDecodeMDF = const $ pure $ Left $ commonFormError (MissingDefaultValue @input)  -- | Always succeed decoding successDecode :: Applicative m => a -> (input -> m (Either err a))@@ -252,20 +232,24 @@   => (view -> view') -- ^ Manipulator   -> Form m input err view a -- ^ Initial form   -> Form m input err view' a -- ^ Resulting form-mapView f Form{formDecodeInput, formInitialValue, formFormlet} = -  Form formDecodeInput formInitialValue (fmap (first (fmap f)) formFormlet)+mapView f Form{formDecodeInput, formInitialValue, formFormlet=formFormlet'} =+  let formFormlet = fmap (first (fmap f)) formFormlet'+  in Form {..}  -- | Increment a form ID incrementFormId :: FormId -> FormId-incrementFormId fid = add 1 fid+incrementFormId = add 1+  where+  add i (FormId p (x :| xs)) = FormId p $ (x + i) :| xs+  add i (FormIdName n x) = FormIdName n $ x + 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 a (FormRange b c) = -     formIdentifier a >= formIdentifier b +isInRange a (FormRange b c) =+     formIdentifier a >= formIdentifier b   && formIdentifier a < formIdentifier c  -- | Check if a 'FormRange' is contained in another 'FormRange'@@ -274,7 +258,7 @@   -> FormRange -- ^ Larger range   -> Bool -- ^ If the sub-range is contained in the larger range isSubRange (FormRange a b) (FormRange c d) =-     formIdentifier a >= formIdentifier c +     formIdentifier a >= formIdentifier c   && formIdentifier b <= formIdentifier d  -- | Get a @FormId@ from the FormState@@ -295,7 +279,7 @@  -- | Turns a @FormId@ into a @FormRange@ by incrementing the base for the end Id unitRange :: FormId -> FormRange-unitRange i = FormRange i $ add 1 i+unitRange i = FormRange i $ incrementFormId i  bracketState :: Monad m => FormState m a -> FormState m a bracketState k = do@@ -312,29 +296,31 @@   put $ unitRange endF1  -- | Run a form-runForm :: Monad m +runForm :: Monad m   => Text   -> Form m input err view a   -> m (View err view, Result err (Proved a)) runForm prefix Form{formFormlet} =-  evalStateT formFormlet (unitRange (FormId prefix (pure 0)))+  evalStateT formFormlet $ unitRange $ FormId prefix (pure 0)  -- | Run a form, and unwrap the result runForm_ :: (Monad m)   => Text   -> Form m input err view a-  -> m (view , Maybe a)-runForm_ prefix form = do +  -> m (view, Maybe a)+runForm_ prefix form = do   (view', result) <- runForm prefix form   pure $ case result of-    Error e -> (unView view' e , Nothing)+    Error e -> (unView view' e, Nothing)     Ok x -> (unView view' [], Just (unProved x))  -- | Evaluate a form -- -- Returns: ----- [@Left view@] on failure. The @view@ will have already been applied to the errors.+-- [@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. --@@ -344,11 +330,12 @@   -> m (Either view a) -- ^ Result eitherForm id' form = do   (view', result) <- runForm id' form-  return $ case result of-    Error e -> Left $ unView view' e+  pure $ case result of+    Error e -> Left (unView view' e)     Ok x -> Right (unProved x) --- | infix mapView: succinctly mix the @view@ dsl and the formlets dsl  @foo \@$ do ..@+-- | 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 (@$) = mapView@@ -361,39 +348,38 @@   -> a   -> FormState m (View err view, Result err (Proved a)) mkOk i view' val = pure-  ( View $ const $ view'-  , Ok ( Proved+  ( View $ const view'+  , Ok $ Proved       { pos = unitRange i       , unProved = 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 a   -> Form m input err view (Either [err] a) formEither Form{formDecodeInput, formInitialValue, formFormlet} = Form-  (\input -> do -    res <- formDecodeInput input-    case res of-      Left err -> pure $ Right $ Left [err]-      Right x -> pure $ Right $ Right x-  ) -  (fmap Right formInitialValue) -  ( do-    range <- get-    (view', res') <- formFormlet-    let res = case res' of-          Error err -> Left (map snd err)-          Ok (Proved _ x) -> Right x-    pure  -      ( view'-      , Ok $ Proved -          { pos = range-          , unProved = res-          }-      )-  )+  { formDecodeInput = \input -> do+      res <- formDecodeInput input+      case res of+        Left err -> pure $ Right $ Left [err]+        Right x -> pure $ Right $ Right x+  , formInitialValue = fmap Right formInitialValue+  , formFormlet = do+      range <- get+      (view', res') <- formFormlet+      let res = case res' of+            Error err -> Left (map snd err)+            Ok (Proved _ x) -> Right x+      pure+        ( view'+        , Ok $ Proved+            { pos = range+            , unProved = res+            }+        )+  }  -- | Utility function: Get the current input getFormInput :: Environment m input => FormState m (Value input)@@ -405,14 +391,19 @@  -- | Select the errors for a certain range retainErrors :: FormRange -> [(FormRange, e)] -> [e]-retainErrors range = map snd . filter ((== range) . fst)+retainErrors = retainErrorsOn (==)  -- | 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)+retainChildErrors = retainErrorsOn isSubRange --- | Turn a @view@ into a @Form@+{-# INLINE retainErrorsOn #-}+retainErrorsOn :: (FormRange -> FormRange -> Bool) -> FormRange -> [(FormRange, e)] -> [e]+retainErrorsOn f range = map snd . filter ((`f` range) . 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 html = Form (successDecode ()) (pure ()) $ do   i <- getFormId@@ -423,20 +414,17 @@             }         ) --- | Change the underlying Monad of the form, usually a @lift@ or newtype-mapFormMonad :: (Monad f)+-- | 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-mapFormMonad f Form{formDecodeInput, formInitialValue, formFormlet} = Form +hoistForm f Form{formDecodeInput, formInitialValue, formFormlet} = Form   { formDecodeInput = f . formDecodeInput   , formInitialValue = f formInitialValue-  , formFormlet = do-      (view', res) <- fstate formFormlet-      pure $ (view', res)+  , formFormlet = mapStateT f formFormlet   }-  where-  fstate st = StateT $ f . runStateT st  -- | Catch errors purely catchFormError :: (Monad m)@@ -455,7 +443,7 @@   => Form m input err view a   -> ([err] -> Form m input err view a)   -> Form m input err view a-catchFormErrorM form@(Form{formDecodeInput, formInitialValue}) e = Form formDecodeInput formInitialValue $ do+catchFormErrorM form@Form{formDecodeInput, formInitialValue} e = Form formDecodeInput formInitialValue $ do   (_, res0) <- formFormlet form   case res0 of     Ok _ -> formFormlet form@@ -478,7 +466,7 @@   -> Form m input err view a -- ^ form to view   -> m view viewForm prefix form = do-  (v, _) <- getNoEnvironment $ runForm prefix $ mapFormMonad NoEnvironment form+  (v, _) <- getNoEnvironment $ runForm prefix $ hoistForm NoEnvironment form   pure (unView v [])  -- | lift the result of a decoding to a @Form@@@ -503,8 +491,19 @@  -- | @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 x = Form (const (fmap Right x)) x $ do-  res <- lift x-  i <- getFormId-  pure (mempty, Ok $ Proved (FormRange i i) res)+liftForm x = Form+  { formDecodeInput = const (fmap Right x)+  , formInitialValue = x+  , formFormlet = lift x >>= pureFormState+  } +-- | lift a value to a @Form@'s formlet+pureFormState :: (Monad m, Monoid view) => a -> FormState m (view, Result err (Proved a))+pureFormState x = do+  i <- getFormId+  pure  ( mempty+        , Ok $ Proved+            { pos = FormRange i i+            , unProved = x+            }+        )

@@ -1,6 +1,5 @@-{-# LANGUAGE +{-# LANGUAGE     NamedFieldPuns-  , OverloadedStrings   , ScopedTypeVariables   , LambdaCase   , TypeFamilies@@ -12,6 +11,7 @@  import Control.Monad.State.Class (get) import Control.Monad.Trans (lift)+import Data.Either import Data.List (find) import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable (for)@@ -70,23 +70,20 @@     v <- getFormInput' i     case v of       Default -> do-        let ivs' = case initialValue of-              [] -> []-              _ -> initialValue-        views <- for ivs' $ \x -> do-          (View viewF, _) <- formFormlet $ createForm x +        views <- for initialValue $ \x -> do+          (View viewF, _) <- formFormlet $ createForm x           pure $ viewF []         pure           ( View $ const $ viewCat views           , Ok $ Proved               { pos = unitRange i-              , unProved = ivs'+              , unProved = initialValue               }           )       Found inp -> lift (fromInput inp) >>= \case         Right xs -> do           views <- for xs $ \x -> do-            (View viewF, _) <- formFormlet $ createForm x +            (View viewF, _) <- formFormlet $ createForm x             pure $ viewF []           pure             ( View $ const $ viewCat views@@ -98,13 +95,13 @@         Left err -> do           let err' = [(unitRange i, err)]           views <- for initialValue $ \x -> do-            (View viewF, _) <- formFormlet $ createForm x +            (View viewF, _) <- formFormlet $ createForm x             pure $ viewF err'           pure             ( View $ const $ viewCat views             , Error err'             )-      Missing -> do +      Missing -> do         pure           ( View $ const defView           , Ok $ Proved@@ -127,17 +124,17 @@     case v of       Default -> pure           ( View $ const $ toView i initialValue-          , Ok ( Proved+          , Ok Proved               { pos = unitRange i               , unProved = initialValue-              })+              }           )       Found x -> case fromInput x of         Right a -> pure           ( View $ const $ toView i (Just a)-          , Ok $ Proved+          , Ok Proved               { pos = unitRange i-              , unProved = (Just a)+              , unProved = Just a               }           )         Left err -> pure@@ -162,10 +159,10 @@     i <- i'     pure       ( View $ const $ toView i-      , Ok ( Proved+      , Ok Proved           { pos = unitRange i           , unProved = ()-          })+          }       )  -- | used for @\<input type=\"file\"\>@@@ -174,7 +171,7 @@   -> (FormId -> view)   -> Form m input err view (FileType input) inputFile i' toView =-  Form (pure . getInputFile') (pure mempty) $ do -- FIXME+  Form (pure . getInputFile) (pure mempty) $ do -- FIXME     i <- i'     v <- getFormInput' i     case v of@@ -183,13 +180,13 @@           ( View $ const $ toView i           , Error [(unitRange i, commonFormError (InputMissing i :: CommonFormError input) :: err)]           )-      Found x -> case getInputFile' x of+      Found x -> case getInputFile x of         Right a -> pure           ( View $ const $ toView i-          , Ok ( Proved+          , Ok Proved               { pos = unitRange i               , unProved = a-              })+              }           )         Left err -> pure           ( View $ const $ toView i@@ -200,10 +197,6 @@           ( View $ const $ toView i           , Error [(unitRange i, commonFormError (InputMissing i :: CommonFormError input) ::err)]           )-  where-    -- just here for the type-signature to make the type-checker happy-    getInputFile' :: (FormError input err) => input -> Either err (FileType input)-    getInputFile' = getInputFile  -- | used for groups of checkboxes, @\<select multiple=\"multiple\"\>@ boxes inputMulti :: forall m input err view a lbl. (FormError input err, FormInput input, Environment m input, Eq a)@@ -228,14 +221,14 @@                 )                 ([], [])                 choices-        view' <- mkView i <$> augmentChoices choices'+        view' <- mkView i <$> augmentChoices i choices'         mkOk i view' vals       Missing -> do         -- just means that no checkboxes were checked-        view' <- mkView i <$> augmentChoices (map (\(x, y) -> (x, y, False)) choices)+        view' <- mkView i <$> augmentChoices i (map (\(x, y) -> (x, y, False)) choices)         mkOk i view' []       Found v -> do-        let keys = either (const []) id $ fromInput v+        let keys = fromRight [] $ fromInput v             (choices', vals) =               foldr                 ( \(a, lbl) (c, v0) ->@@ -243,18 +236,18 @@                   then ((a, lbl, True) : c, a : v0)                   else ((a, lbl, False) : c, v0)                 )-                ([], []) $+                ([], [])                 choices-        view' <- mkView i <$> augmentChoices choices'+        view' <- mkView i <$> augmentChoices i choices'         mkOk i view' vals-  where-    augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m [Choice lbl a]-    augmentChoices choices' = mapM augmentChoice choices'-    augmentChoice :: (Monad m) => (a, lbl, Bool) -> FormState m (Choice lbl a)-    augmentChoice (a, lbl, selected) = do-      i <- i'-      pure $ Choice i lbl selected a +augmentChoices :: (Monad m) => FormId ->  [(a, lbl, Bool)] -> FormState m [Choice lbl a]+augmentChoices i choices = mapM (augmentChoice i) choices++augmentChoice :: (Monad m) => FormId -> (a, lbl, Bool) -> FormState m (Choice lbl a)+augmentChoice i (a, lbl, selected) = do+  pure $ Choice i lbl selected a+ -- | a choice for inputChoice data Choice lbl a = Choice   { choiceFormId :: FormId -- ^ the formId@@ -281,12 +274,12 @@     case inp of       Default -> do         let (choices', def) = markSelected choices-        view' <- mkView i <$> augmentChoices choices'+        view' <- mkView i <$> augmentChoices i choices'         mkOk' i view' def       Missing -> do         -- can happen if no choices where checked         let (choices', def) = markSelected choices-        view' <- mkView i <$> augmentChoices choices'+        view' <- mkView i <$> augmentChoices i choices'         mkOk' i view' def       Found v -> do         case fromInput v of@@ -296,7 +289,7 @@                     ( \(a, lbl) c -> (a, lbl, False) : c )                     []                     choices-            view' <- mkView i <$> augmentChoices choices'+            view' <- mkView i <$> augmentChoices i choices'             pure               ( View $ const view'               , Error [(unitRange i, err)]@@ -309,9 +302,9 @@                       then ((a, lbl, True) : c, Just a)                       else ((a, lbl, False) : c, v0)                     )-                    ([], Nothing) $+                    ([], Nothing)                     choices-            view' <- mkView i <$> augmentChoices choices'+            view' <- mkView i <$> augmentChoices i choices'             case mval of               Nothing -> pure                 ( View $ const view'@@ -322,7 +315,7 @@     mkOk' i view' (Just val) = mkOk i view' val     mkOk' i view' Nothing =       pure-        ( View $ const $ view'+        ( View $ const view'         , Error [(unitRange i, commonFormError (MissingDefaultValue :: CommonFormError input) :: err)]         )     markSelected :: Foldable f => f (a, lbl) -> ([(a, lbl, Bool)], Maybe a)@@ -335,12 +328,6 @@         )         ([], Nothing)         cs-    augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m [Choice lbl a]-    augmentChoices choices' = mapM augmentChoice choices'-    augmentChoice :: (Monad m) => (a, lbl, Bool) -> FormState m (Choice lbl a)-    augmentChoice (a, lbl, selected) = do-      i <- i'-      pure $ Choice i lbl selected a  -- | used to create @\<label\>@ elements label :: Monad m@@ -351,11 +338,10 @@   id' <- i'   pure     ( View (const $ f id')-    , ( Ok $ Proved+    , Ok $ Proved         { pos = unitRange id'         , unProved = ()         }-      )     )  -- | used to add a list of err messages to a 'Form'@@ -370,11 +356,10 @@   range <- get   pure     ( View (f . retainErrors range)-    , ( Ok $ Proved+    , Ok $ Proved         { pos = range         , unProved = ()         }-      )     )  -- | similar to 'errors' but includes err messages from children of the form as well.@@ -385,11 +370,10 @@   range <- get   pure     ( View (f . retainChildErrors range)-    , ( Ok $ Proved+    , Ok $ Proved         { pos = range         , unProved = ()         }-      )     )  -- | modify the view of a form based on its child errors

@@ -195,4 +195,3 @@           , unProved = Nothing           } )       )-

@@ -1,12 +1,7 @@-{-# LANGUAGE -    DeriveFoldable-  , DeriveFunctor-  , DeriveTraversable-  , GeneralizedNewtypeDeriving-  , MultiParamTypeClasses +{-# LANGUAGE+    DeriveFunctor   , NamedFieldPuns   , ScopedTypeVariables-  , StandaloneDeriving #-}  {- |@@ -38,8 +33,8 @@  data Proof m err a b = Proof   { proofFunction :: a -> m (Either err b) -- ^ function which provides the proof-  , proofNewInitialValue :: a -> b-  }+  , proofNewInitialValue :: a -> b -- ^ usually @const b@+  } deriving (Functor)  -- | apply a 'Proof' to a 'Form' prove@@ -47,8 +42,8 @@   => Form m input error view a   -> Proof m error a b   -> Form m input error view b-prove (Form{formDecodeInput, formInitialValue, formFormlet}) (Proof f ivB) = Form -  (\input -> do +prove Form{formDecodeInput, formInitialValue, formFormlet} (Proof f ivB) = Form+  (\input -> do     a <- formDecodeInput input     case a of       Left x -> pure $ Left x@@ -79,7 +74,7 @@   -> (a -> m (Either error b))   -> (a -> b)   -> Form m input error view b-transformEitherM frm func ivb = frm `prove` (Proof func ivb)+transformEitherM frm func ivb = frm `prove` Proof func ivb  -- | transform the 'Form' result using an 'Either' function. transformEither@@ -98,8 +93,8 @@   where     check list =       if null list-      then (Left errorMsg)-      else (Right list)+      then Left errorMsg+      else Right list  -- | read an unsigned number in decimal notation decimal@@ -111,42 +106,42 @@   where     toDecimal str =       case readDec str of-        [(d, [])] -> (Right d)-        _ -> (Left $ mkError str)+        [(d, [])] -> Right d+        _ -> Left $ mkError str  -- | read signed decimal number-signedDecimal :: (Monad m, Eq i, Real i) -  => (String -> error) +signedDecimal :: (Monad m, Eq i, Real i)+  => (String -> error)   -> i   -> Proof m error String i signedDecimal mkError i = Proof (pure . toDecimal) (const i)   where     toDecimal str =-      case (readSigned readDec) str of-        [(d, [])] -> (Right d)-        _ -> (Left $ mkError str)+      case readSigned readDec str of+        [(d, [])] -> Right d+        _ -> Left $ mkError str  -- | read 'RealFrac' number-realFrac :: (Monad m, RealFrac a) -  => (String -> error) +realFrac :: (Monad m, RealFrac a)+  => (String -> error)   -> a   -> Proof m error String a realFrac mkError a = Proof (pure . toRealFrac) (const a)   where     toRealFrac str =       case readFloat str of-        [(f, [])] -> (Right f)-        _ -> (Left $ mkError str)+        [(f, [])] -> Right f+        _ -> Left $ mkError str  -- | read a signed 'RealFrac' number-realFracSigned :: (Monad m, RealFrac a) -  => (String -> error) +realFracSigned :: (Monad m, RealFrac a)+  => (String -> error)   -> a   -> Proof m error String a realFracSigned mkError a = Proof (pure . toRealFrac) (const a)   where     toRealFrac str =-      case (readSigned readFloat) str of-        [(f, [])] -> (Right f)-        _ -> (Left $ mkError str)+      case readSigned readFloat str of+        [(f, [])] -> Right f+        _ -> Left $ mkError str 

@@ -1,11 +1,13 @@-{-# LANGUAGE +{-# LANGUAGE     BangPatterns   , DeriveFoldable   , DeriveFunctor   , DeriveTraversable   , GeneralizedNewtypeDeriving-  , MultiParamTypeClasses +  , MultiParamTypeClasses   , OverloadedStrings+  , PatternSynonyms+  , ExplicitForAll #-}  -- | Types relevant to forms and their validation.@@ -19,15 +21,15 @@   , Value(..)   , View(..)   , Proved(..)-  , Result(..)+  , Result(.., Error, Ok)   ) where  import Control.Applicative (Alternative(..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.String (IsString(..)) import Data.Text (Text)-import Torsor import qualified Data.Text as T+import qualified Data.List.NonEmpty as NE  ------------------------------------------------------------------------------ -- FormId@@ -38,7 +40,7 @@   = FormId       {-# UNPACK #-} !Text           -- ^ Global prefix for the form       {-# UNPACK #-} !(NonEmpty Int) -- ^ Stack indicating field. Head is most specific to this item-  | FormIdName +  | FormIdName       {-# UNPACK #-} !Text -- ^ Local name of the input       {-# UNPACK #-} !Int  -- ^ Index of the input   deriving (Eq, Ord, Show)@@ -50,7 +52,8 @@ -- the name of the input / query string parameter encodeFormId :: FormId -> Text encodeFormId (FormId p xs) =-  p <> "-val-" <> (T.intercalate "." $ foldr (\a as -> T.pack (show a) : as) [] xs)+  let ids = fmap (T.pack . show) (NE.toList xs)+  in p <> "-val-" <> T.intercalate "." ids encodeFormId (FormIdName x _) = x  -- | get the head 'Int' from a 'FormId'@@ -58,11 +61,6 @@ formIdentifier (FormId _ (x :| _)) = x formIdentifier (FormIdName _ x) = x -instance Torsor FormId Int where-  add i (FormId p (x :| xs)) = FormId p $ (x + i) :| xs-  add i (FormIdName n x) = FormIdName n $ x + i -  difference a b = formIdentifier a - formIdentifier b- -- | A range of ID's to specify a group of forms data FormRange   = FormRange FormId FormId@@ -103,8 +101,8 @@  instance Semigroup a => Semigroup (Value a) where   Missing <> Missing = Missing-  Default <> Missing = Default   Missing <> Default = Default+  Default <> Missing = Default   Default <> Default = Default   Found x <> Found y = Found (x <> y)   Found x <> _ = Found x@@ -112,15 +110,14 @@  -- | Type for failing computations -- Similar to @Either@ but with an accumilating @Applicative@ instance-data Result e ok-  = Error [(FormRange, e)]-  | Ok ok-  deriving (Show, Eq, Functor, Foldable, Traversable)+newtype Result e ok = Result { getResult :: Either [(FormRange, e)] ok }+  deriving (Show, Eq, Functor, Foldable, Traversable, Monad) -instance Monad (Result e) where-  return = Ok-  Error x >>= _ = Error x-  Ok x >>= f = f x+pattern Error :: forall e ok. [(FormRange, e)] -> Result e ok+pattern Error e = Result (Left e)+pattern Ok :: forall e ok. ok -> Result e ok+pattern Ok ok = Result (Right ok)+{-# COMPLETE Error, Ok #-}  instance Applicative (Result e) where   pure = Ok