digestive-functors 0.5.0.4 → 0.6.0.0

raw patch · 8 files changed

+500/−200 lines, 8 filesdep ~test-frameworkdep ~test-framework-hunitPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: test-framework, test-framework-hunit

API changes (from Hackage documentation)

Files

• digestive-functors.cabal +6/−7
• src/Text/Digestive/Field.hs +0/−89
• src/Text/Digestive/Form.hs +87/−11
• src/Text/Digestive/Form/Encoding.hs +5/−5
• src/Text/Digestive/Form/Internal.hs +129/−57
• src/Text/Digestive/Form/Internal/Field.hs +93/−0
• src/Text/Digestive/Form/List.hs +68/−0
• src/Text/Digestive/View.hs +112/−31

@@ -1,5 +1,5 @@ Name:     digestive-functors-Version:  0.5.0.4+Version:  0.6.0.0 Synopsis: A practical formlet library  Description:@@ -45,18 +45,17 @@   Hs-source-dirs: src   Ghc-options:    -Wall -fwarn-tabs -  Exposed-modules:     +  Exposed-modules:     Text.Digestive     Text.Digestive.Form     Text.Digestive.Form.Encoding+    Text.Digestive.Form.List     Text.Digestive.Ref     Text.Digestive.Types     Text.Digestive.Util     Text.Digestive.View--  Other-modules:-    Text.Digestive.Field     Text.Digestive.Form.Internal+    Text.Digestive.Form.Internal.Field    Build-depends:     base       >= 4       && < 5,@@ -73,8 +72,8 @@    Build-depends:     HUnit                >= 1.2 && < 1.3,-    test-framework       >= 0.4 && < 0.7,-    test-framework-hunit >= 0.2 && < 0.3,+    test-framework       >= 0.4 && < 0.9,+    test-framework-hunit >= 0.2 && < 0.4,     -- Copied from regular dependencies:     base       >= 4       && < 5,     bytestring >= 0.9     && < 0.11,

@@ -1,89 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE OverloadedStrings         #-}-module Text.Digestive.Field-    ( Field (..)-    , SomeField (..)-    , evalField-    , fieldMapView-    ) where------------------------------------------------------------------------------------import           Control.Arrow        (second)-import           Data.Maybe           (fromMaybe, listToMaybe)-import           Data.Text            (Text)------------------------------------------------------------------------------------import           Text.Digestive.Types-------------------------------------------------------------------------------------- | A single input field. This usually maps to a single HTML @<input>@ element.-data Field v a where-    Singleton :: a -> Field v a-    Text      :: Text -> Field v Text-    -- A list of identifier, value, view. Then we have the default index in-    -- the list. The return value has the actual value as well as the index in-    -- the list.-    Choice    :: [(Text, (a, v))] -> Int -> Field v (a, Int)-    Bool      :: Bool -> Field v Bool-    File      :: Field v (Maybe FilePath)------------------------------------------------------------------------------------instance Show (Field v a) where-    show (Singleton _) = "Singleton _"-    show (Text t)      = "Text " ++ show t-    show (Choice _ _)  = "Choice _ _"-    show (Bool b)      = "Bool " ++ show b-    show (File)        = "File"------------------------------------------------------------------------------------data SomeField v = forall a. SomeField (Field v a)------------------------------------------------------------------------------------evalField :: Method       -- ^ Get/Post-          -> [FormInput]  -- ^ Given input-          -> Field v a    -- ^ Field-          -> a            -- ^ Result-evalField _    _                 (Singleton x) = x-evalField _    (TextInput x : _) (Text _)      = x-evalField _    _                 (Text x)      = x-evalField _    (TextInput x : _) (Choice ls y) =-    fromMaybe (fst (snd (ls !! y)), y) $ do-        -- Expects input in the form of "foo.bar.2". This is not needed for-        -- <select> fields, but we need it for labels for radio buttons.-        t      <- listToMaybe $ reverse $ toPath x-        (c, i) <- lookupIdx t ls-        return (fst c, i)-evalField _    _                 (Choice ls x) = (fst (snd (ls !! x)), x)-evalField Get  _                 (Bool x)      = x-evalField Post (TextInput x : _) (Bool _)      = x == "on"-evalField Post _                 (Bool _)      = False-evalField Post (FileInput x : _) File          = Just x-evalField _    _                 File          = Nothing------------------------------------------------------------------------------------fieldMapView :: (v -> w) -> Field v a -> Field w a-fieldMapView _ (Singleton x)   = Singleton x-fieldMapView _ (Text x)        = Text x-fieldMapView f (Choice xs i)   = Choice (map (second (second f)) xs) i-fieldMapView _ (Bool x)        = Bool x-fieldMapView _ File            = File------------------------------------------------------------------------------------lookupIdx :: Eq k => k -> [(k, v)] -> Maybe (v, Int)-lookupIdx key = go 0-  where-    go _  []        = Nothing-    go !i ((k, v) : xs)-        | key == k  = Just (v, i)-        | otherwise = go (i + 1) xs

