module Text.Digestive.View
( View (..)
, getForm
, postForm
, subView
, absolutePath
, viewEncType
, fieldInputText
, fieldInputChoice
, fieldInputBool
, fieldInputFile
, errors
, childErrors
) where
import Control.Arrow (second)
import Data.List (findIndex, isPrefixOf)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Text.Digestive.Field
import Text.Digestive.Form.Encoding
import Text.Digestive.Form.Internal
import Text.Digestive.Types
data View v = forall a m. Monad m => View
{ viewName :: Text
, viewContext :: Path
, viewForm :: Form v m a
, viewInput :: [(Path, FormInput)]
, viewErrors :: [(Path, v)]
, viewMethod :: Method
}
instance Functor View where
fmap f (View name ctx form input errs method) = View
name ctx (formMapView f form) input (map (second f) errs) method
instance Show v => Show (View v) where
show (View name ctx form input errs method) =
"View " ++ show name ++ " " ++ show ctx ++ " " ++ show form ++ " " ++
show input ++ " " ++ show errs ++ " " ++ show method
getForm :: Monad m => Text -> Form v m a -> View v
getForm name form = View name [] form [] [] Get
postForm :: Monad m => Text -> Form v m a -> Env m -> m (View v, Maybe a)
postForm name form env = eval Post env' form >>= \(r, inp) -> return $ case r of
Error errs -> (View name [] form inp errs Post, Nothing)
Success x -> (View name [] form inp [] Post, Just x)
where
env' = env . (name :)
subView :: Text -> View v -> View v
subView ref (View name ctx form input errs method) =
View name (ctx ++ path) form input errs method
where
path = toPath ref
absolutePath :: Text -> View v -> Path
absolutePath ref view@(View name _ _ _ _ _) = name : viewPath ref view
viewPath :: Text -> View v -> Path
viewPath ref (View _ ctx _ _ _ _) = ctx ++ toPath ref
viewEncType :: View v -> FormEncType
viewEncType (View _ _ form _ _ _) = formEncType form
lookupInput :: Path -> [(Path, FormInput)] -> [FormInput]
lookupInput path = map snd . filter ((== path) . fst)
fieldInputText :: forall v. Text -> View v -> Text
fieldInputText ref view@(View _ _ form input _ method) =
queryField path form eval'
where
path = viewPath ref view
givenInput = lookupInput path input
eval' :: Field v b -> Text
eval' field = case field of
Text t -> evalField method givenInput (Text t)
_ -> ""
fieldInputChoice :: forall v. Text -> View v -> ([v], Int)
fieldInputChoice ref view@(View _ _ form input _ method) =
queryField path form eval'
where
path = viewPath ref view
givenInput = lookupInput path input
eval' :: Field v b -> ([v], Int)
eval' field = case field of
Choice xs i ->
let x = evalField method givenInput (Choice xs i)
idx = fromMaybe 0 $ findIndex (== x) (map fst xs)
in (map snd xs, idx)
_ -> ([], 0)
fieldInputBool :: forall v. Text -> View v -> Bool
fieldInputBool ref view@(View _ _ form input _ method) =
queryField path form eval'
where
path = viewPath ref view
givenInput = lookupInput path input
eval' :: Field v b -> Bool
eval' field = case field of
Bool x -> evalField method givenInput (Bool x)
_ -> False
fieldInputFile :: forall v. Text -> View v -> Maybe FilePath
fieldInputFile ref view@(View _ _ form input _ method) =
queryField path form eval'
where
path = viewPath ref view
givenInput = lookupInput path input
eval' :: Field v b -> Maybe FilePath
eval' field = case field of
File -> evalField method givenInput File
_ -> Nothing
errors :: Text -> View v -> [v]
errors ref view = map snd $ filter ((== viewPath ref view) . fst) $
viewErrors view
childErrors :: Text -> View v -> [v]
childErrors ref view = map snd $
filter ((viewPath ref view `isPrefixOf`) . fst) $ viewErrors view