By | Chris Done |
At | 2011-06-14 |
Title | Switch to using named-formlet library. |
Description |
Edit file amelie.cabal 33188 → 33188
40 40 ,ConfigFile >= 1.0
41 41 ,feed >= 0.3
42 42 ,download-curl >= 0.1
43 43 ,Diff >= 0.1
44 44 ,css >= 0.1
+ 45 ,named-formlet >= 0.1
… … … … Remove file src/Text/Formlet.hs 33188
- 1 {-# OPTIONS -Wall #-} - 2 {-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} - 3 {-# LANGUAGE ViewPatterns #-} - 4 {-# OPTIONS -fno-warn-name-shadowing -fno-warn-orphans #-} - 5 - 6 -- | Mini formlets library. - 7 - 8 module Text.Formlet - 9 (Formlet(..) - 10 ,formlet - 11 ,req - 12 ,opt - 13 ,wrap - 14 ,integer - 15 ,textInput - 16 ,dropInput - 17 ,areaInput - 18 ,submitInput - 19 ,parse - 20 ,options - 21 ,findOption) where - 22 - 23 import Control.Applicative - 24 import Control.Monad.Error - 25 import Control.Monad.Reader - 26 import Control.Monad.Trans.Error (ErrorList(..)) - 27 import Control.Monad.Writer - 28 import Data.List (find) - 29 import qualified Data.Map as M - 30 import Data.Maybe - 31 import Data.Monoid.Operator - 32 import Data.Text (Text) - 33 import qualified Data.Text as T - 34 import Data.Text.Encoding - 35 import Prelude hiding ((++)) - 36 import Safe (readMay) - 37 import Snap.Types - 38 import Text.Blaze.Html5 as H hiding (map) - 39 import qualified Text.Blaze.Html5.Attributes as A - 40 - 41 -- | A simple formlet data type, fails on first error. - 42 data Formlet a = Formlet { - 43 formletValue :: Params -> Either [Text] a - 44 , formletName :: Maybe Text - 45 , formletHtml :: Params -> Html - 46 } - 47 - 48 -- | Fails on first error, concatenates HTML output. - 49 instance Applicative Formlet where - 50 pure a = Formlet { formletValue = const (return a) - 51 , formletHtml = const mempty - 52 , formletName = Nothing - 53 } - 54 Formlet f n fhtml <*> Formlet v n' vhtml = - 55 Formlet { formletValue = \params -> - 56 case v params of - 57 Right x -> f params <*> Right x - 58 Left e -> case f params <*> Left [] of - 59 Right x -> return x - 60 Left e' -> Left $ e' ++ e - 61 , formletHtml = \params -> fhtml params ++ vhtml params - 62 , formletName = case (n,n') of - 63 (Just{},Just{}) -> Nothing - 64 _ -> n `mplus` n' - 65 } - 66 - 67 -- | Normal instance. - 68 instance Functor Formlet where - 69 fmap f formlet@Formlet{..} = formlet { formletValue = value } - 70 where value = \params -> - 71 case formletValue params of - 72 Left e -> Left e - 73 Right a -> Right (f a) - 74 - 75 -- | The error message for the formlets is a text value. - 76 instance Error Text where noMsg = ""; strMsg = T.pack - 77 instance ErrorList Text where listMsg = return . T.pack - 78 - 79 -- | Make a simple formlet. - 80 formlet :: Text -> (Maybe Text -> Html) -> Formlet Text - 81 formlet name html = - 82 Formlet { formletValue = \inputs -> - 83 case (M.lookup (encodeUtf8 name) inputs) of - 84 Just (value:_) -> return $ decodeUtf8 value - 85 _ -> throwError $ ["missing input: " ++ name] - 86 , formletHtml = \inputs -> - 87 case M.lookup (encodeUtf8 name) inputs of - 88 Just (value:_) -> html (Just $ decodeUtf8 value) - 89 _ -> html Nothing - 90 , formletName = Just name - 91 } - 92 - 93 -- | Make an input required (non-empty text). - 94 req :: Formlet Text -> Formlet Text - 95 req formlet@Formlet{..} = - 96 formlet { formletValue = \inputs -> - 97 case formletValue inputs of - 98 Right v | T.null v -> - 99 throwError $ ["required input" ++ maybe "" (": "++) formletName] - 100 meh -> meh - 101 } - 102 - 103 -- | Make an input optional (empty text is nothing). - 104 opt :: Formlet Text -> Formlet (Maybe Text) - 105 opt formlet@Formlet{..} = - 106 formlet { formletValue = \inputs -> - 107 case formletValue inputs of - 108 Right v | T.null v -> Right Nothing - 109 meh -> Just <$> meh - 110 } - 111 - 112 - 113 - 114 -- | Parse a form value. - 115 parse :: (a -> Either Text b) -> Formlet a -> Formlet b - 116 parse parser formlet@Formlet{..} = - 117 formlet { formletValue = \inputs -> - 118 case formletValue inputs of - 119 Left e -> Left e - 120 Right x -> case parser x of - 121 Right y -> Right y - 122 Left e -> Left [e ++ maybe "" (": "++) formletName] - 123 } - 124 - 125 -- | Integer parser. - 126 integer :: Text -> Either Text Integer - 127 integer (readMay . T.unpack -> Just v) = Right v - 128 integer _ = Left "expected integer" - 129 - 130 -- | Wrap/transform formlet's HTML. - 131 wrap :: (Html -> Html) -> Formlet Text -> Formlet Text - 132 wrap f formlet@Formlet{..} = formlet { formletHtml = f . formletHtml } - 133 - 134 -- | Make a text input formlet with a label. - 135 textInput :: Text -> Text -> Maybe Text -> Formlet Text - 136 textInput name caption def = - 137 formlet name $ \value -> do - 138 p $ H.label $ do - 139 H.span $ toHtml $ caption ++ ": " - 140 input ! A.name (toValue name) - 141 ! A.value (toValue $ fromMaybe "" (value <|> def)) - 142 ! A.class_ "text" - 143 - 144 -- | Make a textarea input with a label. - 145 areaInput :: Text -> Text -> Maybe Text -> Formlet Text - 146 areaInput name caption def = - 147 formlet name $ \value -> do - 148 p $ H.label $ do - 149 H.span $ toHtml $ caption ++ ": " - 150 textarea ! A.name (toValue name) $ - 151 toHtml $ fromMaybe "" (value <|> def) - 152 - 153 -- | Make a drop down input with a label. - 154 dropInput :: [(Text,Text)] -> Text -> Text -> Text -> Formlet Text - 155 dropInput values name caption def = - 156 formlet name $ \value -> do - 157 p $ H.label $ do - 158 H.span $ toHtml $ caption ++ ": " - 159 select ! A.name (toValue name) $ - 160 forM_ values $ \(key,title) -> do - 161 let nonSelected = all ((/=value) . Just . fst) values - 162 defaulting = nonSelected && def == key - 163 selected - 164 | Just key == value = (! A.selected "selected") - 165 | defaulting = (! A.selected "selected") - 166 | otherwise = id - 167 selected $ option ! A.value (toValue key) $ toHtml title - 168 - 169 -- | Make a submit (captioned) button. - 170 submitInput :: Text -> Text -> Html - 171 submitInput name caption = p $ do - 172 p $ H.input ! A.type_ "submit" - 173 ! A.name (toValue name) - 174 ! A.value (toValue caption) - 175 - 176 -- | Make a list of options for use with the option formlet. - 177 options :: (o -> Text) -> (o -> Text) -> [o] -> [(Text,Text)] - 178 options slug caption os = ("","") : map (\o -> (slug o,caption o)) os - 179 - 180 -- | Lookup a real internal id from a slug. - 181 findOption :: (o -> Bool) -> [o] -> (o -> internalid) -> Either Text internalid - 182 findOption pred os field = - 183 case find pred os of - 184 Nothing -> Left "" - 185 Just x -> Right (field x) Add file lib/named-formlet 40960
+ 1 /home/chris/Projects/me/named-formlet/