@@ -17,6 +17,10 @@     , choice'     , choiceWith     , choiceWith'+    , groupedChoice+    , groupedChoice'+    , groupedChoiceWith+    , groupedChoiceWith'     , bool     , file @@ -33,32 +37,36 @@        -- * Lifting forms     , monadic++      -- * Dynamic list forms+    , listOf     ) where   ---------------------------------------------------------------------------------import           Control.Monad                (liftM)-import           Data.List                    (findIndex)-import           Data.Maybe                   (fromMaybe)-import           Data.Text                    (Text)-import qualified Data.Text                    as T+import           Control.Monad                      (liftM)+import           Data.List                          (findIndex)+import           Data.Maybe                         (fromMaybe)+import           Data.Text                          (Text)+import qualified Data.Text                          as T   ---------------------------------------------------------------------------------import           Text.Digestive.Field import           Text.Digestive.Form.Internal+import           Text.Digestive.Form.Internal.Field+import           Text.Digestive.Form.List import           Text.Digestive.Ref import           Text.Digestive.Types import           Text.Digestive.Util   ---------------------------------------------------------------------------------type Formlet m v a = Maybe a -> Form m v a+type Formlet v m a = Maybe a -> Form v m a   -------------------------------------------------------------------------------- text :: Formlet v m Text-text def = Pure Nothing $ Text $ fromMaybe "" def+text def = Pure $ Text $ fromMaybe "" def   --------------------------------------------------------------------------------@@ -97,19 +105,68 @@ -------------------------------------------------------------------------------- -- | A version of 'choiceWith' for when you have no good 'Eq' instance. choiceWith' :: Monad m => [(Text, (a, v))] -> Maybe Int -> Form v m a-choiceWith' items def = fmap fst $ Pure Nothing $ Choice items def'+choiceWith' items def = fmap fst $ Pure $ Choice [("", items)] def'   where     def' = fromMaybe 0 def   --------------------------------------------------------------------------------+groupedChoice :: (Eq a, Monad m) => [(Text, [(a, v)])] -> Formlet v m a+groupedChoice items def =+    groupedChoiceWith (mkGroupedRefs items makeRefs) def+++--------------------------------------------------------------------------------+-- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you+-- can use this function, which takes an index in the list as default.+groupedChoice' :: Monad m => [(Text, [(a, v)])] -> Maybe Int -> Form v m a+groupedChoice' items def =+    groupedChoiceWith' (mkGroupedRefs items makeRefs) def+++mkGroupedRefs :: [(Text, [a])]+              -> [Text]+              -> [(Text, [(Text, a)])]+mkGroupedRefs [] _ = []+mkGroupedRefs (g:gs) is = cur : mkGroupedRefs gs b+  where+    (a,b) = splitAt (length $ snd g) is+    cur = (fst g, zip a (snd g))+++--------------------------------------------------------------------------------+-- | Allows you to assign your own values: these values will be used in the+-- resulting HTML instead of the default @[0 ..]@. This fixes some race+-- conditions that might otherwise appear, e.g. if new choice items are added to+-- some database while a user views and submits the form...+groupedChoiceWith :: (Eq a, Monad m)+                  => [(Text, [(Text, (a, v))])]+                  -> Formlet v m a+groupedChoiceWith items def = groupedChoiceWith' items def'+  where+    def' = def >>= (\d -> findIndex ((== d) . fst . snd) $+                            concat $ map snd items)+++--------------------------------------------------------------------------------+-- | Low-level support for grouped choice.+groupedChoiceWith' :: Monad m+                   => [(Text, [(Text, (a, v))])]+                   -> Maybe Int+                   -> Form v m a+groupedChoiceWith' items def = fmap fst $ Pure $ Choice items def'+  where+    def' = fromMaybe 0 def+++-------------------------------------------------------------------------------- bool :: Formlet v m Bool-bool = Pure Nothing . Bool . fromMaybe False+bool = Pure . Bool . fromMaybe False   -------------------------------------------------------------------------------- file :: Form v m (Maybe FilePath)-file = Pure Nothing File+file = Pure File   --------------------------------------------------------------------------------@@ -185,3 +242,22 @@ -------------------------------------------------------------------------------- readTransform :: (Monad m, Read a) => v -> String -> m (Result v a) readTransform err = return . maybe (Error err) return . readMaybe+++--------------------------------------------------------------------------------+listOf :: Monad m+       => Formlet v m a+       -> Formlet v m [a]+listOf single def =+    List (fmap single defList) (indicesRef .: listIndices ixs)+  where+    ixs = case def of+        Nothing -> [0]+        Just xs -> [0 .. length xs - 1]++    defList = DefaultList Nothing $ maybe [] (map Just) def+++--------------------------------------------------------------------------------+listIndices :: Monad m => [Int] -> Form v m [Int]+listIndices = fmap parseIndices . text . Just . unparseIndices

