module Text.Formlets ( input', fmapFst
, check, ensure, ensures
, runFormState
, xml, plug
, Env , Form , Plus (..)
)
where
import Control.Applicative
import Control.Applicative.Error
import Control.Applicative.State
import Data.Maybe (isJust)
class Plus a where
zero :: a
plus :: a -> a -> a
ensure :: Show a
=> (a -> Bool)
-> String
-> a
-> Failing a
ensure p msg x | p x = Success x
| otherwise = Failure [msg]
ensures :: Show a
=> [(a -> Bool, String)]
-> a
-> Failing a
ensures ps x | null errors = Success x
| otherwise = Failure errors
where errors = [ err | (p, err) <- ps, not $ p x ]
input' :: (String -> String -> xml) -> Maybe String -> Form xml String
input' i defaultValue = Form $ \env -> mkInput env <$> freshName
where mkInput env name = (Success . (`queryParam` (name)),
i name (value name env))
value name env = maybe (maybe "" id defaultValue) id (lookup name env)
runFormState :: Env
-> Form xml a
-> (Collector (Failing a), xml)
runFormState e (Form f) = evalState (f e) 0
check :: Form xml a -> (a -> Failing b) -> Form xml b
check (Form frm) f = Form $ \e -> checker (frm e)
where checker = fmap $ fmapFst (f' .)
f' (Failure x) = Failure x
f' (Success x) = f x
type Env = [(String, String)]
type FormState = Names
type Names = Integer
type Name = String
queryParam :: Env -> Name -> String
queryParam env name = case (name `lookup` env) of
Nothing -> error $ "Couldn't find " ++ name
Just x -> x
newtype Form xml a = Form { deform :: Env -> State FormState (Collector (Failing a), xml) }
instance Functor (Form xml) where
fmap f (Form a) = Form $ \env -> (fmap . fmapFst . fmap . fmap) f (a env)
fmapFst f (a, b) = (f a, b)
type Collector a = Env -> a
instance Plus xml => Applicative (Form xml) where
pure = pureF
(<*>) = applyF
pureF :: Plus xml => a -> Form xml a
pureF v = Form $ \env -> pure (const (Success v), zero)
applyF :: Plus xml => Form xml (a -> b) -> Form xml a -> Form xml b
(Form f) `applyF` (Form v) = Form $ \env -> pure combine <*> f env <*> v env
where combine (v1, xml1) (v2, xml2) = (\e -> v1 e <*> v2 e, xml1 `plus` xml2)
xml :: xml -> Form xml ()
xml x = Form $ \env -> pure (const $ Success (), x)
plug :: Plus xml => (xml -> xml) -> Form xml a -> Form xml a
f `plug` (Form m) = Form $ \env -> pure plugin <*> m env
where plugin (c, x) = (c, f x)
freshName :: State FormState String
freshName = do n <- currentName
modify (+1)
return n
currentName :: State FormState String
currentName = gets $ (++) "input" . show