module Text.Formlets ( input', inputFile, fmapFst
, check, ensure, ensures
, ensureM, checkM, pureM
, runFormState
, xml, plug
, 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
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)), 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
ensure :: Show a
=> (a -> Bool)
-> String
-> a
-> Failing a
ensure p msg x | p x = Success x
| otherwise = Failure [msg]
ensureM :: (Monad m, Show a)
=> (a -> m Bool)
-> String
-> a
-> m (Failing a)
ensureM p msg x = do result <- p x
return $ if result then Success x else 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' :: 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),
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."]
inputFile :: Monad m => (String -> xml) -> 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"]
runFormState :: Monad m
=> Env
-> Form xml m a
-> (Collector (m (Failing a)), xml, FormContentType)
runFormState e (Form f) = evalState (f e) (0, "")
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
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
pureF :: (Monad m, Plus xml) => a -> Form xml m a
pureF v = Form $ \env -> pure (const (return $ Success v), zero, UrlEncoded)
pureM :: (Monad m, Plus xml) => m a -> Form xml m a
pureM v = Form $ \env -> pure (const (liftM Success v), 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 -> pure combine <*> f env <*> v env
where combine (v1, xml1, t1) (v2, xml2, t2) = (first v1 v2, xml1 `plus` xml2, t1 `orT` t2)
first v1 v2 e = do x <- v1 e
y <- v2 e
return $ x <*> y
orT UrlEncoded x = x
orT x UrlEncoded = x
orT x y = x
xml :: Monad m => xml -> Form xml m ()
xml x = Form $ \env -> pure (const $ return $ Success (), x, UrlEncoded)
plug :: 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, f x, t)
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