@@ -8,15 +8,15 @@   ---------------------------------------------------------------------------------import           Control.Monad                (liftM)-import           Control.Monad.Identity       (Identity)-import           Data.Maybe                   (mapMaybe)-import           Data.Monoid                  (Monoid(..), mconcat)+import           Control.Monad                      (liftM)+import           Control.Monad.Identity             (Identity)+import           Data.Maybe                         (mapMaybe)+import           Data.Monoid                        (Monoid (..), mconcat)   ---------------------------------------------------------------------------------import           Text.Digestive.Field import           Text.Digestive.Form.Internal+import           Text.Digestive.Form.Internal.Field   --------------------------------------------------------------------------------

@@ -18,28 +18,35 @@     , (.:)     , getRef     , lookupForm+    , lookupList     , toField     , queryField     , eval     , formMapView++      -- * Debugging+    , debugFormPaths     ) where   ---------------------------------------------------------------------------------import           Control.Applicative    (Applicative(..))-import           Control.Monad          (liftM, liftM2, (>=>))-import           Control.Monad.Identity (Identity(..))-import           Data.Maybe             (maybeToList)-import           Data.Monoid            (Monoid)+import           Control.Applicative                (Applicative (..))+import           Control.Monad                      (liftM, liftM2,+                                                     mapAndUnzipM, (>=>))+import           Control.Monad.Identity             (Identity (..))+import           Data.Monoid                        (Monoid)+import           Data.Traversable                   (mapM, sequenceA)+import           Prelude                            hiding (mapM)   ---------------------------------------------------------------------------------import           Data.Text              (Text)-import qualified Data.Text              as T+import           Data.Text                          (Text)+import qualified Data.Text                          as T   ---------------------------------------------------------------------------------import           Text.Digestive.Field+import           Text.Digestive.Form.Internal.Field+import           Text.Digestive.Form.List import           Text.Digestive.Types  @@ -63,17 +70,25 @@  -------------------------------------------------------------------------------- data FormTree t v m a where-    Pure    :: Ref -> Field v a -> FormTree t v m a-    App     :: Ref-            -> FormTree t v m (b -> a)+    -- Setting refs+    Ref     :: Ref -> FormTree t v m a -> FormTree t v m a++    -- Applicative interface+    Pure    :: Field v a -> FormTree t v m a+    App     :: FormTree t v m (b -> a)             -> FormTree t v m b             -> FormTree t v m a +    -- Modifications     Map     :: (b -> m (Result v a)) -> FormTree t v m b -> FormTree t v m a-     Monadic :: t (FormTree t v m a) -> FormTree t v m a +    -- Dynamic lists+    List    :: DefaultList (FormTree t v m a)  -- Not the optimal structure+            -> FormTree t v m [Int]+            -> FormTree t v m [a] + -------------------------------------------------------------------------------- instance Monad m => Functor (FormTree t v m) where     fmap = transform . (return .) . (return .)@@ -81,8 +96,8 @@  -------------------------------------------------------------------------------- instance (Monad m, Monoid v) => Applicative (FormTree t v m) where-    pure x  = Pure Nothing (Singleton x)-    x <*> y = App Nothing x y+    pure x  = Pure (Singleton x)+    x <*> y = App x y   --------------------------------------------------------------------------------@@ -100,20 +115,25 @@   ---------------------------------------------------------------------------------type Ref = Maybe Text+type Ref = Text   -------------------------------------------------------------------------------- showForm :: FormTree Identity v m a -> [String] showForm form = case form of-    (Pure r x)  -> ["Pure (" ++ show r ++ ") (" ++ show x ++ ")"]-    (App r x y) -> concat-        [ ["App (" ++ show r ++ ")"]+    (Ref r x) -> ("Ref " ++ show r) : map indent (showForm x)+    (Pure x)  -> ["Pure (" ++ show x ++ ")"]+    (App x y) -> concat+        [ ["App"]         , map indent (showForm x)         , map indent (showForm y)         ]     (Map _ x)   -> "Map _" : map indent (showForm x)     (Monadic x) -> "Monadic" : map indent (showForm $ runIdentity x)+    (List _ is) -> concat+        [ ["List <defaults>"]  -- TODO show defaults+        , map indent (showForm is)+        ]   where     indent = ("  " ++) @@ -132,64 +152,97 @@  -------------------------------------------------------------------------------- toFormTree :: Monad m => Form v m a -> m (FormTree Identity v m a)-toFormTree (Pure r x)  = return $ Pure r x-toFormTree (App r x y) = liftM2 (App r) (toFormTree x) (toFormTree y)+toFormTree (Ref r x)   = liftM (Ref r) (toFormTree x)+toFormTree (Pure x)    = return $ Pure x+toFormTree (App x y)   = liftM2 App (toFormTree x) (toFormTree y) toFormTree (Map f x)   = liftM (Map f) (toFormTree x) toFormTree (Monadic x) = x >>= toFormTree >>= return . Monadic . Identity+toFormTree (List d is) = liftM2 List (mapM toFormTree d) (toFormTree is)   -------------------------------------------------------------------------------- children :: FormTree Identity v m a -> [SomeForm v m]-children (Pure _ _)    = []-children (App _ x y)   = [SomeForm x, SomeForm y]-children (Map _ x)     = children x-children (Monadic x)   = children $ runIdentity x+children (Ref _ x )  = children x+children (Pure _)    = []+children (App x y)   = [SomeForm x, SomeForm y]+children (Map _ x)   = children x+children (Monadic x) = children $ runIdentity x+children (List _ is) = [SomeForm is]   ---------------------------------------------------------------------------------setRef :: Monad t => Ref -> FormTree t v m a -> FormTree t v m a-setRef r (Pure _ x)  = Pure r x-setRef r (App _ x y) = App r x y-setRef r (Map f x)   = Map f (setRef r x)-setRef r (Monadic x) = Monadic $ liftM (setRef r) x+pushRef :: Monad t => Ref -> FormTree t v m a -> FormTree t v m a+pushRef = Ref   -------------------------------------------------------------------------------- -- | Operator to set a name for a subform. (.:) :: Monad m => Text -> Form v m a -> Form v m a-(.:) = setRef . Just+(.:) = pushRef infixr 5 .:   ---------------------------------------------------------------------------------getRef :: FormTree Identity v m a -> Ref-getRef (Pure r _)  = r-getRef (App r _ _) = r-getRef (Map _ x)   = getRef x-getRef (Monadic x) = getRef $ runIdentity x+popRef :: FormTree Identity v m a -> (Maybe Ref, FormTree Identity v m a)+popRef form = case form of+    (Ref r x)   -> (Just r, x)+    (Pure _)    -> (Nothing, form)+    (App _ _)   -> (Nothing, form)+    (Map f x)   -> let (r, form') = popRef x in (r, Map f form')+    (Monadic x) -> popRef $ runIdentity x+    (List _ _)  -> (Nothing, form)   --------------------------------------------------------------------------------+getRef :: FormTree Identity v m a -> Maybe Ref+getRef = fst . popRef+++-------------------------------------------------------------------------------- lookupForm :: Path -> FormTree Identity v m a -> [SomeForm v m] lookupForm path = go path . SomeForm   where+    -- Note how we use `popRef` to strip the ref away. This is really important.     go []       form            = [form]-    go (r : rs) (SomeForm form) = case getRef form of-        Just r'-            -- Note how we use `setRef Nothing` to strip the ref away. This is-            -- really important.-            | r == r' && null rs -> [SomeForm $ setRef Nothing form]+    go (r : rs) (SomeForm form) = case popRef form of+        (Just r', stripped)+            | r == r' && null rs -> [SomeForm stripped]             | r == r'            -> children form >>= go rs             | otherwise          -> []-        Nothing                  -> children form >>= go (r : rs)+        (Nothing, _)             -> children form >>= go (r : rs)   --------------------------------------------------------------------------------+-- | Always returns a List+lookupList :: Path -> FormTree Identity v m a -> SomeForm v m+lookupList path form = case candidates of+    (SomeForm f : _) -> SomeForm f+    []               -> error $ "Text.Digestive.Form.Internal: " +++        T.unpack (fromPath path) ++ ": expected List, but got another form"+  where+    candidates =+        [ x+        | SomeForm f <- lookupForm path form+        , x          <- getList f+        ]++    getList :: forall a v m. FormTree Identity v m a -> [SomeForm v m]+    getList (Ref _ _)   = []+    getList (Pure _)    = []+    getList (App x y)   = getList x ++ getList y+    getList (Map _ x)   = getList x+    getList (Monadic x) = getList $ runIdentity x+    getList (List d is) = [SomeForm (List d is)]+++-------------------------------------------------------------------------------- toField :: FormTree Identity v m a -> Maybe (SomeField v)-toField (Pure _ x)  = Just (SomeField x)+toField (Ref _ x)   = toField x+toField (Pure x)    = Just (SomeField x)+toField (App _ _)   = Nothing toField (Map _ x)   = toField x toField (Monadic x) = toField (runIdentity x)-toField _           = Nothing+toField (List _ _)  = Nothing   --------------------------------------------------------------------------------@@ -220,41 +273,47 @@ eval' :: Monad m => Path -> Method -> Env m -> FormTree Identity v m a       -> m (Result [(Path, v)] a, [(Path, FormInput)]) -eval' context method env form = case form of--    Pure Nothing (Singleton x) -> return (pure x, [])--    Pure Nothing f ->-        error $ "No ref specified for field " ++ show f+eval' path method env form = case form of+    Ref r x -> eval' (path ++ [r]) method env x -    Pure (Just _) field -> do+    Pure field -> do         val <- env path         let x = evalField method val field         return $ (pure x, [(path, v) | v <- val]) -    App _ x y -> do+    App x y -> do         (x', inp1) <- eval' path method env x         (y', inp2) <- eval' path method env y         return (x' <*> y', inp1 ++ inp2)      Map f x -> do-        (x', inp) <- eval' context method env x+        (x', inp) <- eval' path method env x         x''       <- bindResult (return x') (f >=> return . ann path)         return (x'', inp) -    Monadic x -> eval' context method env $ runIdentity x+    Monadic x -> eval' path method env $ runIdentity x -  where-    path = context ++ maybeToList (getRef form)+    List defs fis -> do+        (ris, inp1) <- eval' path method env fis+        case ris of+            Error errs -> return (Error errs, inp1)+            Success is -> do+                (results, inps) <- mapAndUnzipM+                    -- TODO fix head defs+                    (\i -> eval' (path ++ [T.pack $ show i])+                        method env $ defs `defaultListIndex` i) is+                return (sequenceA results, inp1 ++ concat inps)   -------------------------------------------------------------------------------- formMapView :: Monad m             => (v -> w) -> FormTree Identity v m a -> FormTree Identity w m a-formMapView f (Pure r x)  = Pure r $ (fieldMapView f) x-formMapView f (App r x y) = App r (formMapView f x) (formMapView f y)+formMapView f (Ref r x)   = Ref r $ formMapView f x+formMapView f (Pure x)    = Pure $ fieldMapView f x+formMapView f (App x y)   = App (formMapView f x) (formMapView f y) formMapView f (Map g x)   = Map (g >=> return . resultMapError f) (formMapView f x) formMapView f (Monadic x) = formMapView f $ runIdentity x+formMapView f (List d is) = List (fmap (formMapView f) d) (formMapView f is)   --------------------------------------------------------------------------------@@ -266,3 +325,16 @@     case x of         Error errs  -> return $ Error errs         Success x'  -> f x'+++--------------------------------------------------------------------------------+-- | Debugging purposes+debugFormPaths :: Monad m => FormTree Identity v m a -> [Path]+debugFormPaths (Pure _)    = [[]]+debugFormPaths (App x y)   = debugFormPaths x ++ debugFormPaths y+debugFormPaths (Map _ x)   = debugFormPaths x+debugFormPaths (Monadic x) = debugFormPaths $ runIdentity x+debugFormPaths (List d is) =+    debugFormPaths is +++    (map ("0" :) $ debugFormPaths $ d `defaultListIndex` 0)+debugFormPaths (Ref r x)   = map (r :) $ debugFormPaths x

