reform 0.2.0 → 0.2.1
raw patch · 3 files changed
+111/−4 lines, 3 files
Files
- Text/Reform/Core.hs +1/−0
- Text/Reform/Generalized.hs +109/−3
- reform.cabal +1/−1
Text/Reform/Core.hs view
@@ -24,6 +24,7 @@ , pos :: FormRange , unProved :: a }+ deriving Show instance Functor (Proved ()) where fmap f (Proved () pos a) = Proved () pos (f a)
Text/Reform/Generalized.hs view
@@ -5,6 +5,8 @@ module Text.Reform.Generalized where import Control.Applicative ((<$>))+import Control.Monad (foldM)+import Control.Monad.Trans (lift) import qualified Data.IntSet as IS import Data.List (find) import Data.Maybe (mapMaybe)@@ -171,7 +173,8 @@ augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool) augmentChoice (vl, (a, lbl, checked)) =- do i <- getFormId+ do incFormId+ i <- getFormId return (i, vl, lbl, checked) @@ -236,10 +239,113 @@ 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 i <- getFormId+ augmentChoice (vl, (_a, lbl,selected)) =+ do incFormId+ i <- getFormId return (i, vl, lbl, selected) ++-- | radio buttons, single @\<select\>@ boxes+inputChoiceForms :: forall a m error input lbl view proof. (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input) =>+ a+ -> [(Form m input error view proof a, lbl)] -- ^ value, label+ -> (FormId -> [(FormId, Int, FormId, view, lbl, Bool)] -> view) -- ^ function which generates the view+ -> Form m input error view proof 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 return an internal error?+ (Right str) = getInputString v :: Either error String -- FIXME+ key = readDec' str+ choices' <- augmentChoices $ markSelected key (zip [0..] choices)++ (choices'', mres) <-+ foldM (\(views, res) (fid, val, iview, frm, lbl, selected) -> do+ incFormId+ if selected+ then do (v, mres) <- unForm frm+ res' <- lift $ lift mres+ case res' of+ (Ok ok) -> do+ return (((fid, val, iview, unView v [], lbl, selected) : views), return res')+ (Error errs) -> do+ return (((fid, val, iview, unView v errs, lbl, selected) : views), return res')+ else do (v, _) <- unForm frm+ return ((fid, val, iview, unView v [], lbl, selected):views, res)+ ) ([], return $ Error [(unitRange i, commonFormError (InputMissing i))]) (choices')+ let view = mkView i (reverse choices'')+ return (View (const view), mres)++ where+ -- | Utility Function: turn a view and return value into a successful 'FormState'+ mkOk' :: (Monad m) =>+ FormId+ -> view+ -> a+ -> FormState m input (View error view, m (Result error (Proved proof a)))+ mkOk' i view val =+ return ( View $ const $ view+ , return $ Error []+ )++ selectFirst :: [(Form m input error view proof a, lbl)] -> [(Form m input error view proof a, lbl, Bool)]+ selectFirst ((frm, lbl):fs) = (frm,lbl,True) : map (\(frm',lbl') -> (frm', lbl', False)) fs++ markSelected :: Int -> [(Int, (Form m input error view proof a, lbl))] -> [(Form m input error view proof a, lbl, Bool)]+ markSelected n choices =+ map (\(i, (f, lbl)) -> (f, lbl, i == n)) choices++ viewSubForm :: (FormId, Int, FormId, Form m input error view proof a, lbl, Bool) -> FormState m input (FormId, Int, FormId, view, lbl, Bool)+ viewSubForm (fid, vl, iview, frm, lbl, selected) =+ do incFormId+ (v,_) <- unForm frm+ return (fid, vl, iview, unView v [], lbl, selected)++ augmentChoices :: (Monad m) => [(Form m input error view proof a, lbl, Bool)] -> FormState m input [(FormId, Int, FormId, Form m input error view proof a, lbl, Bool)]+ augmentChoices choices = mapM augmentChoice (zip [0..] choices)++ augmentChoice :: (Monad m) => (Int, (Form m input error view proof a, lbl, Bool)) -> FormState m input (FormId, Int, FormId, Form m input error view proof a, lbl, Bool)+ augmentChoice (vl, (frm, lbl, selected)) =+ do incFormId+ i <- getFormId+ incFormId+ iview <- getFormId+ return (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 return an internal error?+ (Right str) = getInputString v :: Either error 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 => (FormId -> view)
reform.cabal view
@@ -1,5 +1,5 @@ Name: reform-Version: 0.2.0+Version: 0.2.1 Synopsis: reform is an HTML form generation and validation library Description: reform follows in the footsteps of formlets and digestive-functors <= 0.2. It provides a