--------------------------------------------------------------------------------
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.Digestive.View
( View (..)
-- * Obtaining a view
, getForm
, postForm
-- * Operations on views
, subView
, subViews
-- * Querying a view
-- ** Low-level
, absolutePath
, absoluteRef
-- ** Form encoding
, viewEncType
-- ** Input
, fieldInputText
, fieldInputChoice
, fieldInputBool
, fieldInputFile
-- ** Errors
, errors
, childErrors
) where
--------------------------------------------------------------------------------
import Control.Arrow (second)
import Control.Monad.Identity (Identity)
import Data.List (isPrefixOf)
import Data.Text (Text)
import qualified Data.Text as T
--------------------------------------------------------------------------------
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 :: FormTree Identity 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 -> m (View v)
getForm name form = do
form' <- toFormTree form
return $ View name [] form' [] [] Get
--------------------------------------------------------------------------------
postForm :: Monad m => Text -> Form v m a -> Env m -> m (View v, Maybe a)
postForm name form env = do
form' <- toFormTree form
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
--------------------------------------------------------------------------------
-- | Returns all immediate subviews of a view
subViews :: View v -> [View v]
subViews view@(View _ _ form _ _ _) =
[subView r view | r <- go (SomeForm form)]
where
go (SomeForm f) = case getRef f of
Nothing -> [r | c <- children f, r <- go c]
Just r -> [r]
--------------------------------------------------------------------------------
-- | Determine an absolute 'Path' for a field in the form
absolutePath :: Text -> View v -> Path
absolutePath ref view@(View name _ _ _ _ _) = name : viewPath ref view
--------------------------------------------------------------------------------
-- | Determine an absolute path and call 'fromPath' on it. Useful if you're
-- writing a view library...
absoluteRef :: Text -> View v -> Text
absoluteRef ref view = fromPath $ absolutePath ref view
--------------------------------------------------------------------------------
-- | Internal version of 'absolutePath' which does not take the form name into
-- account
viewPath :: Text -> View v -> Path
viewPath ref (View _ ctx _ _ _ _) = ctx ++ toPath ref
--------------------------------------------------------------------------------
viewEncType :: View v -> FormEncType
viewEncType (View _ _ form _ _ _) = formTreeEncType 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)
f -> error $ T.unpack ref ++ ": expected (Text _), " ++
"but got: (" ++ show f ++ ")"
--------------------------------------------------------------------------------
-- | Returns a list of (identifier, view, selected?)
fieldInputChoice :: forall v. Text -> View v -> [(Text, v, Bool)]
fieldInputChoice ref view@(View _ _ form input _ method) =
queryField path form eval'
where
path = viewPath ref view
givenInput = lookupInput path input
eval' :: Field v b -> [(Text, v, Bool)]
eval' field = case field of
Choice xs didx ->
let idx = snd $ evalField method givenInput (Choice xs didx)
in map (\(i, (k, (_, v))) -> (k, v, i == idx)) $ zip [0 ..] xs
f -> error $ T.unpack ref ++ ": expected (Choice _ _), " ++
"but got: (" ++ show f ++ ")"
--------------------------------------------------------------------------------
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)
f -> error $ T.unpack ref ++ ": expected (Bool _), " ++
"but got: (" ++ show f ++ ")"
--------------------------------------------------------------------------------
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
f -> error $ T.unpack ref ++ ": expected (File), " ++
"but got: (" ++ show f ++ ")"
--------------------------------------------------------------------------------
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