@@ -0,0 +1,93 @@+--------------------------------------------------------------------------------+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE OverloadedStrings         #-}+module Text.Digestive.Form.Internal.Field+    ( Field (..)+    , SomeField (..)+    , evalField+    , fieldMapView+    ) where+++--------------------------------------------------------------------------------+import           Control.Arrow        (second)+import           Data.Maybe           (fromMaybe, listToMaybe)+import           Data.Text            (Text)+++--------------------------------------------------------------------------------+import           Text.Digestive.Types+++--------------------------------------------------------------------------------+-- | A single input field. This usually maps to a single HTML @<input>@ element.+data Field v a where+    Singleton :: a -> Field v a+    Text      :: Text -> Field v Text+    -- A list of identifier, value, view. Then we have the default index in+    -- the list. The return value has the actual value as well as the index in+    -- the list.+    Choice    :: [(Text, [(Text, (a, v))])] -> Int -> Field v (a, Int)+    Bool      :: Bool -> Field v Bool+    File      :: Field v (Maybe FilePath)+++--------------------------------------------------------------------------------+instance Show (Field v a) where+    show (Singleton _) = "Singleton _"+    show (Text t)      = "Text " ++ show t+    show (Choice _ _)  = "Choice _ _"+    show (Bool b)      = "Bool " ++ show b+    show (File)        = "File"+++--------------------------------------------------------------------------------+data SomeField v = forall a. SomeField (Field v a)+++--------------------------------------------------------------------------------+evalField :: Method       -- ^ Get/Post+          -> [FormInput]  -- ^ Given input+          -> Field v a    -- ^ Field+          -> a            -- ^ Result+evalField _    _                 (Singleton x) = x+evalField _    (TextInput x : _) (Text _)      = x+evalField _    _                 (Text x)      = x+evalField _    (TextInput x : _) (Choice ls' y) =+  let ls = concat (map snd ls') in+    fromMaybe (fst (snd (ls !! y)), y) $ do+        -- Expects input in the form of "foo.bar.2". This is not needed for+        -- <select> fields, but we need it for labels for radio buttons.+        t      <- listToMaybe $ reverse $ toPath x+        (c, i) <- lookupIdx t ls+        return (fst c, i)+evalField _    _                 (Choice ls' x) =+  let ls = concat (map snd ls') in+    (fst (snd (ls !! x)), x)+evalField Get  _                 (Bool x)      = x+evalField Post (TextInput x : _) (Bool _)      = x == "on"+evalField Post _                 (Bool _)      = False+evalField Post (FileInput x : _) File          = Just x+evalField _    _                 File          = Nothing+++--------------------------------------------------------------------------------+fieldMapView :: (v -> w) -> Field v a -> Field w a+fieldMapView _ (Singleton x)   = Singleton x+fieldMapView _ (Text x)        = Text x+fieldMapView f (Choice xs i)   = Choice (map (second func) xs) i+  where func = map (second (second f))+fieldMapView _ (Bool x)        = Bool x+fieldMapView _ File            = File+++--------------------------------------------------------------------------------+lookupIdx :: Eq k => k -> [(k, v)] -> Maybe (v, Int)+lookupIdx key = go 0+  where+    go _  []        = Nothing+    go !i ((k, v) : xs)+        | key == k  = Just (v, i)+        | otherwise = go (i + 1) xs

