module Text.Formlets ( input', inputM', optionalInput, inputFile, fmapFst, nothingIfNull
, check, ensure, ensures
, ensureM, checkM, pureM
, runFormState
, massInput
, xml, plug, plug'
, Env , Form , Formlet
, File (..), ContentType (..), FormContentType (..)
)
where
import Data.Monoid
import Control.Applicative
import Control.Applicative.Error
import Control.Applicative.State
import Data.Maybe (isJust)
import Data.List (intercalate)
import qualified Text.Formlets.FormResult as FR
import qualified Data.ByteString.Lazy as BS
import qualified Data.Traversable as T
type Env = [(String, Either String File)]
type FormState = [Integer]
type Formlet xml m a = Maybe a -> Form xml m a
type Name = String
type S a = State FormState a
type Validator a = S (FR.FormResult a)
data FormContentType = UrlEncoded | MultiPart deriving (Eq, Show, Read)
newtype Form xml m a = Form { deform :: Env -> S (m (Validator 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)
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 = inputM' (\n -> return . i n)
inputM' :: Monad m => (String -> String -> m xml) -> Maybe String -> Form xml m String
inputM' i defaultValue = Form $ \env -> mkInput env <$> freshName
where mkInput env name = (lookupFreshName fromLeft env, 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 = FR.NotAvailable $ n ++ " is not in the data"
fromLeft n (Just (Left x)) = FR.Success x
fromLeft n _ = FR.Failure [n ++ " is a file."]
lookupFreshName f env = return $ (freshName >>= \name -> return $ f name $ (lookup name env))
optionalInput :: Monad m => (String -> xml) -> Form xml m (Maybe String)
optionalInput i = Form $ \env -> mkInput env <$> freshName
where mkInput env name = (lookupFreshName fromLeft env, return (i name), UrlEncoded)
fromLeft n Nothing = FR.Success Nothing
fromLeft n (Just (Left x)) = FR.Success (Just x)
fromLeft n _ = FR.Failure [n ++ " could not be recognized."]
inputFile :: Monad m
=> (String -> xml)
-> Form xml m File
inputFile i = Form $ \env -> mkInput env <$> freshName
where mkInput env name = (lookupFreshName fromRight env, return (i name), MultiPart)
fromRight n Nothing = FR.NotAvailable $ n ++ " is not in the data"
fromRight n (Just (Right x)) = FR.Success x
fromRight n _ = FR.Failure [n ++ " is not a file"]
runFormState :: Monad m
=> Env
-> Form xml m a
-> (m (Failing a), m xml, FormContentType)
runFormState e (Form f) = fmapFst3 (liftM FR.toE . liftM es) (es (f e))
where es = flip evalState [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 (liftM $ liftM $ f')
f' (FR.Failure x) = FR.Failure x
f' (FR.NotAvailable x) = FR.NotAvailable x
f' (FR.Success x) = FR.fromE $ f x
checkM :: (Monad m) => Form xml m a -> (a -> m (Failing b)) -> Form xml m b
checkM (Form frm) f = Form $ \env -> checker f (frm env)
where checker f frm = do currentState <- get
(validator, xml, ct) <- frm
let validator' = transform f validator currentState
return (validator', xml, ct)
transform :: Monad m => (a -> m (Failing b)) -> m (Validator a) -> FormState -> m (Validator b)
transform f source st = x' (x f) source
where x :: Monad m => (a -> m (Failing b)) -> a -> m (Validator b)
x f = fmap (liftM (return . FR.fromE)) f
x' :: Monad m => (a -> m (Validator b)) -> m (Validator a) -> m (Validator b)
x' f a = do a' <- a
let (a'', st') = runState a' st
val <- combine f a''
return (changeState st' val)
changeState :: st -> State st a -> State st a
changeState st' mComp = do result <- mComp
put st'
return result
convert :: Monad m => (a -> m (Failing b)) -> (a -> m (FR.FormResult b))
convert f = fmap (liftM FR.fromE) f
combine :: Monad m => (a -> m (Validator b)) -> FR.FormResult a -> m (Validator b)
combine f x = case x of
(FR.Success x) -> f x
(FR.NotAvailable x) -> return . return $ FR.NotAvailable x
(FR.Failure x) -> return . return $ FR.Failure x
instance (Functor m, Monad m) => Functor (Form xml m) where
fmap f (Form a) = Form $ \env -> (fmap . fmapFst3 . liftM . liftM . 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
xml :: Monad m => xml -> Form xml m ()
xml x = Form $ \env -> pure (return (return $ FR.Success ()), return x, UrlEncoded)
plug :: (Monad m, Monoid 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)
plug' :: (Monad m, Monoid xml1) => (xml1 -> xml2) -> Formlet xml1 m a -> Formlet xml2 m a
plug' transformer formlet value = plug transformer (formlet value)
massInput :: (Applicative m, Monad m, Monoid xml)
=> (Formlet xml m a)
-> Formlet xml m [a]
massInput single defaults = Form $ \env -> do
modify (\x -> 0:0:x)
st <- get
(collector, xml, contentType) <- (deform $ single Nothing) env
resetCurrentLevel
listXml <- generateListXml (single Nothing) env
let newCollector = liftCollector st collector
xml' = case env of
[] -> xml
_ -> listXml
x <- case maybe [] id defaults of
[] -> return (newCollector, xml', contentType)
xs -> do resetCurrentLevel
xmls <- mapM (generateXml single env) xs
let xmls' = sequence xmls
return (newCollector, liftM mconcat xmls', contentType)
modify (tail.tail)
return x
generateXml :: Monad m => (Maybe a -> Form xml m a) -> Env -> a -> S (m xml)
generateXml form env value = do (_, xml, _) <- (deform $ form $ Just value) env
modify nextItem
return xml
resetCurrentLevel :: S ()
resetCurrentLevel = do modify (tail . tail)
modify (\x -> 0:0:x)
generateListXml :: (Applicative m, Monad m, Monoid xml) => Form xml m a -> Env -> S (m xml)
generateListXml form env = do n <- currentName
case lookup n env of
Nothing -> return $ return mempty
Just _ -> do (_, xml, _) <- (deform form) env
modify nextItem
rest <- generateListXml form env
return $ mappend <$> xml <*> rest
liftCollector :: (Monad m) => FormState -> m (Validator a) -> m (Validator [a])
liftCollector st coll = do coll' <- coll
let st' = nextItem st
computeRest = liftCollector st' coll
case evalState coll' st of
FR.Success x -> do rest <- computeRest
return (fmap (fmap (x:)) rest)
FR.NotAvailable x -> return (return (FR.Success []))
FR.Failure x -> do rest <- computeRest
return $ combineFailures x rest
nextItem st = flip execState st $ modify tail >> freshName >> modify (0:) >> get
combineFailures :: [String] -> Validator [a] -> Validator [a]
combineFailures msgs s = do x <- s
case x of
FR.Success x -> return $ FR.Failure msgs
FR.Failure f -> return $ FR.Failure (msgs ++ f)
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
freshName :: S String
freshName = do n <- currentName
modify (changeHead (+1))
return n
changeHead f [] = error "changeHead: there is no head"
changeHead f (x:xs) = (f x) : xs
currentName :: S String
currentName = gets $ \xs -> "fval[" ++ (intercalate "." $ reverse $ map show xs) ++ "]"
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 (return (return $ FR.Success v), return mempty, UrlEncoded)
pureM :: (Monad m, Monoid xml) => m a -> Form xml m a
pureM v = Form $ \env -> pure (liftM (return . FR.Success) v, return 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 :: Monad m
=> m (Validator (a -> b))
-> m (Validator (a ))
-> m (Validator (b ))
first v1 v2 = do x <- v1
y <- v2
return $ do x'' <- x
y'' <- y
return (x'' <*> y'')