Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

First commit

  • Loading branch information...
commit dfc97b0fb2078bb5601a5882e58d26c9217f08aa 0 parents
Chris Eidhof authored
30 LICENSE
@@ -0,0 +1,30 @@
+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.
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
208 Text/Formlets.hs
@@ -0,0 +1,208 @@
+module Text.Formlets ( input', inputFile, fmapFst, nothingIfNull
+ , check, ensure, ensures
+ , ensureM, checkM, pureM
+ , runFormState
+ , massInput
+ , xml, plug
+ , withPrefix
+ , Env , Form , Plus (..)
+ , File (..), ContentType (..), FormContentType (..)
+ )
+ where
+
+import Control.Applicative
+import Control.Applicative.Error
+import Control.Applicative.State
+import Data.Maybe (isJust)
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Traversable as T
+
+-- Form stuff
+type Env = [(String, Either String File)]
+type FormState = (Integer, String)
+type Name = String
+type Collector a = Env -> a
+data FormContentType = UrlEncoded | MultiPart deriving (Eq, Show, Read)
+newtype Form xml m a = Form { deform :: Env -> State FormState (Collector (m (Failing a)), m xml, FormContentType) }
+data File = File {content :: BS.ByteString, fileName :: String, contentType :: ContentType} deriving (Eq, Show, Read)
+data ContentType = ContentType { ctType :: String
+ , ctSubtype :: String
+ , ctParameters :: [(String, String)]
+ }
+ deriving (Eq, Show, Read)
+
+class Plus a where
+ zero :: a
+ plus :: a -> a -> a
+
+-- | 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 ]
+
+-- | Helper function for genereting input components based forms.
+input' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String
+input' i defaultValue = Form $ \env -> mkInput env <$> freshName
+ where mkInput env name = (return . fromLeft name . (lookup name),
+ return (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 = Failure [n ++ " is not in the data"]
+ fromLeft n (Just (Left x)) = Success x
+ fromLeft n _ = Failure [n ++ " is a file."]
+
+-- | 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), return (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"]
+
+-- | 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 (Failing a), m xml, FormContentType)
+runFormState e prefix (Form f) = let (coll, xml, typ) = evalState (f e) (0, prefix)
+ in (coll e, xml, typ)
+
+-- | 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
+
+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, Plus xml) => Applicative (Form xml m) where
+ pure = pureF
+ (<*>) = applyF
+
+-- | Pure xml
+xml :: Monad m => xml -> Form xml m ()
+xml x = Form $ \env -> pure (const $ return $ Success (), return x, UrlEncoded)
+
+-- | Transform the XML component
+plug :: (Monad m, Plus xml) => (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)
+
+-- | 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 :: (Plus 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 :: (Plus 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 :: (Plus 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 (v, xml, t) = evalState f currentState
+ let v' = evalState (combineIt [] f (Just v)) currentState
+ 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
+
+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, Plus xml) => a -> Form xml m a
+pureF v = Form $ \env -> pure (const (return $ Success v), return zero, UrlEncoded)
+
+pureM :: (Monad m, Plus xml) => m a -> Form xml m a
+pureM v = Form $ \env -> pure (const (liftM Success v), return zero, UrlEncoded)
+
+applyF :: (Monad m, Applicative m, Plus 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, (plus <$> xml1 <*> xml2), t1 `orT` t2)
+ first v1 v2 e = do x <- v1 e
+ y <- v2 e
+ return $ x <*> y
75 Text/XHtml/Strict/Formlets.hs
@@ -0,0 +1,75 @@
+module Text.XHtml.Strict.Formlets ( input, textarea, password, file
+ , hidden, inputInteger, radio, enumRadio
+ , selectRaw, select
+ , XHtmlForm
+ , module Text.Formlets
+ ) where
+
+import Text.Formlets
+import qualified Text.XHtml.Strict as X
+import Text.XHtml.Strict ((!), (+++), (<<))
+import Control.Applicative
+import Control.Applicative.Error
+import Data.List (elemIndex)
+
+type XHtmlForm m a = Form X.Html m a
+
+instance Plus X.Html where
+ zero = X.noHtml
+ plus = (+++)
+
+-- | An input field with an optional value
+input :: Monad m => Maybe String -> XHtmlForm m String
+input = input' (\n v -> X.textfield n ! [X.value v])
+
+textarea :: Monad m => Maybe String -> XHtmlForm m String
+textarea = input' (\n v -> X.textarea (X.toHtml v) ! [X.name n])
+
+-- | A password field with an optional value
+password :: Monad m => Maybe String -> XHtmlForm m String
+password = input' (\n v -> X.password n ! [X.value v])
+
+-- | A hidden input field
+hidden :: Monad m => Maybe String -> XHtmlForm m String
+hidden = input' X.hidden
+
+-- | A validated integer component
+inputInteger :: Monad m => Maybe Integer -> XHtmlForm m Integer
+inputInteger x = input (fmap show x) `check` asInteger
+
+file :: Monad m => XHtmlForm m File
+file = inputFile X.afile
+
+-- | A radio choice
+radio :: Monad m => [(String, String)] -> Maybe String -> XHtmlForm m String
+radio choices = input' mkRadios -- todo: validate that the result was in the choices
+ where radio n v i = X.input ! [X.thetype "radio", X.name n, X.identifier i, X.theclass "radio", X.value v]
+ mkRadios name selected = X.concatHtml $ map (mkRadio name selected) (zip choices [1..])
+ mkRadio name selected ((value, label), idx) = (radio name value ident) ! attrs
+ +++ X.label (X.toHtml label) ! [X.thefor ident, X.theclass "radio"]
+ where attrs | selected == value = [X.checked]
+ | otherwise = []
+ ident = name ++ "_" ++ show idx
+
+-- | An radio choice for Enums
+enumRadio :: (Monad m, Enum a) => [(a, String)] -> Maybe a -> XHtmlForm m a
+enumRadio values defaultValue = radio (map toS values) (fmap (show . fromEnum) defaultValue)
+ `check` convert `check` tryToEnum
+ where toS = fmapFst (show . fromEnum)
+ convert v = maybeRead' v "Conversion error"
+
+selectRaw :: Monad m => [(String, String)] -> Maybe String -> XHtmlForm m String
+selectRaw choices = input' mkChoices -- todo: validate that the result was in the choices
+ where mkChoices name selected = X.select ! [X.name name] $ X.concatHtml $ map (mkChoice selected) choices
+ mkChoice selected (value, label) = X.option ! (attrs ++ [X.value value]) << label
+ where attrs | selected == value = [X.selected]
+ | otherwise = []
+
+-- | A drop-down for anything that is an instance of Eq
+select :: (Eq a, Monad m) => [(a, String)] -> Maybe a -> XHtmlForm m a
+select ls v = selectRaw (map f $ zip [0..] ls) selected `check` asInt `check` convert
+ where selected = show <$> (v >>= flip elemIndex (map fst ls))
+ f (idx, (_,l)) = (show idx, l)
+ convert i | i >= length ls || i < 0 = Failure ["Out of bounds"]
+ | otherwise = Success $ fst $ ls !! i
+ asInt s = maybeRead' s (s ++ " is not a valid int")
20 formlets.cabal
@@ -0,0 +1,20 @@
+Name: formlets
+Version: 0.4.7
+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.
+ <http://groups.inf.ed.ac.uk/links/formlets/>
+Category: XML, Web, User Interfaces, Text
+License: BSD3
+License-file: LICENSE
+Copyright: (c) Jeremy Yallop / Tupil
+Author: Jeremy Yallop / Chris Eidhof
+Maintainer: Chris Eidhof <ce+hackage@tupil.com>
+Exposed-Modules: Text.Formlets
+ , Text.XHtml.Strict.Formlets
+Build-Type: Simple
+Build-Depends: base, haskell98, mtl, xhtml, applicative-extras, bytestring
Please sign in to comment.
Something went wrong with that request. Please try again.