digestive-functors 0.3.0.2 → 0.3.1.0

raw patch · 5 files changed

+128/−57 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• digestive-functors.cabal +1/−1
• src/Text/Digestive/Form.hs +41/−12
• src/Text/Digestive/Form/Encoding.hs +12/−6
• src/Text/Digestive/Form/Internal.hs +62/−31
• src/Text/Digestive/View.hs +12/−7

@@ -1,5 +1,5 @@ Name:     digestive-functors-Version:  0.3.0.2+Version:  0.3.1.0 Synopsis: A practical formlet library  Description:

@@ -1,10 +1,11 @@ {-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings, Rank2Types #-} module Text.Digestive.Form-    ( Form+    ( Formlet+    , Form     , SomeForm (..)     , (.:) -      -- * Forms+      -- * Basic forms     , text     , string     , stringRead@@ -12,13 +13,22 @@     , bool     , file +      -- * Optional forms+    , optionalText+    , optionalString+    , optionalStringRead+       -- * Validation     , check     , checkM     , validate     , validateM++      -- * Lifting forms+    , monadic     ) where +import Control.Monad (liftM) import Data.List (findIndex) import Data.Maybe (fromMaybe) @@ -30,24 +40,23 @@ import Text.Digestive.Types import Text.Digestive.Util -text :: Maybe Text -> Form v m Text+type Formlet m v a = Maybe a -> Form m v a++text :: Formlet v m Text text def = Pure Nothing $ Text $ fromMaybe "" def -string :: Monad m => Maybe String -> Form v m String+string :: Monad m => Formlet v m String string = fmap T.unpack . text . fmap T.pack -stringRead :: (Monad m, Read a, Show a) => v -> Maybe a -> Form v m a-stringRead err = transform readTransform . string . fmap show-  where-    readTransform = return . maybe (Error err) return . readMaybe+stringRead :: (Monad m, Read a, Show a) => v -> Formlet v m a+stringRead err = transform (readTransform err) . string . fmap show -choice :: Eq a => [(a, v)] -> Maybe a -> Form v m a+choice :: Eq a => [(a, v)] -> Formlet v m a choice items def = Pure Nothing $ Choice items $ fromMaybe 0 $     maybe Nothing (\d -> findIndex ((== d) . fst) items) def -bool :: Bool           -- ^ Default value-     -> Form v m Bool  -- ^ Resulting form-bool = Pure Nothing . Bool+bool :: Formlet v m Bool+bool = Pure Nothing . Bool . fromMaybe False  file :: Form v m (Maybe FilePath) file = Pure Nothing File@@ -90,3 +99,23 @@ -- | Version of 'validate' which allows monadic validations validateM :: Monad m => (a -> m (Result v b)) -> Form v m a -> Form v m b validateM = transform++optionalText :: Monad m => Maybe Text -> Form v m (Maybe Text)+optionalText def = validate optional (text def)+  where+    optional t+        | T.null t  = return Nothing+        | otherwise = return $ Just t++optionalString :: Monad m => Maybe String -> Form v m (Maybe String)+optionalString = fmap (fmap T.unpack) . optionalText . fmap T.pack++optionalStringRead :: (Monad m, Read a, Show a)+                   => v -> Maybe a -> Form v m (Maybe a)+optionalStringRead err = transform readTransform' . optionalString . fmap show+  where+    readTransform' (Just s) = liftM (fmap Just) $ readTransform err s+    readTransform' Nothing  = return (return Nothing)++readTransform :: (Monad m, Read a) => v -> String -> m (Result v a)+readTransform err = return . maybe (Error err) return . readMaybe

@@ -2,8 +2,11 @@ module Text.Digestive.Form.Encoding     ( FormEncType (..)     , formEncType+    , formTreeEncType     ) where +import Control.Monad (liftM)+import Control.Monad.Identity (Identity) import Data.Maybe (mapMaybe) import Data.Monoid (Monoid (..), mconcat) @@ -30,13 +33,16 @@ fieldEncType File = MultiPart fieldEncType _    = UrlEncoded -formEncType :: Form v m a -> FormEncType-formEncType = mconcat . map fieldEncType' . fieldList-  where-    fieldEncType' (SomeField f) = fieldEncType f--fieldList :: Form v m a -> [SomeField v]+fieldList :: FormTree Identity v m a -> [SomeField v] fieldList = mapMaybe toField' . fieldList' . SomeForm   where     fieldList' (SomeForm f) = SomeForm f : concatMap fieldList' (children f)     toField' (SomeForm f)   = toField f++formEncType :: Monad m => Form v m a -> m FormEncType+formEncType form = liftM formTreeEncType $ toFormTree form++formTreeEncType :: FormTree Identity v m a -> FormEncType+formTreeEncType = mconcat . map fieldEncType' . fieldList+  where+    fieldEncType' (SomeField f) = fieldEncType f

@@ -1,10 +1,15 @@ -- | This module mostly meant for internal usage, and might change between minor -- releases.-{-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings, Rank2Types #-}+{-# LANGUAGE ExistentialQuantification, FlexibleInstances,+        GADTs, OverloadedStrings, Rank2Types #-} module Text.Digestive.Form.Internal-    ( Form (..)+    ( Form+    , FormTree (..)     , SomeForm (..)+    , Ref     , transform+    , monadic+    , toFormTree     , children     , (.:)     , lookupForm@@ -15,7 +20,8 @@     ) where  import Control.Applicative (Applicative (..))-import Control.Monad ((>=>))+import Control.Monad (liftM, liftM2, (>=>))+import Control.Monad.Identity (Identity (..)) import Data.Maybe (maybeToList) import Data.Monoid (Monoid) @@ -25,8 +31,6 @@ import Text.Digestive.Types import Text.Digestive.Field -type Ref = Maybe Text- -- | Base type for a form. -- -- The three type parameters are:@@ -41,28 +45,37 @@ -- * @a@: the type of the value returned by the form, used for its Applicative --   instance. ---data Form v m a where-    Pure :: Ref -> Field v a -> Form v m a-    App  :: Ref -> Form v m (b -> a) -> Form v m b -> Form v m a+type Form v m a = FormTree m v m a -    Map  :: (b -> m (Result v a)) -> Form v m b -> Form v m a+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)+            -> FormTree t v m b+            -> FormTree t v m a -instance Monad m => Functor (Form v m) where+    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++instance Monad m => Functor (FormTree t v m) where     fmap = transform . (return .) . (return .) -instance (Monad m, Monoid v) => Applicative (Form v m) where+instance (Monad m, Monoid v) => Applicative (FormTree t v m) where     pure x  = Pure Nothing (Singleton x)     x <*> y = App Nothing x y -instance Show (Form v m a) where+instance Show (FormTree Identity v m a) where     show = unlines . showForm -data SomeForm v m = forall a. SomeForm (Form v m a)+data SomeForm v m = forall a. SomeForm (FormTree Identity v m a)  instance Show (SomeForm v m) where     show (SomeForm f) = show f -showForm :: Form v m a -> [String]+type Ref = Maybe 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@@ -71,34 +84,48 @@         , map indent (showForm y)         ]     (Map _ x)   -> "Map _" : map indent (showForm x)+    (Monadic x) -> "Monadic" : map indent (showForm $ runIdentity x)   where     indent = ("  " ++) -transform :: Monad m => (a -> m (Result v b)) -> Form v m a -> Form v m b+transform :: Monad m+          => (a -> m (Result v b)) -> FormTree t v m a -> FormTree t v m b transform f (Map g x) = flip Map x $ \y -> bindResult (g y) f transform f x         = Map f x -children :: Form v m a -> [SomeForm v m]-children (Pure _ _)  = []-children (App _ x y) = [SomeForm x, SomeForm y]-children (Map _ x)   = children x+monadic :: m (Form v m a) -> Form v m a+monadic = Monadic -setRef :: Ref -> Form v m a -> Form v m a+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 (Map f x)   = liftM (Map f) (toFormTree x)+toFormTree (Monadic x) = x >>= toFormTree >>= return . Monadic . Identity++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++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  -- | Operator to set a name for a subform.-(.:) :: Text -> Form v m a -> Form v m a+(.:) :: Monad m => Text -> Form v m a -> Form v m a (.:) = setRef . Just infixr 5 .: -getRef :: Form v m a -> Ref+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 -lookupForm :: Path -> Form v m a -> [SomeForm v m]+lookupForm :: Path -> FormTree Identity v m a -> [SomeForm v m] lookupForm path = go path . SomeForm   where     go []       form            = [form]@@ -111,13 +138,13 @@             | otherwise          -> []         Nothing                  -> children form >>= go (r : rs) -toField :: Form v m a -> Maybe (SomeField v)+toField :: FormTree Identity v m a -> Maybe (SomeField v) toField (Pure _ x) = Just (SomeField x) toField (Map _ x)  = toField x toField _          = Nothing  queryField :: Path-           -> Form v m a+           -> FormTree Identity v m a            -> (forall b. Field v b -> c)            -> c queryField path form f = case lookupForm path form of@@ -132,19 +159,19 @@ ann _    (Success x) = Success x ann path (Error x)   = Error [(path, x)] -eval :: Monad m => Method -> Env m -> Form v m a+eval :: Monad m => Method -> Env m -> FormTree Identity v m a      -> m (Result [(Path, v)] a, [(Path, FormInput)]) eval = eval' [] -eval' :: Monad m => Path -> Method -> Env m -> Form v m a+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 _ ->-        error "No ref specified for field"+    Pure Nothing f ->+        error $ "No ref specified for field " ++ show f      Pure (Just _) field -> do         val <- env path@@ -161,13 +188,17 @@         x''       <- bindResult (return x') (f >=> return . ann path)         return (x'', inp) +    Monadic x -> eval' path method env $ runIdentity x+   where     path = context ++ maybeToList (getRef form) -formMapView :: Monad m => (v -> w) -> Form v m a -> Form w m a-formMapView f (Pure r x)  = Pure r (fieldMapView f x)+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 (Map g x)   = Map (g >=> return . resultMapError f) (formMapView f x)+formMapView f (Monadic x) = formMapView f $ runIdentity x  -- | Utility: bind for 'Result' inside another monad bindResult :: Monad m

@@ -30,6 +30,7 @@     ) where  import Control.Arrow (second)+import Control.Monad.Identity (Identity) import Data.List (findIndex, isPrefixOf) import Data.Maybe (fromMaybe) @@ -44,7 +45,7 @@ data View v = forall a m. Monad m => View     { viewName    :: Text     , viewContext :: Path-    , viewForm    :: Form v m a+    , viewForm    :: FormTree Identity v m a     , viewInput   :: [(Path, FormInput)]     , viewErrors  :: [(Path, v)]     , viewMethod  :: Method@@ -59,13 +60,17 @@         "View " ++ show name ++ " " ++ show ctx ++ " " ++ show form ++ " " ++         show input ++ " " ++ show errs ++ " " ++ show method -getForm :: Monad m => Text -> Form v m a -> View v-getForm name form = View name [] form [] [] Get+getForm :: Monad m => Text -> Form v m a -> m (View v)+getForm name form = do+    form' <- toFormTree form+    return $ View name [] form' [] [] Get  postForm :: Monad m => Text -> Form v m a -> Env m -> m (View v, Maybe a)-postForm name form env = eval Post env' form >>= \(r, inp) -> return $ case r of-    Error errs -> (View name [] form inp errs Post, Nothing)-    Success x  -> (View name [] form inp [] Post, Just x)+postForm name form env = do+    form' <- toFormTree form+    eval Post env' form' >>= \(r, inp) -> return $ case r of+        Error errs -> (View name [] form' inp errs Post, Nothing)+        Success x  -> (View name [] form' inp [] Post, Just x)   where     env' = env . (name :) @@ -90,7 +95,7 @@ viewPath ref (View _ ctx _ _ _ _) = ctx ++ toPath ref  viewEncType :: View v -> FormEncType-viewEncType (View _ _ form _ _ _) = formEncType form+viewEncType (View _ _ form _ _ _) = formTreeEncType form  lookupInput :: Path -> [(Path, FormInput)] -> [FormInput] lookupInput path = map snd . filter ((== path) . fst)