diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,3 @@ -Copyright (c) 2008, Tupil - All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README b/README --- a/README +++ b/README @@ -1,8 +1,9 @@ -The original author of this library is Jeremy Yallop. It is currently maintained -by Chris Eidhof. +The original author of this library is Jeremy Yallop. It was packaged by Chris +Eidhof, and is currently maintained by Doug Beardsley. Other contributors: -* MightyByte * Eelco Lempsink +* Jeremy Shaw +* Judah Jacobson The formlets repository is hosted on github: http://github.com/chriseidhof/formlets/ diff --git a/Text/Formlets.hs b/Text/Formlets.hs --- a/Text/Formlets.hs +++ b/Text/Formlets.hs @@ -1,19 +1,23 @@ -module Text.Formlets ( input', inputM', optionalInput, inputFile, fmapFst, nothingIfNull +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +module Text.Formlets ( input', inputM', optionalInput, generalInput, generalInputMulti, inputFile, fmapFst, nothingIfNull , check, ensure, ensures , ensureM, checkM, pureM , runFormState , massInput - , xml, plug, plug' + , xml, plug, plug2, plug' , Env , Form , Formlet , File (..), ContentType (..), FormContentType (..) + , Rect, stringRect ) where +import Data.Generics +import Data.Either (partitionEithers) import Data.Monoid import Control.Applicative import Control.Applicative.Error import Control.Applicative.State -import Data.Maybe (isJust) +import Data.Maybe (isJust, fromMaybe) import Data.List (intercalate) import qualified Text.Formlets.FormResult as FR import qualified Data.ByteString.Lazy as BS @@ -27,14 +31,25 @@ type S a = State FormState a type Validator a = S (FR.FormResult a) data FormContentType = UrlEncoded | MultiPart deriving (Eq, Show, Read) -newtype Form xml m a = Form { deform :: Env -> S (m (Validator a), m xml, FormContentType) } -data File = File {content :: BS.ByteString, fileName :: String, contentType :: ContentType} deriving (Eq, Show, Read) +newtype Form xml m a = Form { deform :: Env -> S (m (Validator a), xml, FormContentType) } +data File = File {content :: BS.ByteString, fileName :: String, contentType :: ContentType} deriving (Eq, Show, Read, Data, Typeable) data ContentType = ContentType { ctType :: String , ctSubtype :: String , ctParameters :: [(String, String)] } - deriving (Eq, Show, Read) + deriving (Eq, Show, Read, Data, Typeable) + +data Rect = Rect {rectCols :: Int, rectRows :: Int} + deriving (Eq, Ord, Show, Read, Data, Typeable) +-- |Choose a good number of rows for a textarea input. Uses the +-- number of newlines in the string and the number of lines that +-- are too long for the desired width. +stringRect :: Int -> String -> Rect +stringRect cols s = + Rect {rectCols = cols, + rectRows = foldr (+) 0 (map (\ line -> 1 + (length line) `div` cols) (lines s))} + -- | Apply a predicate to a value and return FR.Success or FR.Failure as appropriate ensure :: Show a => (a -> Bool) -- ^ The predicate @@ -62,34 +77,122 @@ where errors = [ err | (p, err) <- ps, not $ p x ] -- | Helper function for genereting input components based forms. -input' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String -input' i = inputM' (\n -> return . i n) +-- +-- see also 'optionalInput', 'generalInput', and 'generalInputMulti' +input' :: Monad m + => (String -> String -> xml) -- ^ function which takes the control name, the initial value, and returns the control markup + -> Maybe String -- ^ optional default value + -> Form xml m String +input' i defaultValue = generalInput' i' fromLeft -- `check` maybe (Failure ["not in the data"]) Success + where i' n v = i n (fromMaybe (fromMaybe "" defaultValue) v) + fromLeft n Nothing = FR.NotAvailable $ n ++ " is not in the data" + fromLeft n (Just (Left x)) = FR.Success x + fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."] -inputM' :: Monad m => (String -> String -> m xml) -> Maybe String -> Form xml m String -inputM' i defaultValue = Form $ \env -> mkInput env <$> freshName - where mkInput env name = (lookupFreshName fromLeft env, i name (value name env), UrlEncoded) - value name env = maybe (maybe "" id defaultValue) fromLeft' (lookup name env) - fromLeft' (Left x) = x - fromLeft' _ = "" - fromLeft n Nothing = FR.NotAvailable $ n ++ " is not in the data" - fromLeft n (Just (Left x)) = FR.Success x - fromLeft n _ = FR.Failure [n ++ " is a file."] +{-# DEPRECATED inputM' "You can just use input'"#-} +-- |deprecated. See 'input'' +inputM' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String +inputM' = input' +-- | Create a form control which is not required to be successful +-- +-- There is no way to provide a default value, because that would +-- result in the control being successful. +-- +-- For more information on successful controls see: +-- +-- +-- +-- see also 'input'', 'generalInput', and 'generalInputMulti' +optionalInput :: Monad m + => (String -> xml) -- ^ function which takes the form name and produces the control markup + -> Form xml m (Maybe String) +optionalInput i = generalInput' (\n _ -> i n) fromLeft + where + fromLeft n Nothing = FR.Success Nothing + fromLeft n (Just (Left x)) = FR.Success (Just x) + fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."] + +-- |generate a form control +-- +-- see also 'input'', 'optionalInput', 'generalInputMulti'. +generalInput :: Monad m => + (String -> Maybe String -> xml) -- ^ function which takes the control name, an initial value if one was found in the environment and returns control markup + -> Form xml m (Maybe String) +generalInput i = generalInput' (\n v -> i n v) fromLeft + where + fromLeft n Nothing = FR.Success Nothing + fromLeft n (Just (Left x)) = FR.Success (Just x) + fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."] + +-- a combination of lookup and freshName. +-- 1. generate a fresh name +-- 2. lookup that name in the environment (returns a Maybe value) +-- 3. pass the name and the Maybe value to the function 'f', which returns a value of type 'a' +lookupFreshName :: (Monad m) => (String -> Maybe (Either String File) -> a) -> Env -> m (State FormState a) lookupFreshName f env = return $ (freshName >>= \name -> return $ f name $ (lookup name env)) -optionalInput :: Monad m => (String -> xml) -> Form xml m (Maybe String) -optionalInput i = Form $ \env -> mkInput env <$> freshName - where mkInput env name = (lookupFreshName fromLeft env, return (i name), UrlEncoded) - fromLeft n Nothing = FR.Success Nothing - fromLeft n (Just (Left x)) = FR.Success (Just x) - fromLeft n _ = FR.Failure [n ++ " could not be recognized."] +-- |generate a form control +-- +-- see also 'input'', 'optionalInput', 'generalInputMulti'. +generalInput' :: Monad m => + (String -> Maybe String -> xml) -- ^ function which takes the control name, an initial value if one was found in the environment and returns control markup + -> (String -> Maybe (Either String File) -> FR.FormResult a) + -> Form xml m a +generalInput' i fromLeft = Form $ \env -> mkInput env <$> freshName + where mkInput env name = (lookupFreshName fromLeft env, -- return . result name, + i name (value name env), UrlEncoded) + -- A function to obtain the initial value used to compute the + -- representation. The environment is the one passed to + -- runFormState. It typically reflects the initial value of + -- the datatype which the form is meant to represent. + value name env = + case lookup name env of + Just (Left x) -> Just x + Just (Right _) -> error $ name ++ " is a file." + Nothing -> Nothing + -- A function to obtain the form's return value from the + -- environment returned after the form is run. +-- |generate a form control which can return multiple values +-- +-- Useful for controls such as checkboxes and multiple select . +-- +-- see also 'input'', 'optionalInput', 'generalInput'. +generalInputMulti :: forall m xml. Monad m => + (String -> [String] -> xml) + -> Form xml m [String] +generalInputMulti i = Form $ \env -> mkInput env <$> freshName + where mkInput :: Env -> String -> (m (Validator [String]), xml, FormContentType) + mkInput env name = (return (result env), + i name (value name env), UrlEncoded) + -- A function to obtain the initial value used to compute the + -- representation. The environment is the one passed to + -- runFormState. It typically reflects the initial value of + -- the datatype which the form is meanto to represent. + value :: String -> Env -> [String] + value name env = + case partitionEithers $ lookups name env of + (xs,[]) -> xs + _ -> error $ name ++ " is a file." + -- A function to obtain the form's return value from the + -- environment returned after the form is run. + result :: Env -> Validator [String] + result env = + do name <- freshName + return $ case partitionEithers $ lookups name env of + ([],[]) -> FR.NotAvailable $ name ++ " is not in the data." + (xs,[]) -> FR.Success xs + _ -> FR.Failure [name ++ " is a file."] + lookups :: (Eq a) => a -> [(a, b)] -> [b] + lookups k = map snd . filter ((k ==) . fst) + -- | A File input widget. inputFile :: Monad m => (String -> xml) -- ^ Generates the xml for the file-upload widget based on the name -> Form xml m File inputFile i = Form $ \env -> mkInput env <$> freshName - where mkInput env name = (lookupFreshName fromRight env, return (i name), MultiPart) + where mkInput env name = (lookupFreshName fromRight env, i name, MultiPart) fromRight n Nothing = FR.NotAvailable $ n ++ " is not in the data" fromRight n (Just (Right x)) = FR.Success x fromRight n _ = FR.Failure [n ++ " is not a file"] @@ -98,7 +201,7 @@ runFormState :: Monad m => Env -- ^ A previously filled environment (may be empty) -> Form xml m a -- ^ The form - -> (m (Failing a), m xml, FormContentType) + -> (m (Failing a), xml, FormContentType) runFormState e (Form f) = fmapFst3 (liftM FR.toE . liftM es) (es (f e)) where es = flip evalState [0] @@ -120,14 +223,14 @@ --return x transform :: Monad m => (a -> m (Failing b)) -> m (Validator a) -> FormState -> m (Validator b) - transform f source st = x' (x f) source - where x :: Monad m => (a -> m (Failing b)) -> a -> m (Validator b) - x f = fmap (liftM (return . FR.fromE)) f - x' :: Monad m => (a -> m (Validator b)) -> m (Validator a) -> m (Validator b) - x' f a = do a' <- a - let (a'', st') = runState a' st - val <- combine f a'' - return (changeState st' val) + transform f source st = transform' (makeValidator f) source + where makeValidator :: Monad m => (a -> m (Failing b)) -> a -> m (Validator b) + makeValidator f = fmap (liftM (return . FR.fromE)) f + transform' :: Monad m => (a -> m (Validator b)) -> m (Validator a) -> m (Validator b) + transform' f a = do a' <- a + let (a'', st') = runState a' st + val <- combine f a'' + return (changeState st' val) changeState :: st -> State st a -> State st a changeState st' mComp = do result <- mComp put st' @@ -152,14 +255,34 @@ -- | Pure xml xml :: Monad m => xml -> Form xml m () -xml x = Form $ \env -> pure (return (return $ FR.Success ()), return x, UrlEncoded) +xml x = Form $ \env -> pure (return (return $ FR.Success ()), x, UrlEncoded) -- | Transform the XML component -plug :: (Monad m, Monoid xml) => (xml -> xml1) -> Form xml m a -> Form xml1 m a +plug :: (xml -> xml1) -> Form xml m a -> Form xml1 m a f `plug` (Form m) = Form $ \env -> pure plugin <*> m env - where plugin (c, x, t) = (c, liftM f x, t) + where plugin (c, x, t) = (c, f x, t) -plug' :: (Monad m, Monoid xml1) => (xml1 -> xml2) -> Formlet xml1 m a -> Formlet xml2 m a +-- | Combine the XML components of two forms using f, and combine the +-- values using g. +plug2 :: (Monad m) => (xml -> xml1 -> xml2) -> (a -> b -> Failing c) -> Form xml m a -> Form xml1 m b -> Form xml2 m c +plug2 f g (Form m) (Form n) = + Form $ \env -> plugin <$> m env <*> n env + where + plugin (c1, x1, t1) (c2, x2, t2) = (combineCollectors c1 c2, f x1 x2, t2) +-- combineCollectors :: (Monad m) => m (State FormState (FR.FormResult a)) -> m (State FormState (FR.FormResult b)) -> m (State FormState (FR.FormResult c)) + combineCollectors c1 c2 = + do a' <- c1 + b' <- c2 + return $ combiner <$> a' <*> b' +-- combiner :: (FR.FormResult a) -> (FR.FormResult b) -> (FR.FormResult c) + combiner (FR.Failure a) (FR.Failure b) = FR.Failure (a ++ b) + combiner (FR.Failure a) _ = FR.Failure a + combiner _ (FR.Failure b) = FR.Failure b + combiner (FR.NotAvailable str) _ = FR.NotAvailable str + combiner _ (FR.NotAvailable str) = FR.NotAvailable str + combiner (FR.Success a) (FR.Success b) = FR.fromE (g a b) + +plug' :: (xml1 -> xml2) -> Formlet xml1 m a -> Formlet xml2 m a plug' transformer formlet value = plug transformer (formlet value) -- | This generates a single (or more) forms for a, and a parser function for a list of a's. @@ -180,12 +303,11 @@ [] -> return (newCollector, xml', contentType) xs -> do resetCurrentLevel xmls <- mapM (generateXml single env) xs - let xmls' = sequence xmls - return (newCollector, liftM mconcat xmls', contentType) + return (newCollector, mconcat xmls, contentType) modify (tail.tail) return x -generateXml :: Monad m => (Maybe a -> Form xml m a) -> Env -> a -> S (m xml) +generateXml :: Monad m => (Maybe a -> Form xml m a) -> Env -> a -> S xml generateXml form env value = do (_, xml, _) <- (deform $ form $ Just value) env modify nextItem return xml @@ -194,14 +316,14 @@ resetCurrentLevel = do modify (tail . tail) modify (\x -> 0:0:x) -generateListXml :: (Applicative m, Monad m, Monoid xml) => Form xml m a -> Env -> S (m xml) +generateListXml :: (Applicative m, Monad m, Monoid xml) => Form xml m a -> Env -> S xml generateListXml form env = do n <- currentName case lookup n env of - Nothing -> return $ return mempty + Nothing -> return mempty Just _ -> do (_, xml, _) <- (deform form) env modify nextItem rest <- generateListXml form env - return $ mappend <$> xml <*> rest + return $ mappend xml rest liftCollector :: (Monad m) => FormState -> m (Validator a) -> m (Validator [a]) liftCollector st coll = do coll' <- coll @@ -250,14 +372,14 @@ orT x y = x pureF :: (Monad m, Monoid xml) => a -> Form xml m a -pureF v = Form $ \env -> pure (return (return $ FR.Success v), return mempty, UrlEncoded) +pureF v = Form $ \env -> pure (return (return $ FR.Success v), mempty, UrlEncoded) pureM :: (Monad m, Monoid xml) => m a -> Form xml m a -pureM v = Form $ \env -> pure (liftM (return . FR.Success) v, return mempty, UrlEncoded) +pureM v = Form $ \env -> pure (liftM (return . FR.Success) v, mempty, UrlEncoded) applyF :: (Monad m, Applicative m, Monoid xml) => Form xml m (a -> b) -> Form xml m a -> Form xml m b (Form f) `applyF` (Form v) = Form $ \env -> combine <$> f env <*> v env - where combine (v1, xml1, t1) (v2, xml2, t2) = (first v1 v2, (mappend <$> xml1 <*> xml2), t1 `orT` t2) + where combine (v1, xml1, t1) (v2, xml2, t2) = (first v1 v2, (mappend xml1 xml2), t1 `orT` t2) first :: Monad m => m (Validator (a -> b)) -> m (Validator (a )) diff --git a/Text/Formlets/MassInput.hs b/Text/Formlets/MassInput.hs --- a/Text/Formlets/MassInput.hs +++ b/Text/Formlets/MassInput.hs @@ -41,6 +41,9 @@ ," }" ," ));" ,"" +-- Uncomment the following line if you want the newly added fields to +-- be empty. +-- ," newItem.children('input').attr('value','');" ," newItem.appendTo(item.parent());" ,"}" ,"function removeItem(button) {" diff --git a/formlets.cabal b/formlets.cabal --- a/formlets.cabal +++ b/formlets.cabal @@ -1,8 +1,8 @@ Name: formlets -Version: 0.6.1 +Version: 0.7 Synopsis: Formlets implemented in Haskell -Description: A modular way to build forms based on applicative functors, as - described in: +Description: A modular way to build forms based on applicative functors, + based on the work described in: . * Ezra Cooper, Samuel Lindley, Philip Wadler and Jeremy Yallop \"An idiom's guide to formlets\" @@ -11,21 +11,26 @@ Category: XML, Web, User Interfaces, Text License: BSD3 License-file: LICENSE -Copyright: (c) Jeremy Yallop / Tupil -Author: Jeremy Yallop / Chris Eidhof Homepage: http://github.com/chriseidhof/formlets/tree/master -Maintainer: Chris Eidhof +Maintainer: Doug Beardsley Build-Type: Simple Cabal-Version: >= 1.6 Extra-Source-Files: README +Flag base4 + Description: Choose the even newer, even smaller, split-up base package. + Library - Build-Depends: base >= 2 && < 5, - haskell98, - mtl, + Build-Depends: haskell98, + mtl, xhtml, applicative-extras >= 0.1.3, bytestring + if flag(base4) + Build-Depends: base >= 4 && < 5, syb + else + Build-Depends: base >= 2 && < 4 + Exposed-Modules: Text.Formlets , Text.Formlets.MassInput , Text.XHtml.Strict.Formlets