module Text.Formlets ( input', inputM', optionalInput, generalInput, generalInputMulti, inputFile, fmapFst, nothingIfNull
, check, ensure, ensures
, ensureM, checkM, pureM
, runFormState
, massInput
, xml, plug, plug2, plug'
, Env , Form , Formlet
, File (..), ContentType (..), FormContentType (..)
, Rect (..), stringRect
)
where
import Data.Generics
import Data.Either (partitionEithers)
import Data.Monoid
import Control.Applicative
import Control.Applicative.Error
import Control.Applicative.State
import Data.Maybe (isJust, fromMaybe)
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), xml, FormContentType) }
data File = File {content :: BS.ByteString, fileName :: String, contentType :: ContentType} deriving (Eq, Show, Read, Data, Typeable)
data ContentType = ContentType { ctType :: String
, ctSubtype :: String
, ctParameters :: [(String, String)]
}
deriving (Eq, Show, Read, Data, Typeable)
data Rect = Rect {rectCols :: Int, rectRows :: Int}
deriving (Eq, Ord, Show, Read, Data, Typeable)
stringRect :: Int -> String -> Rect
stringRect cols s =
Rect {rectCols = cols,
rectRows = foldr (+) 0 (map (\ line -> 1 + (length line) `div` cols) (lines s))}
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 = generalInput' i' fromLeft
where i' n v = i n (fromMaybe (fromMaybe "" defaultValue) v)
fromLeft n Nothing = FR.NotAvailable $ n ++ " is not in the data"
fromLeft n (Just (Left x)) = FR.Success x
fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."]
inputM' :: Monad m => (String -> String -> xml) -> Maybe String -> Form xml m String
inputM' = input'
optionalInput :: Monad m
=> (String -> xml)
-> Form xml m (Maybe String)
optionalInput i = generalInput' (\n _ -> i n) fromLeft
where
fromLeft n Nothing = FR.Success Nothing
fromLeft n (Just (Left x)) = FR.Success (Just x)
fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."]
generalInput :: Monad m =>
(String -> Maybe String -> xml)
-> Form xml m (Maybe String)
generalInput i = generalInput' (\n v -> i n v) fromLeft
where
fromLeft n Nothing = FR.Success Nothing
fromLeft n (Just (Left x)) = FR.Success (Just x)
fromLeft n (Just (Right _)) = FR.Failure [n ++ " is a file, but should not have been."]
lookupFreshName :: (Monad m) => (String -> Maybe (Either String File) -> a) -> Env -> m (State FormState a)
lookupFreshName f env = return $ (freshName >>= \name -> return $ f name $ (lookup name env))
generalInput' :: Monad m =>
(String -> Maybe String -> xml)
-> (String -> Maybe (Either String File) -> FR.FormResult a)
-> Form xml m a
generalInput' i fromLeft = Form $ \env -> mkInput env <$> freshName
where mkInput env name = (lookupFreshName fromLeft env,
i name (value name env), UrlEncoded)
value name env =
case lookup name env of
Just (Left x) -> Just x
Just (Right _) -> error $ name ++ " is a file."
Nothing -> Nothing
generalInputMulti :: forall m xml. Monad m =>
(String -> [String] -> xml)
-> Form xml m [String]
generalInputMulti i = Form $ \env -> mkInput env <$> freshName
where mkInput :: Env -> String -> (m (Validator [String]), xml, FormContentType)
mkInput env name = (return (result env),
i name (value name env), UrlEncoded)
value :: String -> Env -> [String]
value name env =
case partitionEithers $ lookups name env of
(xs,[]) -> xs
_ -> error $ name ++ " is a file."
result :: Env -> Validator [String]
result env =
do name <- freshName
return $ case partitionEithers $ lookups name env of
([],[]) -> FR.NotAvailable $ name ++ " is not in the data."
(xs,[]) -> FR.Success xs
_ -> FR.Failure [name ++ " is a file."]
lookups :: (Eq a) => a -> [(a, b)] -> [b]
lookups k = map snd . filter ((k ==) . fst)
inputFile :: Monad m
=> (String -> xml)
-> Form xml m File
inputFile i = Form $ \env -> mkInput env <$> freshName
where mkInput env name = (lookupFreshName fromRight env, 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), 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 = transform' (makeValidator f) source
where makeValidator :: Monad m => (a -> m (Failing b)) -> a -> m (Validator b)
makeValidator f = fmap (liftM (return . FR.fromE)) f
transform' :: Monad m => (a -> m (Validator b)) -> m (Validator a) -> m (Validator b)
transform' 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 ()), x, UrlEncoded)
plug :: (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)
plug2 :: (Monad m) => (xml -> xml1 -> xml2) -> (a -> b -> Failing c) -> Form xml m a -> Form xml1 m b -> Form xml2 m c
plug2 f g (Form m) (Form n) =
Form $ \env -> plugin <$> m env <*> n env
where
plugin (c1, x1, t1) (c2, x2, t2) = (combineCollectors c1 c2, f x1 x2, t2)
combineCollectors c1 c2 =
do a' <- c1
b' <- c2
return $ combiner <$> a' <*> b'
combiner (FR.Failure a) (FR.Failure b) = FR.Failure (a ++ b)
combiner (FR.Failure a) _ = FR.Failure a
combiner _ (FR.Failure b) = FR.Failure b
combiner (FR.NotAvailable str) _ = FR.NotAvailable str
combiner _ (FR.NotAvailable str) = FR.NotAvailable str
combiner (FR.Success a) (FR.Success b) = FR.fromE (g a b)
plug' :: (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
return (newCollector, mconcat xmls, contentType)
modify (tail.tail)
return x
generateXml :: Monad m => (Maybe a -> Form xml m a) -> Env -> a -> S 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 xml
generateListXml form env = do n <- currentName
case lookup n env of
Nothing -> 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), mempty, UrlEncoded)
pureM :: (Monad m, Monoid xml) => m a -> Form xml m a
pureM v = Form $ \env -> pure (liftM (return . FR.Success) v, 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'')