git.iko.soy/typeable/validationt
on master help sign in
Cleaned up code and added documentation
62f5774iko
src/Control/Monad/Validation.hs+147−18
compare with master
unifiedsplit
@@ -3,16 +3,38 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE UndecidableInstances #-}
6
7
7−module Control.Monad.Validation where
8+module Control.Monad.Validation
9+ ( ValidationT(..)
10+ , runValidationT
11+ , runValidationTEither
12+ , handleValidationT
13+ , vError
14+ , vWarning
15+ , vErrorL
16+ , vWarningL
17+ , vZoom
18+ , vZoomL
19+ , mmSingleton
20+ , setMempty
21+ , neConcat
22+ , textErrors
23+ , _MonoidMap
24+ , MonoidMap(..)
25+ ) where
8
26
27+import Control.Applicative
9import Control.Lens hiding ((.=))
28import Control.Lens hiding ((.=))
10import Control.Monad.Base
29import Control.Monad.Base
11import Control.Monad.Catch
30import Control.Monad.Catch
12import Control.Monad.Except
31import Control.Monad.Except
32+import Control.Monad.Fail
13import Control.Monad.State.Strict
33import Control.Monad.State.Strict
34+import Control.Monad.Trans.Control
14import Data.Aeson
35import Data.Aeson
15import Data.Foldable as F
36import Data.Foldable as F
37+import Data.Functor
16import Data.List as L
38import Data.List as L
17import Data.Map.Strict as M
39import Data.Map.Strict as M
18import Data.Monoid
40import Data.Monoid
@@ -20,20 +42,32 @@ import Data.Text as T
20import Data.Vector as V
42import Data.Vector as V
21import Test.QuickCheck
43import Test.QuickCheck
22
44
45+
23−-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
46+-- | Collects all thrown warnings in 'StateT' and errors
24−-- through ExceptT to single value using Monoid
47+-- in 'ExceptT' into a single value using 'Monoid'.
25−-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
26newtype ValidationT e m a = ValidationT
48newtype ValidationT e m a = ValidationT
27 { unValidationT :: ExceptT e (StateT e m) a
49 { unValidationT :: ExceptT e (StateT e m) a
28 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
50 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
29− , MonadBase b )
51+ , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
52+ , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
30
53
31instance MonadTrans (ValidationT e) where
54instance MonadTrans (ValidationT e) where
32 lift = ValidationT . lift . lift
55 lift = ValidationT . lift . lift
33
56
34-- | Map with 'Monoid' instance which 'mappend' its values
57-- | Map with 'Monoid' instance which 'mappend' its values
58+--
59+-- This can be used as the `e` in `ValidationT e m a` to provide different
60+-- sets of errors and warnings for different keys.
61+--
62+-- >>> :{
63+-- mconcat
64+-- [ MonoidMap $ M.fromList [(1, "foo"), (2, "hello, "), (3, "oh no")]
65+-- , MonoidMap $ M.fromList [(1, "bar"), (2, "world")]
66+-- ]
67+-- :}
68+-- MonoidMap (fromList [(1,"foobar"),(2,"hello, world"),(3,"oh no")])
35newtype MonoidMap k v = MonoidMap (Map k v)
69newtype MonoidMap k v = MonoidMap (Map k v)
36− deriving (Eq, Ord, Show, Arbitrary)
70+ deriving (Eq, Ord, Show, Arbitrary, Foldable)
37
71
38makePrisms ''MonoidMap
72makePrisms ''MonoidMap
39
73
@@ -61,7 +95,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
61 , "value" .= v ]
95 , "value" .= v ]
62
96
63instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
97instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
64− parseJSON v = withArray "MonoidMap" go v
98+ parseJSON = withArray "MonoidMap" go
65 where
99 where
66 go arr = do
100 go arr = do
67 keyvals <- traverse fromObj arr
101 keyvals <- traverse fromObj arr
@@ -78,14 +112,14 @@ mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
78#endif
112#endif
79mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
113mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
80
114
81−-- | Convenient for 'vZoom' as first artument. Will prevent generation
115+-- | Convenient for 'vZoom' as first argument. Will prevent generation
82−-- of map with 'mempty' values
116+-- of map with 'mempty' values.
83mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
117mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
84mmSingleton k v
118mmSingleton k v
85 | v == mempty = mempty
119 | v == mempty = mempty
86 | otherwise = MonoidMap . M.singleton k $ v
120 | otherwise = MonoidMap . M.singleton k $ v
87
121
88−-- | Set given value to 'mempty'
122+-- | Sets given value to 'mempty'.
89setMempty :: (Monoid s) => ASetter' s a -> a -> s
123setMempty :: (Monoid s) => ASetter' s a -> a -> s
90setMempty setter a = set setter a mempty
124setMempty setter a = set setter a mempty
91
125
@@ -94,12 +128,44 @@ neConcat f a
94 | F.null a = Nothing
128 | F.null a = Nothing
95 | otherwise = Just $ F.foldr1 f a
129 | otherwise = Just $ F.foldr1 f a
96
130
131+-- | Returns the strings, concatanated with @", "@ if the list is not empty.
132+--
133+-- Returns Nothing if the list is empty
134+--
135+-- >>> textErrors ["foo", "bar"]
136+-- Just "foo, bar"
137+--
138+-- >>> textErrors ["foo"]
139+-- Just "foo"
140+--
141+-- >>> textErrors []
142+-- Nothing
97textErrors :: [Text] -> Maybe Text
143textErrors :: [Text] -> Maybe Text
98textErrors = neConcat (\a b -> a <> ", " <> b)
144textErrors = neConcat (\a b -> a <> ", " <> b)
99
145
100−-- | Returns `mempty` instead of error if no warnings was occured. So, your
146+-- | Returns 'mempty' instead of error if no warnings have occured.
101−-- error should have `Eq` instance to detect that any error was occured. Returns
102−-- Nothing for second element of tuple if compuration was interruped by 'vError'
147+-- Returns 'Nothing' as the second element of tuple if computation was
148+-- interrupted by 'vError'.
149+--
150+-- Returns all concatenated errors and warnings and the result if no
151+-- errors have occured (warnings could have occured).
152+--
153+-- >>> :{
154+-- runValidationT $ do
155+-- vWarning ["warning1"]
156+-- vError ["error"]
157+-- vWarning ["warning2"]
158+-- return 8
159+-- :}
160+-- (["error","warning1"],Nothing)
161+--
162+-- >>> :{
163+-- runValidationT $ do
164+-- vWarning ["warning1"]
165+-- vWarning ["warning2"]
166+-- return 8
167+-- :}
168+-- (["warning1","warning2"],Just 8)
103runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
169runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
104runValidationT (ValidationT m) = do
170runValidationT (ValidationT m) = do
105 (res, warnings) <- runStateT (runExceptT m) mempty
171 (res, warnings) <- runStateT (runExceptT m) mempty
@@ -107,6 +173,25 @@ runValidationT (ValidationT m) = do
107 Left err -> (err <> warnings, Nothing)
173 Left err -> (err <> warnings, Nothing)
108 Right a -> (warnings, Just a)
174 Right a -> (warnings, Just a)
109
175
176+-- | Like 'runValidationT' but doesn't return the result
177+-- if any warning has occured.
178+--
179+-- >>> :{
180+-- runValidationTEither $ do
181+-- vWarning ["warning1"]
182+-- vError ["error"]
183+-- vWarning ["warning2"]
184+-- return 8
185+-- :}
186+-- Left ["error","warning1"]
187+--
188+-- >>> :{
189+-- runValidationTEither $ do
190+-- vWarning ["warning1"]
191+-- vWarning ["warning2"]
192+-- return 8
193+-- :}
194+-- Left ["warning1","warning2"]
110runValidationTEither
195runValidationTEither
111 :: (Monoid e, Eq e, Monad m)
196 :: (Monoid e, Eq e, Monad m)
112 => ValidationT e m a
197 => ValidationT e m a
@@ -117,28 +202,71 @@ runValidationTEither action = do
117 Just a | err == mempty -> Right a
202 Just a | err == mempty -> Right a
118 _ -> Left err
203 _ -> Left err
119
204
205+-- | Like 'runValidationTEither', but takes an error handler instead of
206+-- returning errors and warnings.
207+--
208+-- >>> :{
209+-- handleValidationT (\_ -> return 11) $ do
210+-- vWarning ["warning1"]
211+-- vError ["error"]
212+-- vWarning ["warning2"]
213+-- return 8
214+-- :}
215+-- 11
216+--
217+-- >>> :{
218+-- handleValidationT (\_ -> return 11) $ do
219+-- vWarning ["warning1"]
220+-- vWarning ["warning2"]
221+-- return 8
222+-- :}
223+-- 11
120handleValidationT
224handleValidationT
121 :: (Monoid e, Monad m, Eq e)
225 :: (Monoid e, Monad m, Eq e)
122 => (e -> m a)
226 => (e -> m a)
123 -> ValidationT e m a
227 -> ValidationT e m a
124 -> m a
228 -> m a
125−handleValidationT handler action = do
229+handleValidationT handler action =
126 runValidationTEither action >>= either handler return
230 runValidationTEither action >>= either handler return
127
231
128−-- | Stops further execution of validation
232+-- | Stops further execution and appends the given error.
129vError :: (Monad m) => e -> ValidationT e m a
233vError :: (Monad m) => e -> ValidationT e m a
130vError e = ValidationT $ throwError e
234vError e = ValidationT $ throwError e
131
235
132−-- | Does not stop further execution, append warning to
236+-- | Does not stop further execution and appends the given warning.
133vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
237vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
134vWarning e = ValidationT $ modify' (<> e)
238vWarning e = ValidationT $ modify' (<> e)
135
239
240+-- | Like 'vError' but allows you to use a setter to insert an error somewhere
241+-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then
242+-- combined with all gathered warnings.
136vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
243vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
137vErrorL l a = vError $ setMempty l a
244vErrorL l a = vError $ setMempty l a
138
245
246+-- | Like 'vWarning' but allows you to use a setter to insert an error somewhere
247+-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then
248+-- combined with all gathered warnings.
139vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
249vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
140vWarningL l a = vWarning $ setMempty l a
250vWarningL l a = vWarning $ setMempty l a
141
251
252+-- | Allows you apply a transformation to the "e" in "ValidationT e m x".
253+--
254+-- >>> :{
255+--runValidationT . vZoom (Data.Map.singleton "password errors") $ do
256+-- vWarning ["warning1"]
257+-- vError ["error"]
258+-- vWarning ["warning2"]
259+-- return 8
260+-- :}
261+-- (fromList [("password errors",["error","warning1"])],Nothing)
262+--
263+-- >>> :{
264+-- runValidationT . vZoom (Data.Map.singleton "password errors") $ do
265+-- vWarning ["warning1"]
266+-- vWarning ["warning2"]
267+-- return 8
268+-- :}
269+-- (fromList [("password errors",["warning1","warning2"])],Just 8)
142vZoom
270vZoom
143 :: (Monad m, Monoid a, Monoid b)
271 :: (Monad m, Monoid a, Monoid b)
144 => (a -> b)
272 => (a -> b)
@@ -148,11 +276,12 @@ vZoom up action = do
148 (err, res) <- lift $ runValidationT action
276 (err, res) <- lift $ runValidationT action
149 case res of
277 case res of
150 Nothing -> vError $ up err
278 Nothing -> vError $ up err
151− Just a -> vWarning (up err) *> return a
279+ Just a -> vWarning (up err) $> a
152
280
281+-- | Like 'vZoom' but takes a setter instead of a function.
153vZoomL
282vZoomL
154 :: (Monad m, Monoid a, Monoid b)
283 :: (Monad m, Monoid a, Monoid b)
155 => ASetter' b a
284 => ASetter' b a
156 -> ValidationT a m x
285 -> ValidationT a m x
157 -> ValidationT b m x
286 -> ValidationT b m x
158−vZoomL l action = vZoom (setMempty l) action
287+vZoomL l = vZoom (setMempty l)