module Text.Digestive.Forms
( FormInput (..)
, inputString
, inputText
, inputRead
, inputBool
, inputChoice
, inputChoices
, inputFile
, inputList
) where
import Control.Applicative ((<$>))
import Control.Monad (mplus)
import Control.Monad.State (put, get)
import Data.Monoid (Monoid, mappend, mconcat)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T (pack, empty)
import Text.Digestive.Common
import Text.Digestive.Types
import Text.Digestive.Result
import Text.Digestive.Transform
class FormInput i f | i -> f where
getInputString :: i -> Maybe String
getInputString = listToMaybe . getInputStrings
getInputStrings :: i -> [String]
getInputText :: i -> Maybe Text
getInputText = listToMaybe . getInputTexts
getInputTexts :: i -> [Text]
getInputTexts = map T.pack . getInputStrings
getInputFile :: i -> Maybe f
inputString :: (Monad m, Functor m, FormInput i f)
=> (FormId -> Maybe String -> v)
-> Maybe String
-> Form m i e v String
inputString = input toView toResult
where
toView _ inp def = (getInputString =<< inp) `mplus` def
toResult = Ok . fromMaybe "" . (getInputString =<<)
inputText :: (Monad m, Functor m, FormInput i f)
=> (FormId -> Maybe Text -> v)
-> Maybe Text
-> Form m i e v Text
inputText = input toView toResult
where
toView _ inp def = (getInputText =<< inp) `mplus` def
toResult = Ok . fromMaybe T.empty . (getInputText =<<)
inputRead :: (Monad m, Functor m, FormInput i f, Read a, Show a)
=> (FormId -> Maybe String -> v)
-> e
-> Maybe a
-> Form m i e v a
inputRead cons' error' def = inputString cons' (fmap show def)
`transform` transformRead error'
inputBool :: (Monad m, Functor m, FormInput i f)
=> (FormId -> Bool -> v)
-> Bool
-> Form m i e v Bool
inputBool = input toView toResult
where
toView isInput inp def
| isInput = readBool (getInputString =<< inp)
| otherwise = def
toResult inp = Ok $ readBool (getInputString =<< inp)
readBool (Just x) = not $ null x
readBool _ = False
inputChoice :: (Monad m, Functor m, FormInput i f, Monoid v, Eq a)
=> (FormId -> String -> Bool -> a -> v)
-> a
-> [a]
-> Form m i e v a
inputChoice toView defaultInput choices = Form $ do
inputKey <- fromMaybe "" . (getInputString =<<) <$> getFormInput
id' <- getFormId
let
inp = fromMaybe defaultInput $ lookup inputKey $ zip (ids id') choices
view' = mconcat $ zipWith (toView' id' inp) (ids id') choices
return (View (const view'), Ok inp)
where
ids id' = map (((show id' ++ "-") ++) . show) [1 .. length choices]
toView' id' inp key x = toView id' key (inp == x) x
inputChoices :: (Monad m, Functor m, FormInput i f, Monoid v, Eq a)
=> (FormId -> String -> Bool -> a -> v)
-> [a]
-> [a]
-> Form m i e v [a]
inputChoices toView defaults choices = Form $ do
inputKeys <- maybe [] getInputStrings <$> getFormInput
id' <- getFormId
formInput <- isFormInput
let
inps = if formInput
then mapMaybe (\inputKey -> lookup inputKey $ zip (ids id') choices) inputKeys
else defaults
view' = mconcat $ zipWith (toView' id' inps) (ids id') choices
return (View (const view'), Ok inps)
where
ids id' = map (((show id' ++ "-") ++) . show) [1 .. length choices]
toView' id' inps key x = toView id' key (x `elem` inps) x
inputFile :: (Monad m, Functor m, FormInput i f)
=> (FormId -> v)
-> Form m i e v (Maybe f)
inputFile viewCons = input toView toResult viewCons' ()
where
toView _ _ _ = ()
toResult inp = Ok $ getInputFile =<< inp
viewCons' id' () = viewCons id'
up :: Monad m => Int -> FormState m i ()
up n = do
FormRange s _ <- get
put $ unitRange $ mapId ((!!n) . iterate tail) s
down :: Monad m => Int -> FormState m i ()
down n = do
FormRange s _ <- get
put $ unitRange $ mapId ((!!n) . iterate (0:)) s
inputList :: (Monad m, Monoid v)
=> Formlet m i e v Int
-> Formlet m i e v a
-> Formlet m i e v [a]
inputList countField single defaults = Form $ do
let defCount = maybe 1 length defaults
(countView,countRes) <- unForm $ countField (Just defCount)
let countFromForm = getResult countRes
count = fromMaybe defCount countFromForm
fs = replicate count single
forms = zipWith ($) fs $ maybe (maybe [Nothing] (map Just) defaults)
(flip replicate Nothing)
countFromForm
down 2
list <- mapM (incAfter . unForm) forms
up 2
return ( countView `mappend` (mconcat $ map fst list)
, combineResults [] [] $ map snd list)
where
incAfter k = do
res <- k
up 1 >> incState >> down 1
return res
combineResults es os [] =
case es of
[] -> Ok $ reverse os
_ -> Error es
combineResults es os (r:rs) =
case r of
Error es' -> combineResults (es ++ es') os rs
Ok o -> combineResults es (o:os) rs