@@ -0,0 +1,68 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Form.List+    ( indicesRef+    , parseIndices+    , unparseIndices+    , DefaultList (..)+    , defaultListIndex+    ) where+++--------------------------------------------------------------------------------+import           Control.Applicative ((<$>), (<*>))+import           Data.Foldable       (Foldable (..))+import           Data.Maybe          (mapMaybe)+import           Data.Text           (Text)+import qualified Data.Text           as T+import           Data.Traversable    (Traversable (..))+import           Prelude             hiding (foldr)+++--------------------------------------------------------------------------------+import           Text.Digestive.Util+++--------------------------------------------------------------------------------+indicesRef :: Text+indicesRef = "indices"+++--------------------------------------------------------------------------------+parseIndices :: Text -> [Int]+parseIndices = mapMaybe (readMaybe . T.unpack) . T.split (== ',')+++--------------------------------------------------------------------------------+unparseIndices :: [Int] -> Text+unparseIndices = T.intercalate "," . map (T.pack . show)+++--------------------------------------------------------------------------------+-- | A list which, when indexed on non-existant positions, returns a default+-- value.+data DefaultList a = DefaultList a [a]+++--------------------------------------------------------------------------------+instance Functor DefaultList where+    fmap f (DefaultList x xs) = DefaultList (f x) (map f xs)+++--------------------------------------------------------------------------------+instance Foldable DefaultList where+    foldr f z (DefaultList x xs) = f x (foldr f z xs)+++--------------------------------------------------------------------------------+instance Traversable DefaultList where+    traverse f (DefaultList x xs) = DefaultList <$> f x <*> traverse f xs+++--------------------------------------------------------------------------------+defaultListIndex :: DefaultList a -> Int -> a+defaultListIndex (DefaultList x xs) i+    | i < 0     = x+    | otherwise = case drop i xs of+        (y : _) -> y+        []      -> x

