ditto 0.1.1.0 → 0.1.2.0
raw patch · 7 files changed
+533/−804 lines, 7 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Ditto.Proof: data Proof m error a b
+ Ditto.Proof: newtype Proof m error a b
- Ditto.Core: (++>) :: (Monad m, Monoid view) => Form m input error view () -> Form m input error view a -> Form m input error view a
+ Ditto.Core: (++>) :: (Monad m, Semigroup view) => Form m input error view () -> Form m input error view a -> Form m input error view a
- Ditto.Core: (<++) :: (Monad m, Monoid view) => Form m input error view a -> Form m input error view () -> Form m input error view a
+ Ditto.Core: (<++) :: (Monad m, Semigroup view) => Form m input error view a -> Form m input error view () -> Form m input error view a
- Ditto.Generalized.Named: input :: (Monad m, FormError err) => (input -> Either err a) -> (FormId -> a -> view) -> a -> String -> Form m input err view a
+ Ditto.Generalized.Named: input :: (Monad m, FormError err) => String -> (input -> Either err a) -> (FormId -> a -> view) -> a -> Form m input err view a
- Ditto.Generalized.Named: inputChoice :: forall a m err input lbl view. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m) => (a -> Bool) -> [(a, lbl)] -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -> String -> Form m input err view a
+ Ditto.Generalized.Named: inputChoice :: forall a m err input lbl view. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m) => String -> (a -> Bool) -> [(a, lbl)] -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -> Form m input err view a
- Ditto.Generalized.Named: inputChoiceForms :: forall a m err input lbl view. (Functor m, Monad m, FormError err, ErrorInputType err ~ input, FormInput input) => a -> [(Form m input err view a, lbl)] -> (FormId -> [(FormId, Int, FormId, view, lbl, Bool)] -> view) -> String -> Form m input err view a
+ Ditto.Generalized.Named: inputChoiceForms :: forall a m err input lbl view. (Functor m, Monad m, FormError err, ErrorInputType err ~ input, FormInput input) => String -> a -> [(Form m input err view a, lbl)] -> (FormId -> [(FormId, Int, FormId, view, lbl, Bool)] -> view) -> Form m input err view a
- Ditto.Generalized.Named: inputFile :: forall m input err view. (Monad m, FormInput input, FormError err, ErrorInputType err ~ input) => (FormId -> view) -> String -> Form m input err view (FileType input)
+ Ditto.Generalized.Named: inputFile :: forall m input err view. (Monad m, FormInput input, FormError err, ErrorInputType err ~ input) => String -> (FormId -> view) -> Form m input err view (FileType input)
- Ditto.Generalized.Named: inputMaybe :: (Monad m, FormError err) => (input -> Either err a) -> (FormId -> a -> view) -> a -> String -> Form m input err view (Maybe a)
+ Ditto.Generalized.Named: inputMaybe :: (Monad m, FormError err) => String -> (input -> Either err a) -> (FormId -> a -> view) -> a -> Form m input err view (Maybe a)
- Ditto.Generalized.Named: inputMulti :: forall m input err view a lbl. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m) => [(a, lbl)] -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -> (a -> Bool) -> String -> Form m input err view [a]
+ Ditto.Generalized.Named: inputMulti :: forall m input err view a lbl. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m) => String -> [(a, lbl)] -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -> (a -> Bool) -> Form m input err view [a]
- Ditto.Generalized.Named: inputNoData :: Monad m => (FormId -> a -> view) -> a -> String -> Form m input err view ()
+ Ditto.Generalized.Named: inputNoData :: Monad m => String -> (FormId -> a -> view) -> a -> Form m input err view ()
- Ditto.Generalized.Named: label :: Monad m => (FormId -> view) -> String -> Form m input err view ()
+ Ditto.Generalized.Named: label :: Monad m => String -> (FormId -> view) -> Form m input err view ()
Files
- ditto.cabal +8/−6
- src/Ditto/Backend.hs +0/−2
- src/Ditto/Core.hs +13/−13
- src/Ditto/Generalized.hs +13/−384
- src/Ditto/Generalized/Internal.hs +471/−0
- src/Ditto/Generalized/Named.hs +27/−398
- src/Ditto/Proof.hs +1/−1
ditto.cabal view
@@ -1,5 +1,5 @@ Name: ditto-Version: 0.1.1.0+Version: 0.1.2.0 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@@ -30,11 +30,13 @@ Ditto.Generalized.Named Ditto.Proof Ditto.Result+ other-modules:+ Ditto.Generalized.Internal 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+ base >= 4 && < 5+ , containers >= 0.4 && < 0.7+ , mtl >= 2.0 && < 2.3+ , semigroups >= 0.16 && < 0.20+ , text >= 0.11 && < 1.3 hs-source-dirs: src
src/Ditto/Backend.hs view
@@ -43,9 +43,7 @@ -- | A Class to lift a 'CommonFormError' into an application-specific error type class FormError e where- type ErrorInputType e- commonFormError :: (CommonFormError (ErrorInputType e)) -> e -- | Class which all backends should implement.
src/Ditto/Core.hs view
@@ -184,7 +184,7 @@ -- (Ok (Proved posi a)) -> pure (view1, pure $ Ok (Proved posi (f a))) -- (Error errs) -> pure (view1, pure $ Error errs) --- instance (Monoid view, Monad m) => Applicative (Form m input error view) where+-- instance (Semigroup view, Monad m) => Applicative (Form m input error view) where -- pure a = -- Form $ do -- i <- getFormId@@ -200,12 +200,12 @@ -- fok <- lift $ lift $ mfok -- aok <- lift $ lift $ maok -- case (fok, aok) of--- (Error errs1, Error errs2) -> pure (view1 `mappend` view2, pure $ Error $ errs1 ++ errs2)--- (Error errs1, _) -> pure (view1 `mappend` view2, pure $ Error $ errs1)--- (_, Error errs2) -> pure (view1 `mappend` view2, pure $ Error $ errs2)+-- (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 `mappend` view2+-- ( view1 <> view2 -- , pure $ Ok $ Proved -- { pos = FormRange x y -- , unProved = f a@@ -248,12 +248,12 @@ fok <- lift $ lift $ mfok aok <- lift $ lift $ maok case (fok, aok) of- (Error errs1, Error errs2) -> pure (view1 `mappend` view2, pure $ Error $ errs1 ++ errs2)- (Error errs1, _) -> pure (view1 `mappend` view2, pure $ Error $ errs1)- (_, Error errs2) -> pure (view1 `mappend` view2, pure $ Error $ errs2)+ (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 `mappend` view2+ ( view1 <> view2 , pure $ Ok $ Proved { pos = FormRange x y , unProved = f a@@ -353,7 +353,7 @@ -- for=\"someid\"\>@, which need to refer to the id of another -- element. (++>)- :: (Monad m, Monoid view)+ :: (Monad m, Semigroup view) => Form m input error view () -> Form m input error view a -> Form m input error view a@@ -362,14 +362,14 @@ -- Evaluate the form that matters first, so we have a correct range set (v2, r) <- unForm f2 (v1, _) <- unForm f1- pure (v1 `mappend` v2, r)+ pure (v1 <> v2, r) infixl 6 ++> -- | Append a unit form to the right. See '++>'. -- (<++)- :: (Monad m, Monoid view)+ :: (Monad m, Semigroup view) => Form m input error view a -> Form m input error view () -> Form m input error view a@@ -378,7 +378,7 @@ -- Evaluate the form that matters first, so we have a correct range set (v1, r) <- unForm f1 (v2, _) <- unForm f2- pure (v1 `mappend` v2, r)+ pure (v1 <> v2, r) infixr 5 <++
src/Ditto/Generalized.hs view
@@ -1,63 +1,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DoAndIfThenElse #-} -- This module provides helper functions for HTML input elements. These helper functions are not specific to any particular web framework or html library. module Ditto.Generalized where -import Control.Applicative ((<$>))-import Control.Monad (foldM)-import Control.Monad.Trans (lift)-import Data.Bifunctor-import Numeric (readDec) import Ditto.Backend import Ditto.Core import Ditto.Result-import qualified Data.IntSet as IS+import qualified Ditto.Generalized.Internal as G -- | used for constructing elements like @\<input type=\"text\"\>@, which pure a single input value.-input- :: (Monad m, FormError err)- => (input -> Either err a)- -> (FormId -> a -> view)- -> a- -> Form m input err view a-input fromInput toView initialValue =- Form $ do- i <- getFormId- v <- getFormInput' i- case v of- Default ->- pure- ( View $ const $ toView i initialValue- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = initialValue- }- )- )- Found x -> case fromInput x of - Right a -> pure- ( View $ const $ toView i 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))]- )+input :: (Monad m, FormError err) => (input -> Either err a) -> (FormId -> a -> view) -> a -> Form m input err view a+input = G.input getFormId -- | used for elements like @\<input type=\"submit\"\>@ which are not always present in the form submission data. inputMaybe@@ -66,46 +21,7 @@ -> (FormId -> a -> view) -> a -> Form m input err view (Maybe a)-inputMaybe fromInput toView initialValue =- Form $ do- i <- getFormId- v <- getFormInput' i- case v of- Default -> pure- ( View $ const $ toView i initialValue- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = Just initialValue- }- )- )- Found x -> case fromInput x of- Right a -> pure- ( View $ const $ toView i a- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = (Just a)- }- )- )- Left err -> pure- ( View $ const $ toView i initialValue- , pure $ Error [(unitRange i, err)]- )- Missing -> pure- ( View $ const $ toView i initialValue- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = Nothing- }- )- )+inputMaybe = G.inputMaybe getFormId -- | used for elements like @\<input type=\"reset\"\>@ which take a value, but are never present in the form data set. inputNoData@@ -113,59 +29,14 @@ => (FormId -> a -> view) -> a -> Form m input err view ()-inputNoData toView a =- Form $ do- i <- getFormId- pure- ( View $ const $ toView i a- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = ()- }- )- )+inputNoData = G.inputNoData getFormId -- | used for @\<input type=\"file\"\>@ inputFile :: forall m input err view. (Monad m, FormInput input, FormError err, ErrorInputType err ~ input) => (FormId -> view) -> Form m input err view (FileType input)-inputFile toView =- Form $ do- i <- getFormId- v <- getFormInput' i- case v of- Default ->- pure- ( View $ const $ toView i- , pure $ Error [(unitRange i, commonFormError (InputMissing i))]- )- Found x -> case getInputFile' x of- Right a -> pure- ( View $ const $ toView i- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = a- }- )- )- Left err -> pure- ( View $ const $ toView i- , pure $ Error [(unitRange i, err)]- )- Missing ->- pure- ( View $ const $ toView i- , pure $ Error [(unitRange i, commonFormError (InputMissing i))]- )- where- -- just here for the type-signature to make the type-checker happy- getInputFile' :: (FormError err, ErrorInputType err ~ input) => input -> Either err (FileType input)- getInputFile' = getInputFile+inputFile = G.inputFile getFormId -- | used for groups of checkboxes, @\<select multiple=\"multiple\"\>@ boxes inputMulti@@ -174,54 +45,7 @@ -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view -> (a -> Bool) -- ^ isChecked/isSelected initially -> Form m input err view [a]-inputMulti choices mkView isSelected =- Form $ do- i <- getFormId- inp <- getFormInput' i- case inp of- Default ->- do- let (choices', vals) =- foldr- ( \(a, lbl) (cs, vs) ->- if isSelected a- then ((a, lbl, True) : cs, a : vs)- else ((a, lbl, False) : cs, vs)- )- ([], [])- choices- view' <- mkView i <$> augmentChoices choices'- mkOk i view' vals- Missing ->- -- just means that no checkboxes were checked- do- view' <- mkView i <$> augmentChoices (map (\(x, y) -> (x, y, False)) choices)- mkOk i view' []- Found v -> do- let readDec' str = case readDec str of- [(n, [])] -> n- _ -> (-1) -- FIXME: should probably pure an internal err?- keys = IS.fromList $ map readDec' $ getInputStrings v- (choices', vals) =- foldr- ( \(i0, (a, lbl)) (c, v0) ->- if IS.member i0 keys- then ((a, lbl, True) : c, a : v0)- else ((a, lbl, False) : c, v0)- )- ([], []) $- zip [0..] choices- view' <- mkView i <$> augmentChoices choices'- mkOk i view' vals- where- augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]- augmentChoices choices' = mapM augmentChoice (zip [0..] choices')- augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)- augmentChoice (vl, (_, lbl, checked)) =- do- incFormId- i <- getFormId- pure (i, vl, lbl, checked)+inputMulti = G.inputMulti getFormId -- | radio buttons, single @\<select\>@ boxes inputChoice@@ -230,72 +54,7 @@ -> [(a, lbl)] -- ^ value, label -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view -> Form m input err view a-inputChoice isDefault choices mkView =- Form $ do- i <- getFormId- inp <- getFormInput' i- case inp of- Default ->- do- let (choices', def) = markSelected choices- view' <- mkView i <$> augmentChoices choices'- mkOk' i view' def- Missing ->- -- can happen if no choices where checked- do- let (choices', def) = markSelected choices- view' <- mkView i <$> augmentChoices choices'- mkOk' i view' def- Found v ->- do- let readDec' :: String -> Int- readDec' str' = case readDec str' of- [(n, [])] -> n- _ -> (-1) -- FIXME: should probably pure an internal err?- estr = getInputString v :: Either err String- key = second readDec' estr- (choices', mval) =- foldr- ( \(i0, (a, lbl)) (c, v0) ->- if either (const False) (==i0) key- then ((a, lbl, True) : c, Just a)- else ((a, lbl, False) : c, v0)- )- ([], Nothing) $- zip [0..] choices- view' <- mkView i <$> augmentChoices choices'- case mval of- Nothing ->- pure- ( View $ const view'- , pure $ Error [(unitRange i, commonFormError (InputMissing i))]- )- (Just val) -> mkOk i view' val- where- mkOk' i view' (Just val) = mkOk i view' val- mkOk' i view' Nothing =- pure- ( View $ const $ view'- , pure $ Error [(unitRange i, commonFormError MissingDefaultValue)]- )- markSelected :: [(a, lbl)] -> ([(a, lbl, Bool)], Maybe a)- markSelected cs =- foldr- ( \(a, lbl) (vs, ma) ->- if isDefault a- then ((a, lbl, True) : vs, Just a)- else ((a, lbl, False) : vs, ma)- )- ([], Nothing)- cs- augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]- augmentChoices choices' = mapM augmentChoice (zip [0..] choices')- augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)- augmentChoice (vl, (_a, lbl, selected)) =- do- incFormId- i <- getFormId- pure (i, vl, lbl, selected)+inputChoice = G.inputChoice getFormId -- | radio buttons, single @\<select\>@ boxes inputChoiceForms@@ -304,123 +63,14 @@ -> [(Form m input err view a, lbl)] -- ^ value, label -> (FormId -> [(FormId, Int, FormId, view, lbl, Bool)] -> view) -- ^ function which generates the view -> Form m input err view a-inputChoiceForms def choices mkView =- Form $ do- i <- getFormId -- id used for the 'name' attribute of the radio buttons- inp <- getFormInput' i- case inp of- Default ->- -- produce view for GET request- do- choices' <- mapM viewSubForm =<< augmentChoices (selectFirst choices)- let view' = mkView i choices'- mkOk' i view' def- Missing ->- -- shouldn't ever happen...- do- choices' <- mapM viewSubForm =<< augmentChoices (selectFirst choices)- let view' = mkView i choices'- mkOk' i view' def- (Found v) ->- do- let readDec' str' = case readDec str' of- [(n, [])] -> n- _ -> (-1) -- FIXME: should probably pure an internal err?- estr = getInputString v :: Either err String- key = second readDec' estr- choices' <- augmentChoices $ markSelected key (zip [0..] choices)- (choices'', mres) <-- foldM- ( \(views, res) (fid, val, iview, frm, lbl, selected) -> do- incFormId- if selected- then do- (v0, mres) <- unForm frm- res' <- lift $ lift mres- case res' of- Ok{} -> do- pure (((fid, val, iview, unView v0 [], lbl, selected) : views), pure res')- Error errs -> do- pure (((fid, val, iview, unView v0 errs, lbl, selected) : views), pure res')- else do- (v0, _) <- unForm frm- pure ((fid, val, iview, unView v0 [], lbl, selected) : views, res)- )- ([], pure $ Error [(unitRange i, commonFormError (InputMissing i))])- (choices')- let view' = mkView i (reverse choices'')- pure (View (const view'), mres)- where- -- | Utility Function: turn a view and pure value into a successful 'FormState'- mkOk'- :: (Monad m)- => FormId- -> view- -> a- -> FormState m input (View err view, m (Result err (Proved a)))- mkOk' _ view' _ =- pure- ( View $ const view'- , pure $ Error []- )- selectFirst :: [(Form m input err view a, lbl)] -> [(Form m input err view a, lbl, Bool)]- selectFirst ((frm, lbl) : fs) = (frm, lbl, True) : map (\(frm', lbl') -> (frm', lbl', False)) fs- selectFirst [] = []- markSelected :: Either e Int -> [(Int, (Form m input err view a, lbl))] -> [(Form m input err view a, lbl, Bool)]- markSelected en choices' =- map (\(i, (f, lbl)) -> (f, lbl, either (const False) (==i) en)) choices'- viewSubForm :: (FormId, Int, FormId, Form m input err view a, lbl, Bool) -> FormState m input (FormId, Int, FormId, view, lbl, Bool)- viewSubForm (fid, vl, iview, frm, lbl, selected) =- do- incFormId- (v, _) <- unForm frm- pure (fid, vl, iview, unView v [], lbl, selected)- augmentChoices :: (Monad m) => [(Form m input err view a, lbl, Bool)] -> FormState m input [(FormId, Int, FormId, Form m input err view a, lbl, Bool)]- augmentChoices choices' = mapM augmentChoice (zip [0..] choices')- augmentChoice :: (Monad m) => (Int, (Form m input err view a, lbl, Bool)) -> FormState m input (FormId, Int, FormId, Form m input err view a, lbl, Bool)- augmentChoice (vl, (frm, lbl, selected)) =- do- incFormId- i <- getFormId- incFormId- iview <- getFormId- pure (i, vl, iview, frm, lbl, selected)--{-- case inp of- (Found v) ->- do let readDec' str = case readDec str of- [(n,[])] -> n- _ -> (-1) -- FIXME: should probably pure an internal err?- (Right str) = getInputString v :: Either err String -- FIXME- key = readDec' str- (choices', mval) =- foldr (\(i, (a, lbl)) (c, v) ->- if i == key- then ((a,lbl,True) : c, Just a)- else ((a,lbl,False): c, v))- ([], Nothing) $- zip [0..] choices-+inputChoiceForms = G.inputChoiceForms getFormId --} -- | used to create @\<label\>@ elements label :: Monad m => (FormId -> view) -> Form m input err view ()-label f =- Form $ do- id' <- getFormId- pure- ( View (const $ f id')- , pure- ( Ok $ Proved- { pos = unitRange id'- , unProved = ()- }- )- )+label = G.label getFormId -- | used to add a list of err messages to a 'Form' --@@ -431,33 +81,12 @@ :: Monad m => ([err] -> view) -- ^ function to convert the err messages into a view -> Form m input err view ()-errors f =- Form $ do- range <- getFormRange- pure- ( View (f . retainErrors range)- , pure- ( Ok $ Proved- { pos = range- , unProved = ()- }- )- )+errors = G.errors -- | similar to 'errors' but includes err messages from children of the form as well. childErrors :: Monad m => ([err] -> view) -> Form m input err view ()-childErrors f =- Form $ do- range <- getFormRange- pure- ( View (f . retainChildErrors range)- , pure- ( Ok $ Proved- { pos = range- , unProved = ()- }- )- )+childErrors = G.childErrors+
+ src/Ditto/Generalized/Internal.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DoAndIfThenElse #-}++-- This module provides helper functions for HTML input elements. These helper functions are not specific to any particular web framework or html library.++module Ditto.Generalized.Internal where++import Control.Applicative ((<$>))+import Control.Monad (foldM)+import Control.Monad.Trans (lift)+import Data.Bifunctor+import Numeric (readDec)+import Ditto.Backend+import Ditto.Core+import Ditto.Result+import qualified Data.IntSet as IS++-- | used for constructing elements like @\<input type=\"text\"\>@, which pure a single input value.+input+ :: (Monad m, FormError err)+ => FormState m input FormId + -> (input -> Either err a)+ -> (FormId -> a -> view)+ -> a+ -> Form m input err view a+input i' fromInput toView initialValue =+ Form $ do+ i <- i'+ v <- getFormInput' i+ case v of+ Default ->+ pure+ ( View $ const $ toView i initialValue+ , pure $+ Ok+ ( Proved+ { pos = unitRange i+ , unProved = initialValue+ }+ )+ )+ Found x -> case fromInput x of + Right a -> pure+ ( View $ const $ toView i 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+ -> Form m input err view (Maybe a)+inputMaybe i' fromInput toView initialValue =+ Form $ do+ i <- i'+ v <- getFormInput' i+ case v of+ Default -> pure+ ( View $ const $ toView i initialValue+ , pure $+ Ok+ ( Proved+ { pos = unitRange i+ , unProved = Just initialValue+ }+ )+ )+ Found x -> case fromInput x of+ Right a -> pure+ ( View $ const $ toView i a+ , pure $+ Ok+ ( Proved+ { pos = unitRange i+ , unProved = (Just a)+ }+ )+ )+ Left err -> pure+ ( View $ const $ toView i initialValue+ , pure $ Error [(unitRange i, err)]+ )+ Missing -> pure+ ( View $ const $ toView i initialValue+ , pure $+ Ok+ ( Proved+ { pos = unitRange i+ , unProved = Nothing+ }+ )+ )++-- | used for elements like @\<input type=\"reset\"\>@ which take a value, but are never present in the form data set.+inputNoData+ :: (Monad m)+ => FormState m input FormId+ -> (FormId -> a -> view)+ -> a+ -> Form m input err view ()+inputNoData i' toView a =+ Form $ do+ i <- i'+ pure+ ( View $ const $ toView i a+ , pure $+ Ok+ ( Proved+ { pos = unitRange i+ , unProved = ()+ }+ )+ )++-- | used for @\<input type=\"file\"\>@+inputFile+ :: forall m input err view. (Monad m, FormInput input, FormError err, ErrorInputType err ~ input)+ => FormState m input FormId+ -> (FormId -> view)+ -> Form m input err view (FileType input)+inputFile i' toView =+ Form $ do+ i <- i'+ v <- getFormInput' i+ case v of+ Default ->+ pure+ ( View $ const $ toView i+ , pure $ Error [(unitRange i, commonFormError (InputMissing i))]+ )+ Found x -> case getInputFile' x of+ Right a -> pure+ ( View $ const $ toView i+ , pure $+ Ok+ ( Proved+ { pos = unitRange i+ , unProved = a+ }+ )+ )+ Left err -> pure+ ( View $ const $ toView i+ , pure $ Error [(unitRange i, err)]+ )+ Missing ->+ pure+ ( View $ const $ toView i+ , pure $ Error [(unitRange i, commonFormError (InputMissing i))]+ )+ where+ -- just here for the type-signature to make the type-checker happy+ getInputFile' :: (FormError err, ErrorInputType err ~ input) => input -> Either err (FileType input)+ getInputFile' = getInputFile++-- | 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)+ => FormState m input FormId+ -> [(a, lbl)] -- ^ value, label, initially checked+ -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view+ -> (a -> Bool) -- ^ isChecked/isSelected initially+ -> Form m input err view [a]+inputMulti i' choices mkView isSelected =+ Form $ do+ i <- i'+ inp <- getFormInput' i+ case inp of+ Default ->+ do+ let (choices', vals) =+ foldr+ ( \(a, lbl) (cs, vs) ->+ if isSelected a+ then ((a, lbl, True) : cs, a : vs)+ else ((a, lbl, False) : cs, vs)+ )+ ([], [])+ choices+ view' <- mkView i <$> augmentChoices choices'+ mkOk i view' vals+ Missing ->+ -- just means that no checkboxes were checked+ do+ view' <- mkView i <$> augmentChoices (map (\(x, y) -> (x, y, False)) choices)+ mkOk i view' []+ Found v -> do+ let readDec' str = case readDec str of+ [(n, [])] -> n+ _ -> (-1) -- FIXME: should probably pure an internal err?+ keys = IS.fromList $ map readDec' $ getInputStrings v+ (choices', vals) =+ foldr+ ( \(i0, (a, lbl)) (c, v0) ->+ if IS.member i0 keys+ then ((a, lbl, True) : c, a : v0)+ else ((a, lbl, False) : c, v0)+ )+ ([], []) $+ zip [0..] choices+ view' <- mkView i <$> augmentChoices choices'+ mkOk i view' vals+ where+ augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]+ augmentChoices choices' = mapM augmentChoice (zip [0..] choices')+ augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)+ augmentChoice (vl, (_, lbl, checked)) =+ do+ incFormId+ i <- i'+ pure (i, vl, lbl, checked)++-- | radio buttons, single @\<select\>@ boxes+inputChoice+ :: forall a m err input lbl view. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m)+ => FormState m input FormId+ -> (a -> Bool) -- ^ is default+ -> [(a, lbl)] -- ^ value, label+ -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view+ -> Form m input err view a+inputChoice i' isDefault choices mkView =+ Form $ do+ i <- i'+ inp <- getFormInput' i+ case inp of+ Default ->+ do+ let (choices', def) = markSelected choices+ view' <- mkView i <$> augmentChoices choices'+ mkOk' i view' def+ Missing ->+ -- can happen if no choices where checked+ do+ let (choices', def) = markSelected choices+ view' <- mkView i <$> augmentChoices choices'+ mkOk' i view' def+ Found v ->+ do+ let readDec' :: String -> Int+ readDec' str' = case readDec str' of+ [(n, [])] -> n+ _ -> (-1) -- FIXME: should probably pure an internal err?+ estr = getInputString v :: Either err String+ key = second readDec' estr+ (choices', mval) =+ foldr+ ( \(i0, (a, lbl)) (c, v0) ->+ if either (const False) (==i0) key+ then ((a, lbl, True) : c, Just a)+ else ((a, lbl, False) : c, v0)+ )+ ([], Nothing) $+ zip [0..] choices+ view' <- mkView i <$> augmentChoices choices'+ case mval of+ Nothing ->+ pure+ ( View $ const view'+ , pure $ Error [(unitRange i, commonFormError (InputMissing i))]+ )+ (Just val) -> mkOk i view' val+ where+ mkOk' i view' (Just val) = mkOk i view' val+ mkOk' i view' Nothing =+ pure+ ( View $ const $ view'+ , pure $ Error [(unitRange i, commonFormError MissingDefaultValue)]+ )+ markSelected :: [(a, lbl)] -> ([(a, lbl, Bool)], Maybe a)+ markSelected cs =+ foldr+ ( \(a, lbl) (vs, ma) ->+ if isDefault a+ then ((a, lbl, True) : vs, Just a)+ else ((a, lbl, False) : vs, ma)+ )+ ([], Nothing)+ cs+ augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]+ augmentChoices choices' = mapM augmentChoice (zip [0..] choices')+ augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)+ augmentChoice (vl, (_a, lbl, selected)) =+ do+ incFormId+ i <- i'+ pure (i, vl, lbl, selected)++-- | radio buttons, single @\<select\>@ boxes+inputChoiceForms+ :: forall a m err input lbl view. (Functor m, Monad m, FormError err, ErrorInputType err ~ input, FormInput input)+ => FormState m input FormId+ -> a+ -> [(Form m input err view a, lbl)] -- ^ value, label+ -> (FormId -> [(FormId, Int, FormId, view, lbl, Bool)] -> view) -- ^ function which generates the view+ -> Form m input err view a+inputChoiceForms i' def choices mkView =+ Form $ do+ i <- i' -- id used for the 'name' attribute of the radio buttons+ inp <- getFormInput' i+ case inp of+ Default ->+ -- produce view for GET request+ do+ choices' <- mapM viewSubForm =<< augmentChoices (selectFirst choices)+ let view' = mkView i choices'+ mkOk' i view' def+ Missing ->+ -- shouldn't ever happen...+ do+ choices' <- mapM viewSubForm =<< augmentChoices (selectFirst choices)+ let view' = mkView i choices'+ mkOk' i view' def+ (Found v) ->+ do+ let readDec' str' = case readDec str' of+ [(n, [])] -> n+ _ -> (-1) -- FIXME: should probably pure an internal err?+ estr = getInputString v :: Either err String+ key = second readDec' estr+ choices' <- augmentChoices $ markSelected key (zip [0..] choices)+ (choices'', mres) <-+ foldM+ ( \(views, res) (fid, val, iview, frm, lbl, selected) -> do+ incFormId+ if selected+ then do+ (v0, mres) <- unForm frm+ res' <- lift $ lift mres+ case res' of+ Ok{} -> do+ pure (((fid, val, iview, unView v0 [], lbl, selected) : views), pure res')+ Error errs -> do+ pure (((fid, val, iview, unView v0 errs, lbl, selected) : views), pure res')+ else do+ (v0, _) <- unForm frm+ pure ((fid, val, iview, unView v0 [], lbl, selected) : views, res)+ )+ ([], pure $ Error [(unitRange i, commonFormError (InputMissing i))])+ (choices')+ let view' = mkView i (reverse choices'')+ pure (View (const view'), mres)+ where+ -- | Utility Function: turn a view and pure value into a successful 'FormState'+ mkOk'+ :: (Monad m)+ => FormId+ -> view+ -> a+ -> FormState m input (View err view, m (Result err (Proved a)))+ mkOk' _ view' _ =+ pure+ ( View $ const view'+ , pure $ Error []+ )+ selectFirst :: [(Form m input err view a, lbl)] -> [(Form m input err view a, lbl, Bool)]+ selectFirst ((frm, lbl) : fs) = (frm, lbl, True) : map (\(frm', lbl') -> (frm', lbl', False)) fs+ selectFirst [] = []+ markSelected :: Either e Int -> [(Int, (Form m input err view a, lbl))] -> [(Form m input err view a, lbl, Bool)]+ markSelected en choices' =+ map (\(i, (f, lbl)) -> (f, lbl, either (const False) (==i) en)) choices'+ viewSubForm :: (FormId, Int, FormId, Form m input err view a, lbl, Bool) -> FormState m input (FormId, Int, FormId, view, lbl, Bool)+ viewSubForm (fid, vl, iview, frm, lbl, selected) =+ do+ incFormId+ (v, _) <- unForm frm+ pure (fid, vl, iview, unView v [], lbl, selected)+ augmentChoices :: (Monad m) => [(Form m input err view a, lbl, Bool)] -> FormState m input [(FormId, Int, FormId, Form m input err view a, lbl, Bool)]+ augmentChoices choices' = mapM augmentChoice (zip [0..] choices')+ augmentChoice :: (Monad m) => (Int, (Form m input err view a, lbl, Bool)) -> FormState m input (FormId, Int, FormId, Form m input err view a, lbl, Bool)+ augmentChoice (vl, (frm, lbl, selected)) =+ do+ incFormId+ i <- i'+ incFormId+ iview <- getFormId+ pure (i, vl, iview, frm, lbl, selected)++{-+ case inp of+ (Found v) ->+ do let readDec' str = case readDec str of+ [(n,[])] -> n+ _ -> (-1) -- FIXME: should probably pure an internal err?+ (Right str) = getInputString v :: Either err String -- FIXME+ key = readDec' str+ (choices', mval) =+ foldr (\(i, (a, lbl)) (c, v) ->+ if i == key+ then ((a,lbl,True) : c, Just a)+ else ((a,lbl,False): c, v))+ ([], Nothing) $+ zip [0..] choices+++-}+-- | used to create @\<label\>@ elements+label+ :: Monad m+ => FormState m input FormId+ -> (FormId -> view)+ -> Form m input err view ()+label i' f =+ Form $ do+ id' <- i'+ pure+ ( View (const $ f id')+ , pure+ ( Ok $ Proved+ { pos = unitRange id'+ , unProved = ()+ }+ )+ )++-- | used to add a list of err messages to a 'Form'+--+-- This function automatically takes care of extracting only the+-- errors that are relevent to the form element it is attached to via+-- '<++' or '++>'.+errors+ :: Monad m+ => ([err] -> view) -- ^ function to convert the err messages into a view+ -> Form m input err view ()+errors f =+ Form $ do+ range <- getFormRange+ pure+ ( View (f . retainErrors range)+ , pure+ ( Ok $ Proved+ { pos = range+ , unProved = ()+ }+ )+ )++-- | similar to 'errors' but includes err messages from children of the form as well.+childErrors+ :: Monad m+ => ([err] -> view)+ -> Form m input err view ()+childErrors f =+ Form $ do+ range <- getFormRange+ pure+ ( View (f . retainChildErrors range)+ , pure+ ( Ok $ Proved+ { pos = range+ , unProved = ()+ }+ )+ )
src/Ditto/Generalized/Named.hs view
@@ -6,429 +6,79 @@ module Ditto.Generalized.Named where -import Control.Applicative ((<$>))-import Control.Monad (foldM)-import Control.Monad.Trans (lift)-import Data.Bifunctor-import Numeric (readDec) import Ditto.Backend import Ditto.Core import Ditto.Result-import qualified Data.IntSet as IS+import qualified Ditto.Generalized.Internal as G -- | used for constructing elements like @\<input type=\"text\"\>@, which pure a single input value.-input- :: (Monad m, FormError err)- => (input -> Either err a)- -> (FormId -> a -> view)- -> a- -> String- -> Form m input err view a-input fromInput toView initialValue name =- Form $ do- i <- getNamedFormId name- v <- getFormInput' i- case v of- Default ->- pure- ( View $ const $ toView i initialValue- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = initialValue- }- )- )- Found x -> case fromInput x of - Right a -> pure- ( View $ const $ toView i 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))]- )+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 for elements like @\<input type=\"submit\"\>@ which are not always present in the form submission data. inputMaybe :: (Monad m, FormError err)- => (input -> Either err a)+ => String+ -> (input -> Either err a) -> (FormId -> a -> view) -> a- -> String -> Form m input err view (Maybe a)-inputMaybe fromInput toView initialValue name =- Form $ do- i <- getNamedFormId name- v <- getFormInput' i- case v of- Default -> pure- ( View $ const $ toView i initialValue- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = Just initialValue- }- )- )- Found x -> case fromInput x of- Right a -> pure- ( View $ const $ toView i a- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = (Just a)- }- )- )- Left err -> pure- ( View $ const $ toView i initialValue- , pure $ Error [(unitRange i, err)]- )- Missing -> pure- ( View $ const $ toView i initialValue- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = Nothing- }- )- )+inputMaybe name = G.inputMaybe (getNamedFormId name) -- | 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)+ => String+ -> (FormId -> a -> view) -> a- -> String -> Form m input err view ()-inputNoData toView a name =- Form $ do- i <- getNamedFormId name- pure- ( View $ const $ toView i a- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = ()- }- )- )+inputNoData name = G.inputNoData (getNamedFormId name) -- | used for @\<input type=\"file\"\>@ inputFile :: forall m input err view. (Monad m, FormInput input, FormError err, ErrorInputType err ~ input)- => (FormId -> view)- -> String+ => String+ -> (FormId -> view) -> Form m input err view (FileType input)-inputFile toView name =- Form $ do- i <- getNamedFormId name- v <- getFormInput' i- case v of- Default ->- pure- ( View $ const $ toView i- , pure $ Error [(unitRange i, commonFormError (InputMissing i))]- )- Found x -> case getInputFile' x of- Right a -> pure- ( View $ const $ toView i- , pure $- Ok- ( Proved- { pos = unitRange i- , unProved = a- }- )- )- Left err -> pure- ( View $ const $ toView i- , pure $ Error [(unitRange i, err)]- )- Missing ->- pure- ( View $ const $ toView i- , pure $ Error [(unitRange i, commonFormError (InputMissing i))]- )- where- -- just here for the type-signature to make the type-checker happy- getInputFile' :: (FormError err, ErrorInputType err ~ input) => input -> Either err (FileType input)- getInputFile' = getInputFile+inputFile name = G.inputFile (getNamedFormId name) -- | 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)- => [(a, lbl)] -- ^ value, label, initially checked+ => String+ -> [(a, lbl)] -- ^ value, label, initially checked -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view -> (a -> Bool) -- ^ isChecked/isSelected initially- -> String -> Form m input err view [a]-inputMulti choices mkView isSelected name =- Form $ do- i <- getNamedFormId name- inp <- getFormInput' i- case inp of- Default ->- do- let (choices', vals) =- foldr- ( \(a, lbl) (cs, vs) ->- if isSelected a- then ((a, lbl, True) : cs, a : vs)- else ((a, lbl, False) : cs, vs)- )- ([], [])- choices- view' <- mkView i <$> augmentChoices choices'- mkOk i view' vals- Missing ->- -- just means that no checkboxes were checked- do- view' <- mkView i <$> augmentChoices (map (\(x, y) -> (x, y, False)) choices)- mkOk i view' []- Found v -> do- let readDec' str = case readDec str of- [(n, [])] -> n- _ -> (-1) -- FIXME: should probably pure an internal err?- keys = IS.fromList $ map readDec' $ getInputStrings v- (choices', vals) =- foldr- ( \(i0, (a, lbl)) (c, v0) ->- if IS.member i0 keys- then ((a, lbl, True) : c, a : v0)- else ((a, lbl, False) : c, v0)- )- ([], []) $- zip [0..] choices- view' <- mkView i <$> augmentChoices choices'- mkOk i view' vals- where- augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]- augmentChoices choices' = mapM augmentChoice (zip [0..] choices')- augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)- augmentChoice (vl, (_, lbl, checked)) =- do- incFormId- i <- getNamedFormId name- pure (i, vl, lbl, checked)+inputMulti name = G.inputMulti (getNamedFormId name) -- | radio buttons, single @\<select\>@ boxes inputChoice :: forall a m err input lbl view. (Functor m, FormError err, ErrorInputType err ~ input, FormInput input, Monad m)- => (a -> Bool) -- ^ is default+ => String+ -> (a -> Bool) -- ^ is default -> [(a, lbl)] -- ^ value, label -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view- -> String -> Form m input err view a-inputChoice isDefault choices mkView name =- Form $ do- i <- getNamedFormId name- inp <- getFormInput' i- case inp of- Default ->- do- let (choices', def) = markSelected choices- view' <- mkView i <$> augmentChoices choices'- mkOk' i view' def- Missing ->- -- can happen if no choices where checked- do- let (choices', def) = markSelected choices- view' <- mkView i <$> augmentChoices choices'- mkOk' i view' def- Found v ->- do- let readDec' :: String -> Int- readDec' str' = case readDec str' of- [(n, [])] -> n- _ -> (-1) -- FIXME: should probably pure an internal err?- estr = getInputString v :: Either err String- key = second readDec' estr- (choices', mval) =- foldr- ( \(i0, (a, lbl)) (c, v0) ->- if either (const False) (==i0) key- then ((a, lbl, True) : c, Just a)- else ((a, lbl, False) : c, v0)- )- ([], Nothing) $- zip [0..] choices- view' <- mkView i <$> augmentChoices choices'- case mval of- Nothing ->- pure- ( View $ const view'- , pure $ Error [(unitRange i, commonFormError (InputMissing i))]- )- (Just val) -> mkOk i view' val- where- mkOk' i view' (Just val) = mkOk i view' val- mkOk' i view' Nothing =- pure- ( View $ const $ view'- , pure $ Error [(unitRange i, commonFormError MissingDefaultValue)]- )- markSelected :: [(a, lbl)] -> ([(a, lbl, Bool)], Maybe a)- markSelected cs =- foldr- ( \(a, lbl) (vs, ma) ->- if isDefault a- then ((a, lbl, True) : vs, Just a)- else ((a, lbl, False) : vs, ma)- )- ([], Nothing)- cs- augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]- augmentChoices choices' = mapM augmentChoice (zip [0..] choices')- augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)- augmentChoice (vl, (_a, lbl, selected)) =- do- incFormId- i <- getNamedFormId name- pure (i, vl, lbl, selected)+inputChoice name = G.inputChoice (getNamedFormId name) -- | radio buttons, single @\<select\>@ boxes inputChoiceForms :: forall a m err input lbl view. (Functor m, Monad m, FormError err, ErrorInputType err ~ input, FormInput input)- => a+ => String+ -> a -> [(Form m input err view a, lbl)] -- ^ value, label -> (FormId -> [(FormId, Int, FormId, view, lbl, Bool)] -> view) -- ^ function which generates the view- -> String -> Form m input err view a-inputChoiceForms def choices mkView name =- Form $ do- i <- getNamedFormId name -- id used for the 'name' attribute of the radio buttons- inp <- getFormInput' i- case inp of- Default ->- -- produce view for GET request- do- choices' <- mapM viewSubForm =<< augmentChoices (selectFirst choices)- let view' = mkView i choices'- mkOk' i view' def- Missing ->- -- shouldn't ever happen...- do- choices' <- mapM viewSubForm =<< augmentChoices (selectFirst choices)- let view' = mkView i choices'- mkOk' i view' def- (Found v) ->- do- let readDec' str' = case readDec str' of- [(n, [])] -> n- _ -> (-1) -- FIXME: should probably pure an internal err?- estr = getInputString v :: Either err String- key = second readDec' estr- choices' <- augmentChoices $ markSelected key (zip [0..] choices)- (choices'', mres) <-- foldM- ( \(views, res) (fid, val, iview, frm, lbl, selected) -> do- incFormId- if selected- then do- (v0, mres) <- unForm frm- res' <- lift $ lift mres- case res' of- Ok{} -> do- pure (((fid, val, iview, unView v0 [], lbl, selected) : views), pure res')- Error errs -> do- pure (((fid, val, iview, unView v0 errs, lbl, selected) : views), pure res')- else do- (v0, _) <- unForm frm- pure ((fid, val, iview, unView v0 [], lbl, selected) : views, res)- )- ([], pure $ Error [(unitRange i, commonFormError (InputMissing i))])- (choices')- let view' = mkView i (reverse choices'')- pure (View (const view'), mres)- where- -- | Utility Function: turn a view and pure value into a successful 'FormState'- mkOk'- :: (Monad m)- => FormId- -> view- -> a- -> FormState m input (View err view, m (Result err (Proved a)))- mkOk' _ view' _ =- pure- ( View $ const view'- , pure $ Error []- )- selectFirst :: [(Form m input err view a, lbl)] -> [(Form m input err view a, lbl, Bool)]- selectFirst ((frm, lbl) : fs) = (frm, lbl, True) : map (\(frm', lbl') -> (frm', lbl', False)) fs- selectFirst [] = []- markSelected :: Either e Int -> [(Int, (Form m input err view a, lbl))] -> [(Form m input err view a, lbl, Bool)]- markSelected en choices' =- map (\(i, (f, lbl)) -> (f, lbl, either (const False) (==i) en)) choices'- viewSubForm :: (FormId, Int, FormId, Form m input err view a, lbl, Bool) -> FormState m input (FormId, Int, FormId, view, lbl, Bool)- viewSubForm (fid, vl, iview, frm, lbl, selected) =- do- incFormId- (v, _) <- unForm frm- pure (fid, vl, iview, unView v [], lbl, selected)- augmentChoices :: (Monad m) => [(Form m input err view a, lbl, Bool)] -> FormState m input [(FormId, Int, FormId, Form m input err view a, lbl, Bool)]- augmentChoices choices' = mapM augmentChoice (zip [0..] choices')- augmentChoice :: (Monad m) => (Int, (Form m input err view a, lbl, Bool)) -> FormState m input (FormId, Int, FormId, Form m input err view a, lbl, Bool)- augmentChoice (vl, (frm, lbl, selected)) =- do- incFormId- i <- getNamedFormId name- incFormId- iview <- getFormId- pure (i, vl, iview, frm, lbl, selected)--{-- case inp of- (Found v) ->- do let readDec' str = case readDec str of- [(n,[])] -> n- _ -> (-1) -- FIXME: should probably pure an internal err?- (Right str) = getInputString v :: Either err String -- FIXME- key = readDec' str- (choices', mval) =- foldr (\(i, (a, lbl)) (c, v) ->- if i == key- then ((a,lbl,True) : c, Just a)- else ((a,lbl,False): c, v))- ([], Nothing) $- zip [0..] choices-+inputChoiceForms name = G.inputChoiceForms (getNamedFormId name) --} -- | used to create @\<label\>@ elements label :: Monad m- => (FormId -> view)- -> String+ => String+ -> (FormId -> view) -> Form m input err view ()-label f name =- Form $ do- id' <- getNamedFormId name- pure- ( View (const $ f id')- , pure- ( Ok $ Proved- { pos = unitRange id'- , unProved = ()- }- )- )+label name = G.label (getNamedFormId name) -- | used to add a list of err messages to a 'Form' --@@ -439,33 +89,12 @@ :: Monad m => ([err] -> view) -- ^ function to convert the err messages into a view -> Form m input err view ()-errors f =- Form $ do- range <- getFormRange- pure- ( View (f . retainErrors range)- , pure- ( Ok $ Proved- { pos = range- , unProved = ()- }- )- )+errors = G.errors -- | similar to 'errors' but includes err messages from children of the form as well. childErrors :: Monad m => ([err] -> view) -> Form m input err view ()-childErrors f =- Form $ do- range <- getFormRange- pure- ( View (f . retainChildErrors range)- , pure- ( Ok $ Proved- { pos = range- , unProved = ()- }- )- )+childErrors = G.childErrors+
src/Ditto/Proof.hs view
@@ -23,7 +23,7 @@ -- which names the proof, such as: -- ---data Proof m error a b = Proof+newtype Proof m error a b = Proof { proofFunction :: a -> m (Either error b) -- ^ function which provides the proof }