digestive-functors 0.0.2.1 → 0.1.0.0

raw patch · 7 files changed

+316/−104 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• digestive-functors.cabal +1/−1
• src/Text/Digestive/Cli.hs +153/−73
• src/Text/Digestive/Forms.hs +79/−10
• src/Text/Digestive/Forms/Html.hs +3/−0
• src/Text/Digestive/Result.hs +37/−6
• src/Text/Digestive/Transform.hs +11/−0
• src/Text/Digestive/Types.hs +32/−14

@@ -1,5 +1,5 @@ Name:                digestive-functors-Version:             0.0.2.1+Version:             0.1.0.0 Synopsis:            A general way to consume input using applicative functors Description:         Digestive functors is a library to generate and process     HTML forms.  You can find an introduction here:

@@ -3,114 +3,194 @@ -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Text.Digestive.Cli-    ( Descriptions (..)-    , Prompt+    ( Prompt     , prompt+    , promptList     , promptRead     , runPrompt     ) where -import Data.Map (Map)-import qualified Data.Map as M-import Data.Monoid (Monoid, mempty, mappend)+import Data.Monoid (Monoid, mappend, mempty) import Control.Applicative ((<$>))  import Text.Digestive.Result import Text.Digestive.Types import Text.Digestive.Transform-import qualified Text.Digestive.Common as Common+import Text.Digestive.Forms (inputList) --- | A list of descriptions for a certain input prompt+-- A representation of an element in the structure used to gather inputs+-- from the user. ---newtype Descriptions = Descriptions-    { unDescriptions :: Map FormId [String]-    } deriving (Show)--instance Monoid Descriptions where-    mempty = Descriptions mempty-    mappend (Descriptions m1) (Descriptions m2) =-        Descriptions $ M.unionWith (++) m1 m2+data FieldItem+  -- A tangible item that the user is prompted for.+  = FieldItemSingle     FormId String [String]+  -- A delimter marking the start of a series of prompts to be entered+  -- multiple times.+  | FieldItemMultiStart FormId String [String]+  -- A delimiter marking the end of a multiple input prompt.+  | FieldItemMultiEnd+    deriving (Show) --- | Type for a prompt+-- The structure of a prompt, built up as a View. ---type Prompt a = Form IO String String Descriptions a+newtype PromptView = PromptView+    { unPromptView :: [FieldItem]+    } deriving (Show, Monoid) --- | Remove the descriptions for the inputs already in the input map.+-- | Type for a prompt ---neededDescriptions :: InputMap -> Descriptions -> Descriptions-neededDescriptions (InputMap inputMap) =-    Descriptions . M.filterWithKey notInInput . unDescriptions-  where-    notInInput k _ = k `notElem` map fst inputMap+type Prompt a = Form IO String String PromptView a --- | Add errors to the descriptions+-- An association list of FormIds and their inputs gathered by prompting the+-- user. ---addErrors :: [(FormRange, String)] -> Descriptions -> Descriptions-addErrors errors (Descriptions descr) = Descriptions $ foldl add' descr errors-  where-    add' map' ((FormRange x _, e)) = M.insertWith (++) x [e] map'- newtype InputMap = InputMap     { unInputMap :: [(FormId, String)]     } deriving (Show, Monoid) --- | Create an environment from an input map+-- Create an environment from an input map -- inputMapEnvironment :: Monad m => InputMap -> Environment m String inputMapEnvironment map' = Environment $ return . flip lookup (unInputMap map') --- | Prompt once for a needed field. Return (key, value)----promptOnce :: Descriptions -> IO (FormId, String)-promptOnce (Descriptions descr)-    | M.null descr = error "No descriptions!"-    | otherwise = do putStrLn ""-                     mapM_ putStrLn description-                     putStr "> "-                     (,) key <$> getLine-  where-    (key, description) = M.findMin descr---- | Remove all input for which errors are found+-- | Generate a prompt field for a String ---removeInvalidInput :: InputMap -> [(FormRange, String)] -> InputMap-removeInvalidInput = foldl removeInvalidInput'-  where-    removeInvalidInput' :: InputMap -> (FormRange, String) -> InputMap-    removeInvalidInput' (InputMap map') (range, _) =-        InputMap $ filter (not . flip isInRange range . fst) map'+prompt :: String        -- ^ Description+       -> Prompt String -- ^ Resulting prompt+prompt descr = Form $ do+    id' <- getFormId+    inp <- getFormInput+    range <- getFormRange+    let v :: [(FormRange, String)] -> PromptView+        v errs = PromptView [FieldItemSingle id' descr matching]+          where+            -- Only errors which apply specifically to this item+            matching = retainErrors range errs+        result = case inp of+            Just x  -> Ok x+            Nothing -> Error [(range, "No input")]+    return (View v, result) --- | Generate a prompt field from a description+-- | Convert a prompt for a single item into a prompt for multiple items ---prompt :: String -> Prompt String-prompt descr = Common.input (const $ const $ const [])-                            toResult-                            (\x _ -> Descriptions $ M.singleton x [descr])-                            ""+promptList :: String     -- ^ Description of resulting multi-prompt+           -> Prompt a   -- ^ Prompt to convert+           -> Prompt [a] -- ^ Resulting multiple input prompt+promptList descr prmpt = Form $ do+    id'     <- getFormId+    (v, r1) <- unForm $ inputList numPrompt (const prmpt) Nothing+    range   <- getFormRange+    -- The monoid for the view will look like this: [vstart, v, vend]+    -- 'vstart' and 'vend' delimit the beginning and end of the inputs that+    -- are converted into repeatable inputs. When we are prompting the user to+    -- fill out the form, we use these delimiters to control the behavior of+    -- the prompts. Anything between them will be treated as repeatable. The+    -- 'vstart' item (FieldItemMultiStart) also contains the FormId of the+    -- field used to count the number of entries, as well as an additional+    -- description of of the multiple input itself (for example, 'Users', when+    -- the contained items are used to enter in a single User.)+    let vstart errs = PromptView [item]+          where+            item = FieldItemMultiStart id' descr $ retainErrors range errs+        vend _ = PromptView [FieldItemMultiEnd]+    return (View vstart `mappend` v `mappend` View vend, r1)   where-    toResult Nothing = Error []-    toResult (Just x) = Ok x+    numPrompt _ = Form $ do+                    inp <- getFormInput+                    return (mempty, readN inp)+    readN (Just x) = Ok (read x)+    readN Nothing = Error []  -- | Generate a prompt field for a value which can be read -- promptRead :: Read a-           => String    -- ^ Error when the value can't be read-           -> String    -- ^ Description-           -> Prompt a  -- ^ Resulting prompt+           => String   -- ^ Error when the value can't be read+           -> String   -- ^ Description+           -> Prompt a -- ^ Resulting prompt promptRead error' descr = prompt descr `transform` transformRead error' --- | Run a prompt. This will repeatedly prompt for input until we have a valid--- result.+-- Get a single line of text from the user ---runPrompt :: Prompt a -> IO a-runPrompt form = prompt' mempty+cliInput :: IO String+cliInput = putStr "> " >> getLine++-- Get the input for a list of prompt items that have been defined.+--+-- Notably, this supports nested 'mass input' forms (inputList/promptList)+-- which are delimited by FieldItemMultiStart and FieldItemMultiEnd.+-- FieldItemMultiSingle represents a tangible item to prompt for. If a+-- FieldItemMultiStart is reached, we need to prompt for all of the items+-- until the next FieldItemMultiEnd an arbitrary number of times.+--+inputForItems :: [FieldItem]+              -- ^ Items to get input for+              -> [(FormId, String)]+              -- ^ Accumulated association list of inputs we've prompted for+              -> (FormId -> FormId)+              -- ^ A function to transform the FormId of this item. Used to+              -- change the index of the item when prompting multiple times.+              -> IO ([FieldItem], [(FormId, String)])+              -- ^ A pair of the remaining items (empty if we are not+              -- returning from a multiple input item) and accumulated inputs, +inputForItems [] accum _fid = return ([], accum)++inputForItems (FieldItemMultiEnd : rest) accum _fid = return (rest, accum)++-- The simple case for a single item.+inputForItems (FieldItemSingle id' descr _errs : rest) accum fid = do+    putStrLn descr+    val <- cliInput+    inputForItems rest ((fid id', val) : accum) fid++-- The case for a multiple input prompt.+inputForItems (FieldItemMultiStart id' descr _errs : rest) accum fid = do+    let id'' = fid id'+    putStrLn $ "How many '" ++ descr ++ "' do you want to input?"+    -- Leave this as a string, since we must put it into a hidden form field+    -- for inputList, which must read it again. We only prompt for it here+    -- instead of as a discrete form item because we want to know, right now,+    -- how many the user wants to input.+    nStr <- cliInput+    -- Prompt for all of the delimited items, and put them at index i for this+    -- multi-input item.+    -- TODO use foldM+    let f i = do putStrLn $ descr ++ " #" ++ show (i + 1) ++ ":"+                 inputForItems rest [] (modifyId id'' i)+    delimited <- mapM f [0..(read nStr - 1)]+    let rest' = fst $ last delimited+        countfield = (id'', nStr)+    inputForItems rest' ([countfield] ++ accum ++ concatMap snd delimited) fid++-- Construct a function to transform the 'children' (delimited items) of a+-- mass input item to the correct index.+--+modifyId :: FormId -> Integer -> FormId -> FormId+modifyId parent i = mapId (\x -> head x : i : formIdList parent)++-- | Run a Prompt, sequentially prompting the user for each item.+--+runPrompt :: Prompt a+          -- ^ The Prompt to run+          -> IO (Either [String] a)+          -- ^ A list of error strings, or the result.+runPrompt prmpt = do+    prmptv <- viewForm prmpt "form"+    inpmap <- InputMap . snd <$> inputForItems (unPromptView prmptv) [] id+    eith   <- eitherForm prmpt "form" (inputMapEnvironment inpmap)+    return $ case eith of+        Left v  -> Left (fieldItemErrors `concatMap` unPromptView v)+        Right x -> Right x++-- Read the errors from a FieldItem, if any.+--+fieldItemErrors :: FieldItem -> [String]+fieldItemErrors (FieldItemSingle id' descr errs) =+    descriptiveErrors id' descr errs+fieldItemErrors (FieldItemMultiStart id' descr errs) = -- TODO bad+    descriptiveErrors id' descr errs+fieldItemErrors FieldItemMultiEnd = []++descriptiveErrors :: FormId -> String -> [String] -> [String]+descriptiveErrors id' descr errs = map str errs   where-    prompt' inputMap = do-        (v, r) <- runForm form "form" $ inputMapEnvironment inputMap-        case r of-            Ok x -> return x-            Error e -> do let inputMap' = removeInvalidInput inputMap e-                              descr = addErrors e-                                    $ neededDescriptions inputMap' (unView v [])-                          input' <- promptOnce descr-                          prompt' $ inputMap' `mappend` InputMap [input']+    str err = "(" ++ show id' ++ ") " ++ descr ++ ": " ++ err

@@ -1,4 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,+             NoMonomorphismRestriction #-} module Text.Digestive.Forms     ( FormInput (..)     , inputString@@ -6,12 +7,14 @@     , inputBool     , inputChoice     , inputFile+    , inputList     ) where  import Control.Applicative ((<$>)) import Control.Monad (mplus)-import Data.Monoid (Monoid, mconcat)-import Data.Maybe (fromMaybe)+import Control.Monad.State (put, get)+import Data.Monoid (Monoid, mappend, mconcat)+import Data.Maybe (fromMaybe, listToMaybe)  import Data.Text (Text) import qualified Data.Text as T (pack)@@ -29,13 +32,22 @@     -- among other things     --     getInputString :: i -> Maybe String+    getInputString = listToMaybe . getInputStrings -    -- | Parse the input value into 'Text'. The default implementation uses-    -- 'T.pack . getInputString', a more efficient version may be implemented.+    -- | Should be implemented     --+    getInputStrings :: i -> [String]++    -- | Parse the input value into 'Text'+    --     getInputText :: i -> Maybe Text-    getInputText = fmap T.pack . getInputString+    getInputText = listToMaybe . getInputTexts +    -- | Can be overriden for efficiency concerns+    --+    getInputTexts :: i -> [Text]+    getInputTexts = map T.pack . getInputStrings+     -- | Get a file descriptor for an uploaded file     --     getInputFile :: i -> Maybe f@@ -46,7 +58,7 @@             -> Form m i e v String            -- ^ Resulting form inputString = input toView toResult   where-    toView _ inp defaultInput = (getInputString =<< inp) `mplus` defaultInput+    toView _ inp def = (getInputString =<< inp) `mplus` def     toResult = Ok . fromMaybe "" . (getInputString =<<)  inputRead :: (Monad m, Functor m, FormInput i f, Read a, Show a)@@ -63,11 +75,12 @@           -> Form m i e v Bool       -- ^ Resulting form inputBool = input toView toResult   where-    toView isInput inp def = if isInput then readBool (getInputString =<< inp)-                                        else def+    toView isInput inp def+        | isInput   = readBool (getInputString =<< inp)+        | otherwise = def     toResult inp = Ok $ readBool (getInputString =<< inp)     readBool (Just x) = not $ null x-    readBool Nothing  = False+    readBool _        = False  inputChoice :: (Monad m, Functor m, FormInput i f, Monoid v, Eq a)             => (FormId -> String -> Bool -> a -> v)  -- ^ Choice constructor@@ -94,3 +107,59 @@     toView _ _ _ = ()     toResult inp = Ok $ getInputFile =<< inp     viewCons' id' () = viewCons id'++up :: Monad m => Int -> FormState m i ()+up n = do+    FormRange s _ <- get+    put $ unitRange $ mapId ((!!n) . iterate tail) s++down :: Monad m => Int -> FormState m i ()+down n = do+    FormRange s _ <- get+    put $ unitRange $ mapId ((!!n) . iterate (0:)) s++-- | Converts a formlet representing a single item into a formlet representing a+-- dynamically sized list of those items.  It requires that the user specify a+-- formlet to hold the length of the list.  Typically this will be a hidden+-- field that is automatically updated by client-side javascript.+--+-- The field names must be generated as follows.  Assume that if inputList had+-- not been used, the field name would have been prefix-f5.  In this case, the+-- list length field name will be prefix-f5.  The first item in the list will+-- receive field names starting at prefix-f5.0.0.  If each item is a composed+-- form with two fields, those fields will have the names prefix-f5.0.0 and+-- prefix-f5.0.1.  The field names for the second item will be prefix-f5.1.0+-- and prefix-f5.1.1.+--+inputList :: (Monad m, Monoid v)+          => Formlet m i e v Int  -- ^ A formlet for the list length+          -> Formlet m i e v a    -- ^ The formlet for a single list element+          -> Formlet m i e v [a]  -- ^ The dynamic list formlet+inputList countField single defaults = Form $ do+    let defCount = maybe 1 length defaults+    (countView,countRes) <- unForm $ countField (Just defCount)+    let countFromForm = getResult countRes+        count = fromMaybe defCount countFromForm+        fs = replicate count single+        forms = zipWith ($) fs $ maybe (maybe [Nothing] (map Just) defaults)+                                       (flip replicate Nothing)+                                       countFromForm+    down 2+    list <- mapM (incAfter . unForm) forms+    up 2+    return ( countView `mappend` (mconcat $ map fst list)+           , combineResults [] [] $ map snd list)+  where+    incAfter k = do+        res <- k+        up 1 >> incState >> down 1+        return res++    combineResults es os [] =+        case es of+            [] -> Ok $ reverse os+            _  -> Error es+    combineResults es os (r:rs) =+        case r of+            Error es' -> combineResults (es ++ es') os rs+            Ok o      -> combineResults es (o:os) rs

@@ -57,6 +57,9 @@     mappend (FormHtml x f) (FormHtml y g) =         FormHtml (x `mappend` y) $ f `mappend` g +instance Functor FormHtml where+    fmap f (FormHtml e g) = FormHtml e (f . g)+ -- | Create form HTML with the default encoding type -- createFormHtml :: (FormHtmlConfig -> a) -> FormHtml a

@@ -2,9 +2,14 @@ -- module Text.Digestive.Result     ( Result (..)-    , FormId (..)+    , getResult+    , FormId+    , zeroId+    , mapId+    , formIdList     , FormRange (..)     , incrementFormId+    , unitRange     , isInRange     , isSubRange     , retainErrors@@ -12,6 +17,7 @@     ) where  import Control.Applicative (Applicative (..))+import Data.List (intercalate)  -- | Type for failing computations --@@ -35,16 +41,37 @@     Ok _ <*> Error y = Error y     Ok x <*> Ok y = Ok $ x y +getResult :: Result e ok -> Maybe ok+getResult (Error _) = Nothing+getResult (Ok r) = Just r+ -- | An ID used to identify forms -- data FormId = FormId-    { formPrefix :: String-    , formId     :: Integer+    { -- | Global prefix for the form+      formPrefix :: String+    , -- | Stack indicating field. Head is most specific to this item+      formIdList :: [Integer]     } deriving (Eq, Ord) +-- | The zero ID, i.e. the first ID that is usable+--+zeroId :: String -> FormId+zeroId p = FormId+    { formPrefix = p+    , formIdList = [0]+    }++mapId :: ([Integer] -> [Integer]) -> FormId -> FormId+mapId f (FormId p is) = FormId p $ f is+ instance Show FormId where-    show (FormId p x) = p ++ "-f" ++ show x+    show (FormId p xs) =+        p ++ "-fval[" ++ (intercalate "." $ reverse $ map show xs) ++ "]" +formId :: FormId -> Integer+formId = head . formIdList+ -- | A range of ID's to specify a group of forms -- data FormRange = FormRange FormId FormId@@ -53,14 +80,18 @@ -- | Increment a form ID -- incrementFormId :: FormId -> FormId-incrementFormId (FormId p x) = FormId p $ x + 1+incrementFormId (FormId p (x:xs)) = FormId p $ (x + 1):xs+incrementFormId (FormId _ []) = error "Bad FormId list" +unitRange :: FormId -> FormRange+unitRange i = FormRange i $ incrementFormId 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 (FormId _ a) (FormRange b c) = a >= formId b && a < formId c+isInRange a (FormRange b c) = formId a >= formId b && formId a < formId c  -- | Check if a 'FormRange' is contained in another 'FormRange' --

@@ -3,6 +3,7 @@ module Text.Digestive.Transform     ( Transformer (..)     , transform+    , transformFormlet     , transformEither     , transformEitherM     , transformRead@@ -51,6 +52,16 @@                 Left e -> (v1, Error $ map ((,) range) e)                 -- All fine                 Right y -> (v1, Ok y)++-- | Apply a transformer to a formlet+--+transformFormlet :: Monad m+                 => (b -> a)             -- ^ Needed to produce defaults+                 -> Formlet m i e v a    -- ^ Formlet to transform+                 -> Transformer m e a b  -- ^ Transformer+                 -> Formlet m i e v b    -- ^ Resulting formlet+transformFormlet f formlet transformer def =+    formlet (fmap f def) `transform` transformer  -- | Build a transformer from a simple function that returns an 'Either' result. --

@@ -9,8 +9,12 @@     , getFormId     , getFormRange     , getFormInput+    , getFormInput'     , isFormInput     , Form (..)+    , Formlet+    , bracketState+    , incState     , view     , (++>)     , (<++)@@ -78,8 +82,12 @@ -- | Utility function: Get the current input -- getFormInput :: Monad m => FormState m i (Maybe i)-getFormInput = do-    id' <- getFormId+getFormInput = getFormId >>= getFormInput'++-- | Gets the input of an arbitrary FormId.+--+getFormInput' :: Monad m => FormId -> FormState m i (Maybe i)+getFormInput' id' = do     env <- ask     case env of Environment f -> lift $ lift $ f id'                 NoEnvironment -> return Nothing@@ -95,6 +103,10 @@ -- newtype Form m i e v a = Form {unForm :: FormState m i (View e v, Result e a)} +-- | A function for generating forms with an optional default value.+--+type Formlet m i e v a = Maybe a -> Form m i e v a+ instance Monad m => Functor (Form m i e v) where     fmap f form = Form $ do         (view', result) <- unForm form@@ -104,17 +116,25 @@     pure x = Form $ return (mempty, return x)     f1 <*> f2 = Form $ do         -- Assuming f1 already has a valid ID-        FormRange startF1 _ <- get-        (v1, r1) <- unForm f1-        FormRange _ endF1 <- get+        ((v1,r1), (v2,r2)) <- bracketState $ do+            res1 <- unForm f1+            incState+            res2 <- unForm f2+            return (res1, res2)+        return (v1 `mappend` v2, r1 <*> r2) -        -- Set a new, empty range-        put $ FormRange endF1 $ incrementFormId endF1-        (v2, r2) <- unForm f2-        FormRange _ endF2 <- get+bracketState :: Monad m => FormState m i a -> FormState m i a+bracketState k = do+    FormRange startF1 _ <- get+    res <- k+    FormRange _ endF2 <- get+    put $ FormRange startF1 endF2+    return res -        put $ FormRange startF1 endF2-        return (v1 `mappend` v2, r1 <*> r2)+incState :: Monad m => FormState m i ()+incState = do+        FormRange _ endF1 <- get+        put $ unitRange endF1  -- | Insert a view into the functor --@@ -168,9 +188,7 @@         -> Environment m i           -- ^ Input environment         -> m (View e v, Result e a)  -- ^ Result runForm form id' env = evalStateT (runReaderT (unForm form) env) $-    FormRange f0 $ incrementFormId f0-  where-    f0 = FormId id' 0+    unitRange $ zeroId id'  -- | Evaluate a form to it's view if it fails --