@@ -25,27 +25,36 @@       -- ** Input     , fieldInputText     , fieldInputChoice+    , fieldInputChoiceGroup     , fieldInputBool     , fieldInputFile +      -- ** List subview+    , listSubViews+    , makeListSubView+       -- ** Errors     , errors     , childErrors++      -- * Debugging+    , debugViewPaths     ) where   ---------------------------------------------------------------------------------import           Control.Arrow                (second)-import           Control.Monad.Identity       (Identity)-import           Data.List                    (isPrefixOf)-import           Data.Text                    (Text)-import qualified Data.Text                    as T+import           Control.Arrow                      (second)+import           Control.Monad.Identity             (Identity)+import           Data.List                          (isPrefixOf)+import           Data.Text                          (Text)+import qualified Data.Text                          as T   ---------------------------------------------------------------------------------import           Text.Digestive.Field import           Text.Digestive.Form.Encoding import           Text.Digestive.Form.Internal+import           Text.Digestive.Form.Internal.Field+import           Text.Digestive.Form.List import           Text.Digestive.Types  @@ -94,16 +103,28 @@ -------------------------------------------------------------------------------- subView :: Text -> View v -> View v subView ref (View name ctx form input errs method) =-    View name (ctx ++ path) form input errs method+    case lookupForm path form of+        []               ->+            View name (ctx ++ path) notFound (strip input) (strip errs) method+        (SomeForm f : _) ->+            View name (ctx ++ path) f (strip input) (strip errs) method   where-    path = toPath ref+    path     = toPath ref+    lpath    = length path +    strip :: [(Path, a)] -> [(Path, a)]+    strip xs = [(drop lpath p, x) | (p, x) <- xs, path `isPrefixOf` p] +    notFound :: FormTree Identity v Identity a+    notFound = error $ "Text.Digestive.View.subView: " +++        "No such subView: " ++ T.unpack ref++ -------------------------------------------------------------------------------- -- | Returns all immediate subviews of a view subViews :: View v -> [View v]-subViews view@(View _ ctx form _ _ _) =-    [subView r view | f <- lookupForm ctx form, r <- go f]+subViews view@(View _ _ form _ _ _) =+    [subView r view | r <- go (SomeForm form)]   where     go (SomeForm f) = case getRef f of         Nothing -> [r | c <- children f, r <- go c]@@ -113,7 +134,7 @@ -------------------------------------------------------------------------------- -- | Determine an absolute 'Path' for a field in the form absolutePath :: Text -> View v -> Path-absolutePath ref view@(View name _ _ _ _ _) = name : viewPath ref view+absolutePath ref (View name ctx _ _ _ _) = name : (ctx ++ toPath ref)   --------------------------------------------------------------------------------@@ -124,13 +145,6 @@   ----------------------------------------------------------------------------------- | Internal version of 'absolutePath' which does not take the form name into--- account-viewPath :: Text -> View v -> Path-viewPath ref (View _ ctx _ _ _ _) = ctx ++ toPath ref----------------------------------------------------------------------------------- viewEncType :: View v -> FormEncType viewEncType (View _ _ form _ _ _) = formTreeEncType form @@ -142,10 +156,10 @@  -------------------------------------------------------------------------------- fieldInputText :: forall v. Text -> View v -> Text-fieldInputText ref view@(View _ _ form input _ method) =+fieldInputText ref (View _ _ form input _ method) =     queryField path form eval'   where-    path       = viewPath ref view+    path       = toPath ref     givenInput = lookupInput path input      eval' :: Field v b -> Text@@ -158,27 +172,57 @@ -------------------------------------------------------------------------------- -- | Returns a list of (identifier, view, selected?) fieldInputChoice :: forall v. Text -> View v -> [(Text, v, Bool)]-fieldInputChoice ref view@(View _ _ form input _ method) =+fieldInputChoice ref (View _ _ form input _ method) =     queryField path form eval'   where-    path       = viewPath ref view+    path       = toPath ref     givenInput = lookupInput path input      eval' :: Field v b -> [(Text, v, Bool)]     eval' field = case field of         Choice xs didx ->             let idx = snd $ evalField method givenInput (Choice xs didx)-            in map (\(i, (k, (_, v))) -> (k, v, i == idx)) $ zip [0 ..] xs+            in map (\(i, (k, (_, v))) -> (k, v, i == idx)) $+                 zip [0 ..] $ concat $ map snd xs         f           -> error $ T.unpack ref ++ ": expected (Choice _ _), " ++             "but got: (" ++ show f ++ ")"   --------------------------------------------------------------------------------+-- | Returns a list of (groupName, [(identifier, view, selected?)])+fieldInputChoiceGroup :: forall v. Text+                      -> View v+                      -> [(Text, [(Text, v, Bool)])]+fieldInputChoiceGroup ref (View _ _ form input _ method) =+    queryField path form eval'+  where+    path       = toPath ref+    givenInput = lookupInput path input++    eval' :: Field v b -> [(Text, [(Text, v, Bool)])]+    eval' field = case field of+        Choice xs didx ->+            let idx = snd $ evalField method givenInput (Choice xs didx)+            in merge idx xs [0..]+        f           -> error $ T.unpack ref ++ ": expected (Choice _ _), " +++            "but got: (" ++ show f ++ ")"++merge :: Int+      -> [(Text, [(Text, (a, v))])]+      -> [Int]+      -> [(Text, [(Text, v, Bool)])]+merge _ [] _ = []+merge idx (g:gs) is = cur : merge idx gs b+  where+    (a,b) = splitAt (length $ snd g) is+    cur = (fst g, map (\(i, (k, (_, v))) -> (k, v, i == idx)) $ zip a (snd g))++-------------------------------------------------------------------------------- fieldInputBool :: forall v. Text -> View v -> Bool-fieldInputBool ref view@(View _ _ form input _ method) =+fieldInputBool ref (View _ _ form input _ method) =     queryField path form eval'   where-    path       = viewPath ref view+    path       = toPath ref     givenInput = lookupInput path input      eval' :: Field v b -> Bool@@ -190,10 +234,10 @@  -------------------------------------------------------------------------------- fieldInputFile :: forall v. Text -> View v -> Maybe FilePath-fieldInputFile ref view@(View _ _ form input _ method) =+fieldInputFile ref (View _ _ form input _ method) =     queryField path form eval'   where-    path       = viewPath ref view+    path       = toPath ref     givenInput = lookupInput path input      eval' :: Field v b -> Maybe FilePath@@ -204,12 +248,49 @@   --------------------------------------------------------------------------------+listSubViews :: forall v. Text -> View v -> [View v]+listSubViews ref view =+    map (\i -> makeListSubView ref i view) indices+  where+    path        = toPath ref+    indicesPath = path ++ toPath indicesRef+    indices     = parseIndices $ fieldInputText (fromPath indicesPath) view+++--------------------------------------------------------------------------------+-- | Creates a sub view+makeListSubView :: Text+                -- ^ ref+                -> Int+                -- ^ index to use for the subview+                -> View v+                -- ^ list view+                -> View v+makeListSubView ref ind view@(View _ _ form _ _ _) =+    case subView (fromPath $ path ++ [T.pack $ show ind]) view of+        View name ctx _ input errs method ->+            case lookupList path form of+                -- TODO don't use head+                (SomeForm (List defs _)) ->+                    View name ctx (defs `defaultListIndex` ind)+                        input errs method+                _                                -> error $+                    T.unpack ref ++ ": expected List, but got another form"+  where+    path        = toPath ref+++-------------------------------------------------------------------------------- errors :: Text -> View v -> [v]-errors ref view = map snd $ filter ((== viewPath ref view) . fst) $-    viewErrors view+errors ref = map snd . filter ((== toPath ref) . fst) . viewErrors   -------------------------------------------------------------------------------- childErrors :: Text -> View v -> [v]-childErrors ref view = map snd $-    filter ((viewPath ref view `isPrefixOf`) . fst) $ viewErrors view+childErrors ref = map snd .+    filter ((toPath ref `isPrefixOf`) . fst) . viewErrors+++--------------------------------------------------------------------------------+debugViewPaths :: View v -> [Path]+debugViewPaths (View _ _ form _ _ _) = debugFormPaths form