-
Notifications
You must be signed in to change notification settings - Fork 71
/
Form.hs
187 lines (143 loc) · 6.31 KB
/
Form.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
--------------------------------------------------------------------------------
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module Text.Digestive.Form
( Formlet
, Form
, SomeForm (..)
, (.:)
-- * Basic forms
, text
, string
, stringRead
, choice
, choice'
, choiceWith
, choiceWith'
, bool
, file
-- * Optional forms
, optionalText
, optionalString
, optionalStringRead
-- * Validation
, check
, checkM
, validate
, validateM
-- * Lifting forms
, monadic
) where
--------------------------------------------------------------------------------
import Control.Monad (liftM)
import Data.List (findIndex)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
--------------------------------------------------------------------------------
import Text.Digestive.Field
import Text.Digestive.Form.Internal
import Text.Digestive.Ref
import Text.Digestive.Types
import Text.Digestive.Util
--------------------------------------------------------------------------------
type Formlet m v a = Maybe a -> Form m v a
--------------------------------------------------------------------------------
text :: Formlet v m Text
text def = Pure Nothing $ Text $ fromMaybe "" def
--------------------------------------------------------------------------------
string :: Monad m => Formlet v m String
string = fmap T.unpack . text . fmap T.pack
--------------------------------------------------------------------------------
stringRead :: (Monad m, Read a, Show a) => v -> Formlet v m a
stringRead err = transform (readTransform err) . string . fmap show
--------------------------------------------------------------------------------
choice :: (Eq a, Monad m) => [(a, v)] -> Formlet v m a
choice items def = choiceWith (zip makeRefs items) def
--------------------------------------------------------------------------------
-- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you
-- can use this function, which takes an index in the list as default.
choice' :: Monad m => [(a, v)] -> Maybe Int -> Form v m a
choice' items def = choiceWith' (zip makeRefs items) def
--------------------------------------------------------------------------------
-- | Allows you to assign your own values: these values will be used in the
-- resulting HTML instead of the default @[0 ..]@. This fixes some race
-- conditions that might otherwise appear, e.g. if new choice items are added to
-- some database while a user views and submits the form...
choiceWith :: (Eq a, Monad m) => [(Text, (a, v))] -> Formlet v m a
choiceWith items def = choiceWith' items def'
where
def' = def >>= (\d -> findIndex ((== d) . fst . snd) items)
--------------------------------------------------------------------------------
-- | A version of 'choiceWith' for when you have no good 'Eq' instance.
choiceWith' :: Monad m => [(Text, (a, v))] -> Maybe Int -> Form v m a
choiceWith' items def = fmap fst $ Pure Nothing $ Choice items def'
where
def' = fromMaybe 0 def
--------------------------------------------------------------------------------
bool :: Formlet v m Bool
bool = Pure Nothing . Bool . fromMaybe False
--------------------------------------------------------------------------------
file :: Form v m (Maybe FilePath)
file = Pure Nothing File
--------------------------------------------------------------------------------
-- | Validate the results of a form with a simple predicate
--
-- Example:
--
-- > check "Can't be empty" (not . null) (string Nothing)
check :: Monad m
=> v -- ^ Error message (if fail)
-> (a -> Bool) -- ^ Validating predicate
-> Form v m a -- ^ Form to validate
-> Form v m a -- ^ Resulting form
check err = checkM err . (return .)
--------------------------------------------------------------------------------
-- | Version of 'check' which allows monadic validations
checkM :: Monad m => v -> (a -> m Bool) -> Form v m a -> Form v m a
checkM err predicate form = validateM f form
where
f x = do
r <- predicate x
return $ if r then return x else Error err
--------------------------------------------------------------------------------
-- | This is an extension of 'check' that can be used to apply transformations
-- that optionally fail
--
-- Example: taking the first character of an input string
--
-- > head' :: String -> Result String Char
-- > head' [] = Error "Is empty"
-- > head' (x : _) = Success x
-- >
-- > char :: Monad m => Form m String Char
-- > char = validate head' (string Nothing)
--
validate :: Monad m => (a -> Result v b) -> Form v m a -> Form v m b
validate = validateM . (return .)
--------------------------------------------------------------------------------
-- | Version of 'validate' which allows monadic validations
validateM :: Monad m => (a -> m (Result v b)) -> Form v m a -> Form v m b
validateM = transform
--------------------------------------------------------------------------------
optionalText :: Monad m => Maybe Text -> Form v m (Maybe Text)
optionalText def = validate optional (text def)
where
optional t
| T.null t = return Nothing
| otherwise = return $ Just t
--------------------------------------------------------------------------------
optionalString :: Monad m => Maybe String -> Form v m (Maybe String)
optionalString = fmap (fmap T.unpack) . optionalText . fmap T.pack
--------------------------------------------------------------------------------
optionalStringRead :: (Monad m, Read a, Show a)
=> v -> Maybe a -> Form v m (Maybe a)
optionalStringRead err = transform readTransform' . optionalString . fmap show
where
readTransform' (Just s) = liftM (fmap Just) $ readTransform err s
readTransform' Nothing = return (return Nothing)
--------------------------------------------------------------------------------
readTransform :: (Monad m, Read a) => v -> String -> m (Result v a)
readTransform err = return . maybe (Error err) return . readMaybe