digestive-functors-0.8.3.0: src/Text/Digestive/Form/Internal/Field.hs
--------------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Internal embedding of form fields with associated functions.
module Text.Digestive.Form.Internal.Field
( Field (..)
, SomeField (..)
, evalField
, fieldMapView
) where
--------------------------------------------------------------------------------
import Control.Arrow (second)
import Data.Maybe (listToMaybe, mapMaybe, catMaybes)
import Data.Functor ((<$>))
import Data.List (findIndex)
import Data.Text (Text)
--------------------------------------------------------------------------------
import Text.Digestive.Types
--------------------------------------------------------------------------------
-- | A single input field. This usually maps to a single HTML @<input>@ element.
data Field v a where
Singleton :: a -> Field v a
Text :: Text -> Field v Text
-- A list of (group name, [(identifier, (value, view))]).
-- Then we have the default index in the list.
-- The return value has the actual value as well as the index in the list.
Choice :: [(Text, [(Text, (a, v))])] -> [Int] -> Field v [(a, Int)]
Bool :: Bool -> Field v Bool
File :: Field v [FilePath]
--------------------------------------------------------------------------------
instance Show (Field v a) where
show (Singleton _) = "Singleton _"
show (Text t) = "Text " ++ show t
show (Choice _ _) = "Choice _ _"
show (Bool b) = "Bool " ++ show b
show (File) = "File"
--------------------------------------------------------------------------------
-- | Value agnostic "Field"
data SomeField v = forall a. SomeField (Field v a)
--------------------------------------------------------------------------------
-- | Evaluate a field to retrieve a value, using the given method and
-- a list of input.
evalField :: Method -- ^ Get/Post
-> [FormInput] -- ^ Given input
-> Field v a -- ^ Field
-> a -- ^ Result
evalField _ _ (Singleton x) = x
evalField _ (TextInput x : _) (Text _) = x
evalField _ _ (Text x) = x
evalField _ ts@(TextInput _ : _) (Choice ls _) =
let ls' = concat (map snd ls) in
catMaybes $
map (\(TextInput x) ->
(\i -> (fst $ snd $ ls' !! i, i)) <$> findIndex (isSelectedChoice x . fst) ls') ts
evalField Get _ (Choice ls x) =
-- this populates the default values when displaying a view
let ls' = concat (map snd ls) in
map (\i -> (fst $ snd $ ls' !! i, i)) x
evalField Post _ (Choice _ _) = []
evalField Get _ (Bool x) = x
evalField Post (TextInput x : _) (Bool _) = x == "on"
evalField Post _ (Bool _) = False
evalField Post xs File = mapMaybe maybeFile xs
where
maybeFile (FileInput x) = Just x
maybeFile _ = Nothing
evalField _ _ File = []
--------------------------------------------------------------------------------
-- | Map on the error message type of a Field.
fieldMapView :: (v -> w) -> Field v a -> Field w a
fieldMapView _ (Singleton x) = Singleton x
fieldMapView _ (Text x) = Text x
fieldMapView f (Choice xs i) = Choice (map (second func) xs) i
where func = map (second (second f))
fieldMapView _ (Bool x) = Bool x
fieldMapView _ File = File
--------------------------------------------------------------------------------
-- | Determines if the choiceVal is equal to the selectedVal. Works with older
-- versions that submit "foo.bar.2" rather than "2" for Choice fields.
-- > isSelectedChoice "0" "0" == True
-- > isSelectedChoice "foo.bar.0" "0" == True
-- > isSelectedChoice "foo.bar.10" "0" == False
isSelectedChoice :: Text -> Text -> Bool
isSelectedChoice selectedVal choiceVal
| selectedVal == choiceVal = True
| otherwise =
case listToMaybe (reverse $ toPath selectedVal) of
Just x -> x == choiceVal
_ -> False