[a mockup to demo formlets with inline error messages Jeremy Shaw **20090903161752] addfile ./Demo.hs addfile ./LICENSE addfile ./README addfile ./Setup.hs adddir ./Text addfile ./Text/Formlets.hs addfile ./TextDemo.hs addfile ./formlets.cabal hunk ./Demo.hs 1 +{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-} +import Control.Applicative +import Control.Applicative.Error +import Control.Monad +import Control.Monad.Trans +import Happstack.Server hiding (ContentType) +import Happstack.Server.HSP.HTML +import HSP.ServerPartT +import HSP +import qualified HSX.XMLGenerator as HSX +import Text.Formlets + +-- |An input field with an optional value +input :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String +input = input' (\n v -> []) + +-- |An input field with an optional value +password :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String +password = input' (\n v -> []) + +submit :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v String +submit value = input' (\n v -> []) (Just value) + + + +main = simpleHTTP nullConf impl + +impl :: ServerPartT IO Response +impl = + msum [ do methodM GET + let (_, xml, _) = runFormState ([],[]) "" form + page $ +
+ <% xml %> +
+ , do methodM POST + (Just vals') <- getDataFn lookPairs + let vals = map (\(n,v) -> (n, Left v)) vals' + let (collector, _, _) = runFormState ([], vals) "" form + res <- liftIO $ collector + case res of + (SuccessAt a) -> page $

You entered: <% show a %>

+ (FailureAt errs) -> + do let (_, xml, _) = runFormState (errs, vals) "" form + page $ +
+-- <% show vals' %> +-- <% show errs %> + <% xml %> +
+ ] + +page :: XMLGenT (ServerPartT IO) XML -> ServerPartT IO Response +page b = + do xml <- unXMLGenT $ + + + Fomlets Demo + + + <% b %> + + + ok (toResponse xml) + + +label str = xml $ [] + +br :: Form [XMLGenT (ServerPartT IO) (HSX.XML (ServerPartT IO))] IO () +br = xml $ [
] + +form :: Form [XMLGenT (ServerPartT IO) (HSX.XML (ServerPartT IO))] IO (String, String) +form = (,) <$> (username <* br) <*> pass <* submit "create account" + +username :: Form [XMLGenT (ServerPartT IO) (HSX.XML (ServerPartT IO))] IO String +username = + checkInline (label "Username" *> input Nothing) + (\str -> if (length str) < 6 then + Failure ["Your username must be at least 6 characters long."] + else if (str == "foobar") then + Failure ["You may not use the username foobar."] + else Success str) + (\errs xml -> + xml ++ (map (\err -> <% err %>) errs)) + +pass :: Form [XMLGenT (ServerPartT IO) (HSX.XML (ServerPartT IO))] IO String +pass = + checkInline ((,) <$> (label "Password" *> password Nothing <* br) <*> + (label "Confirm Password" *> password Nothing <* br)) + (\(str1, str2) -> + if str1 /= str2 then + Failure ["Passwords do not match."] + else Success str1) + (\errs xml -> + [

Passwords do not match.

] ++ xml + ) hunk ./LICENSE 1 +Copyright (c) 2008, Tupil + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tupil nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hunk ./README 1 +The original author of this library is Jeremy Yallop. It is currently maintained +by Chris Eidhof. + +Other contributors: +* MightyByte +* Eelco Lempsink + +The formlets repository is hosted on github: http://github.com/chriseidhof/formlets/ hunk ./Setup.hs 1 +import Distribution.Simple +main = defaultMain hunk ./Text/Formlets.hs 1 - +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +module Text.Formlets 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 (fromMaybe) +import qualified Data.ByteString.Lazy as BS + +-- * Form stuff +type Errors = [(String, ErrorMsg)] +type Values = [(String, (Either String File))] +type Env = (Errors, Values) +type FormState = (Integer, String) +type Name = String +type Collector a = Env -> a +data FailingAt a = SuccessAt a | FailureAt [(String, ErrorMsg)] deriving (Read, Show, Eq, Data, Typeable) + +instance Functor FailingAt where + fmap f (SuccessAt a) = SuccessAt (f a) + fmap f (FailureAt e) = FailureAt e + +instance Applicative FailingAt where + pure a = SuccessAt a + (SuccessAt f) <*> (SuccessAt a) = SuccessAt (f a) + (SuccessAt _) <*> (FailureAt errs) = (FailureAt errs) + (FailureAt errs) <*> (SuccessAt _) = (FailureAt errs) + (FailureAt errs1) <*> (FailureAt errs2) = (FailureAt $ errs1++errs2) + +data FormContentType = UrlEncoded | MultiPart deriving (Eq, Show, Read) +newtype Form xml m a = Form { deform :: Env -> State FormState (Collector (m (FailingAt 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, Data, Typeable) +-- data Rect = Rect {rectCols :: Int, rectRows :: Int} + + +instance (Functor m, Monad m) => Functor (Form xml m) where + fmap f (Form a) = Form $ \env -> (fmap . fmapFst3 . liftM . fmap . fmap) f (a env) + +fmapFst f (a, b) = (f a, b) +fmapFst3 f (a, b, c) = (f a, b, c) + +instance (Monad m, Applicative m, Monoid xml) => Applicative (Form xml m) where + pure = pureF + (<*>) = applyF + +lookups :: (Eq a) => a -> [(a, b)] -> [b] +lookups k = map snd . filter ((k ==) . fst) + +-- |Given a function that computes the representation from a fresh +-- name and an (optional) initial value, return a form with that +-- representation. The default value used to create the +-- representation is obtained from the environment that is passed in +-- when the form is run, if possible. The form's value is the value +-- associated with the form's id in the environment produced by +-- running the form. +generalInput :: Monad m => + (String -> Maybe String -> xml) + -> Form xml m (Maybe String) +generalInput i = Form $ \(_errors, vals) -> mkInput vals <$> freshName + where mkInput vals name = (return . result name, + i name (value name vals) {- (err 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 name vals = + case lookup name vals 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. + result name (_, vals) = + case lookup name vals of + Just (Left x) -> SuccessAt (Just x) + Just (Right _) -> FailureAt [(name, name ++ " is a file.")] + Nothing -> SuccessAt Nothing + +input' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String +input' i defaultValue = checkInline (generalInput i') (maybe (Failure ["not in the data"]) Success) (\errs -> id) + where i' n v = i n (fromMaybe (fromMaybe "" defaultValue) v) + +-- | Runs the form state +runFormState :: Monad m + => Env -- ^ A previously filled environment (may be empty) + -> String -- ^ A prefix for the names + -> Form xml m a -- ^ The form + -> (m (FailingAt a), xml, FormContentType) +runFormState e prefix (Form f) = + let (coll, xml, typ) = evalState (f e) (0, prefix) + in (coll e, xml, typ) + +checkInline :: forall m xml a b. (Monad m) => Form xml m a -> (a -> Failing b) -> ([ErrorMsg] -> xml -> xml) -> Form xml m b +checkInline (Form frm) f showError = addError (Form $ fmap checker frm) + where checker :: State FormState (Collector (m (FailingAt a)), xml, FormContentType) -> + State FormState (Collector (m (FailingAt b)), xml, FormContentType) + checker frm = do n <- freshName + fmap (fmapFst3 (fmap . liftM $ (f' n))) frm + addError (Form frm) = + Form $ \env@(errors, val) -> + do name <- currentName + case lookups name errors of + [] -> frm env + errs -> + do (c, x, ct) <- frm env + return (c, showError errs x, ct) + + f' :: String -> FailingAt a -> FailingAt b + f' _ (FailureAt errs) = FailureAt errs + f' loc (SuccessAt a) = + case f a of + (Success b) -> SuccessAt b + (Failure errs) -> FailureAt (map (\err -> (loc, err)) errs) + +-- | Pure xml +xml :: Monad m => xml -> Form xml m () +xml x = Form $ \env -> pure (const $ return $ SuccessAt (), x, UrlEncoded) + +-- | Transform the XML component +plug :: (Monad m) => (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, f x, t) + +fst3 (a, b, c) = a + +-- | Returns Nothing if the result is the empty String. +nothingIfNull :: (Monad m, Functor m) => Form xml m String -> Form xml m (Maybe String) +nothingIfNull frm = nullToMaybe <$> frm + where nullToMaybe [] = Nothing + nullToMaybe x = Just x + +withPrefix :: String -> Form xml m a -> Form xml m a +withPrefix prefix (Form f) = Form $ \env -> (modify (const (0, prefix)) >> f env) + +----------------------------------------------- +-- Private methods +----------------------------------------------- + +freshName :: State FormState String +freshName = do n <- currentName + modify (\(n,prefix) -> (n+1, prefix)) + return n + +currentName :: State FormState String +currentName = gets $ \(n, prefix) -> prefix ++ "input" ++ show n + +changePrefix :: String -> State FormState () +changePrefix p = modify (\(n,_) -> (n, p)) + +orT UrlEncoded x = x +orT x UrlEncoded = x +orT x y = x + +pureF :: (Monad m, Monoid xml) => a -> Form xml m a +pureF v = Form $ \env -> pure (const (return $ SuccessAt v), mempty, UrlEncoded) + +pureM :: (Monad m, Monoid xml) => m a -> Form xml m a +pureM v = Form $ \env -> pure (const (liftM SuccessAt 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) + first v1 v2 e = do x <- v1 e + y <- v2 e + return $ x <*> y + + +{- + +testTxt = + do let (collector1, xmlInitial, _) = runFormState ([], []) "" $ form + res <- collector1 + print res + let errors = case res of + (FailureAt f) -> f + (collector2, xmlError, _) = runFormState (errors, [("input1", (Left "value1")) ]) "" $ form + putStrLn xmlInitial + print =<< collector2 + putStrLn xmlError + where + form :: Form String IO String + form = checkInline inputTxt (\str -> Failure ["nope."]) (\errs str -> "You failed:\n" ++ show errs ++"\n" ++ str) + +-} + + + +-- foo = input Nothing + +{- +-- |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))} +-} +{- +-- | Helper function for genereting input components based forms. +input' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String +input' i defaultValue = generalInput i' `check` maybe (Failure ["not in the data"]) Success + where i' n v = i n (fromMaybe (fromMaybe "" defaultValue) v) +-} + +{- +-- | Apply a predicate to a value and return Success or Failure as appropriate +ensure :: Show a + => (a -> Bool) -- ^ The predicate + -> String -- ^ The error message, in case the predicate fails + -> a -- ^ The value + -> Failing a +ensure p msg x | p x = Success x + | otherwise = Failure [msg] + +ensureM :: (Monad m, Show a) + => (a -> m Bool) -- ^ The predicate + -> String -- ^ The error message, in case the predicate fails + -> a -- ^ The value + -> m (Failing a) +ensureM p msg x = do result <- p x + return $ if result then Success x else Failure [msg] + +-- | Apply multiple predicates to a value, return Success or all the Failure messages +ensures :: Show a + => [(a -> Bool, String)] -- ^ List of predicate functions and error messages, in case the predicate fails + -> a -- ^ The value + -> Failing a +ensures ps x | null errors = Success x + | otherwise = Failure errors + where errors = [ err | (p, err) <- ps, not $ p x ] + +optionalInput :: Monad m => (String -> xml) -> Form xml m (Maybe String) +optionalInput i = generalInput (\ n _ -> i n) +-} +{- +generalInputMulti :: Monad m => + (String -> [String] -> xml) + -> Form xml m [String] +generalInputMulti i = Form $ \env -> mkInput env <$> freshName + where mkInput env name = (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 meanto to represent. + value :: String -> Env -> [String] + value name env = + case partitionEithers $ lookups name env of + (xs,[]) -> map snd 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 :: String -> Env -> Failing [String] + result name env = + case partitionEithers $ lookups name env of + (xs,[]) -> Success (map snd xs) + _ -> 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 = (return . fromRight name . (lookup name), i name, MultiPart) + fromRight n Nothing = Failure [n ++ " is not in the data"] + fromRight n (Just (Right x)) = Success x + fromRight n _ = Failure [n ++ " is not a file"] +-} +{- +-- | Check a condition or convert a result +check :: (Monad m) => Form xml m a -> (a -> Failing b) -> Form xml m b +check (Form frm) f = Form $ fmap checker frm + where checker = fmap $ fmapFst3 (fmap . liftM $ f') + f' (Failure x) = Failure x + f' (Success x) = f x +-} +{- +-- | Monadically check a condition or convert a result +checkM :: (Monad m) => Form xml m a -> (a -> m (Failing b)) -> Form xml m b +checkM (Form frm) f = Form $ fmap checker frm + where checker = fmap $ fmapFst3 (fmap f') + f' v' = do v <- v' + case v of + Failure msg -> return $ Failure msg + Success x -> f x +-} + +{- +-- | 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 -> pure plugin <*> m env <*> n env + where plugin (c1, x1, t1) (c2, x2, t2) = (c3 c1 c2, f x1 x2, t2) + c3 c1 c2 = \ env -> + do a' <- c1 env + b' <- c2 env + case (a', b') of + (Failure a, Failure b) -> return $ Failure (a ++ b) + (Failure a, _) -> return $ Failure a + (_, Failure b) -> return $ Failure b + (Success a, Success b) -> return $ g a b + +-- | Takes a hidden-input field, a form of a and produces a list of a. +-- | +-- | The hidden input field contains a prefix, which is the pointer to the next form. +-- | This form has to have the same variable-names as the original form, but prefixed by the prefix. +-- | +-- | Typically, some client-side code is needed to duplicate the original form and generate a unique prefix. +massInput :: (Monoid xml, Applicative m, Monad m) + => (Form xml m (Maybe String)) + -> Form xml m a + -> ([String] -> xml) + -> Form xml m [a] +massInput h f showErrors = massInputHelper form showErrors + where form = (,) <$> f <*> h + +massInputHelper :: (Monoid xml, Applicative m, Monad m) + => Form xml m (a, Maybe String) -- The form + -> ([String] -> xml) -- How to show errors + -> Form xml m [a] +massInputHelper f showErrors = join f + where join :: (Monoid xml, Applicative m, Monad m) => Form xml m (a, Maybe String) -> Form xml m [a] + join (Form f) = Form $ \env -> start (f env) env + start :: (Monad m) + => State FormState (Collector (m (Failing (a, Maybe String))), xml, FormContentType) + -> Env + -> State FormState (Collector (m (Failing [a])), xml, FormContentType) + start f e = do currentState <- get + --todo use v + let (a, s) = runState f currentState + let (v, xml, t) = a + let v' = evalState (combineIt [] f (Just v)) currentState + put s + return (v', xml, t) + combineIt p f v = do currentState <- get + let x = findLinkedList f currentState + return $ \e -> calculate p f e (maybe (x e) (\x -> x e) v) currentState + calculate p f e v (n,_) = do x <- v + case x of + Success (x, Nothing) -> return $ Success [x] + Success (v, Just cont) -> do if cont `elem` p then return $ Failure ["Infinite loop"] else do + x <- (evalState (combineIt (cont:p) f Nothing) (n, cont)) e + case x of + Success ls -> return $ Success (v:ls) + Failure msg -> return $ Failure msg + Failure msg -> return $ Failure msg + findLinkedList f = fst3 . evalState f +-} hunk ./TextDemo.hs 1 +module Main where + +import Control.Applicative +import Control.Applicative.Error +import Text.Formlets +-- * Test + +data Txt + = Label String + | Input (String, Maybe String) + | ErrorMsg [String] + +input :: Form [Txt] IO (Maybe String) +input = generalInput $ (\n v -> [Input (n, v)]) + +label :: String -> Form [Txt] IO () +label str = xml [Label str] + +runTxt :: Txt -> IO Values +runTxt (Label str) = putStr str >> return [] +runTxt (Input (n, mv)) = + do case mv of + Nothing -> + do putStr ": " + v <- getLine + if null v + then return [] + else return [(n, Left v)] + (Just oldV) -> + do putStr $ "[" ++ oldV ++ "]: " + v <- getLine + if null v + then return [(n, Left oldV)] + else return [(n, Left v)] +runTxt (ErrorMsg errs) = + do putStrLn "{" + mapM putStrLn errs + putStrLn "}" + return [] + +runTxts :: [Txt] -> IO Values +runTxts txts = concat <$> mapM runTxt txts + +form :: Form [Txt] IO (String, String) +form = + (,) <$> username <*> passwords + +username :: Form [Txt] IO String +username = + checkInline (label "Username" *> input) + (\mStr -> + case mStr of + Nothing -> + Failure ["You must enter a username."] + (Just str) + | length str < 6 -> Failure ["Username must be at least 6 charaters long."] + | str == "foobar" -> Failure ["Username can not be foobar."] + | otherwise -> Success str) + (\errs txts -> ErrorMsg errs : txts) + +-- echos password, etc, but it's just a demo. +password :: Form [Txt] IO String +password = + checkInline (label "Password" *> input) + (\mStr -> + case mStr of + Nothing -> Failure ["You must enter a password."] + (Just str) -> Success str) + (\errs txts -> ErrorMsg errs : txts) + +passwords :: Form [Txt] IO String +passwords = + checkInline ((,) <$> password <*> password) + (\(pass1, pass2) -> + if pass1 /= pass2 + then Failure ["Passwords do not match."] + else Success pass1) + (\errs txts -> ErrorMsg errs : txts) + + +main :: IO () +main = + do let (_,txts,_) = runFormState ([],[]) "" $ form + values <- runTxts txts + validateLoop values + where + validateLoop values = + do let (collector, _, _) = runFormState ([],values) "" $ form + res <- collector + case res of + (SuccessAt a) -> print a + (FailureAt errs) -> + do putStrLn "Input failed to validate." + let (_, txts, _) = runFormState (errs, values) "" $ form + values <- runTxts txts + validateLoop values + + hunk ./formlets.cabal 1 +Name: formlets +Version: 0.4.8 +Synopsis: Formlets implemented in Haskell +Description: A modular way to build forms based on applicative functors, as + described in: + . + * Ezra Cooper, Samuel Lindley, Philip Wadler and Jeremy Yallop + \"An idiom's guide to formlets\" + Technical Report, EDI-INF-RR-1263. + +Category: XML, Web, User Interfaces, Text +License: BSD3 +License-file: LICENSE +Copyright: (c) Jeremy Yallop / Tupil +Author: Jeremy Yallop / Chris Eidhof +Maintainer: Chris Eidhof +Exposed-Modules: Text.Formlets, Text.Formlets.Markup, Text.XHtml.Strict.Formlets +Build-Type: Simple +Build-Depends: base, + haskell98, + mtl, + syb, + xhtml, + applicative-extras >= 0.1.3, + bytestring +Extra-Source-Files: README +GHC-options: -threaded -O2 -Wall -Werror -fno-warn-name-shadowing -fno-warn-type-defaults