@@ -3,37 +3,75 @@
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE TemplateHaskell #-}
55{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE UndecidableInstances #-}
67
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+ , vPromote
20+ , mmSingleton
21+ , setMempty
22+ , neConcat
23+ , textErrors
24+ , _MonoidMap
25+ , MonoidMap(..)
26+ ) where
827
28+import Control.Applicative
929import Control.Lens hiding ((.=))
1030import Control.Monad.Base
1131import Control.Monad.Catch
1232import Control.Monad.Except
33+import Control.Monad.Fail
1334import Control.Monad.State.Strict
35+import Control.Monad.Trans.Control
1436import Data.Aeson
1537import Data.Foldable as F
38+import Data.Functor
1639import Data.List as L
1740import Data.Map.Strict as M
18−import Data.Monoid
1941import Data.Text as T
2042import Data.Vector as V
2143import Test.QuickCheck
2244
23−-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
24−-- through ExceptT to single value using Monoid
25−-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
45+#if MIN_VERSION_mtl(2,3,0)
46+import Control.Monad
47+import Control.Monad.Fix
48+#endif
49+
50+-- | Collects all thrown warnings in 'StateT' and errors
51+-- in 'ExceptT' into a single value using 'Monoid'.
2652newtype ValidationT e m a = ValidationT
2753 { unValidationT :: ExceptT e (StateT e m) a
2854 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
29− , MonadBase b )
55+ , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
56+ , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
3057
3158instance MonadTrans (ValidationT e) where
3259 lift = ValidationT . lift . lift
3360
3461-- | Map with 'Monoid' instance which 'mappend' its values
62+--
63+-- This can be used as the `e` in `ValidationT e m a` to provide different
64+-- sets of errors and warnings for different keys.
65+--
66+-- >>> :{
67+-- mconcat
68+-- [ MonoidMap $ M.fromList [(1, "foo"), (2, "hello, "), (3, "oh no")]
69+-- , MonoidMap $ M.fromList [(1, "bar"), (2, "world")]
70+-- ]
71+-- :}
72+-- MonoidMap (fromList [(1,"foobar"),(2,"hello, world"),(3,"oh no")])
3573newtype MonoidMap k v = MonoidMap (Map k v)
36− deriving (Eq, Ord, Show, Arbitrary)
74+ deriving (Eq, Ord, Show, Arbitrary, Foldable)
3775
3876makePrisms ''MonoidMap
3977
@@ -51,7 +89,7 @@ instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
5189
5290instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
5391 mempty = MonoidMap M.empty
54− mappend = mmAppend
92+ mappend = (<>)
5593
5694instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
5795 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
@@ -61,7 +99,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
6199 , "value" .= v ]
62100
63101instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
64− parseJSON v = withArray "MonoidMap" go v
102+ parseJSON = withArray "MonoidMap" go
65103 where
66104 go arr = do
67105 keyvals <- traverse fromObj arr
@@ -78,28 +116,60 @@ mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
78116#endif
79117mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
80118
81−-- | Convenient for 'vZoom' as first artument. Will prevent generation
82−-- of map with 'mempty' values
119+-- | Convenient for 'vZoom' as first argument. Will prevent generation
120+-- of map with 'mempty' values.
83121mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
84122mmSingleton k v
85123 | v == mempty = mempty
86124 | otherwise = MonoidMap . M.singleton k $ v
87125
88−-- | Set given value to 'mempty'
126+-- | Sets given value to 'mempty'.
89127setMempty :: (Monoid s) => ASetter' s a -> a -> s
90128setMempty setter a = set setter a mempty
91129
92130neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a
93131neConcat f a
94132 | F.null a = Nothing
95− | otherwise = Just $ F.foldl1 f a
133+ | otherwise = Just $ F.foldr1 f a
96134
135+-- | Returns the strings, concatanated with @", "@ if the list is not empty.
136+--
137+-- Returns Nothing if the list is empty
138+--
139+-- >>> textErrors ["foo", "bar"]
140+-- Just "foo, bar"
141+--
142+-- >>> textErrors ["foo"]
143+-- Just "foo"
144+--
145+-- >>> textErrors []
146+-- Nothing
97147textErrors :: [Text] -> Maybe Text
98148textErrors = neConcat (\a b -> a <> ", " <> b)
99149
100−-- | Returns `mempty` instead of error if no warnings was occured. So, your
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'
150+-- | Returns 'mempty' instead of error if no warnings have occurred.
151+-- Returns 'Nothing' as the second element of tuple if computation was
152+-- interrupted by 'vError'.
153+--
154+-- Returns all concatenated errors and warnings and the result if no
155+-- errors have occurred (warnings could have occurred).
156+--
157+-- >>> :{
158+-- runValidationT $ do
159+-- vWarning ["warning1"]
160+-- vError ["error"]
161+-- vWarning ["warning2"]
162+-- return 8
163+-- :}
164+-- (["error","warning1"],Nothing)
165+--
166+-- >>> :{
167+-- runValidationT $ do
168+-- vWarning ["warning1"]
169+-- vWarning ["warning2"]
170+-- return 8
171+-- :}
172+-- (["warning1","warning2"],Just 8)
103173runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
104174runValidationT (ValidationT m) = do
105175 (res, warnings) <- runStateT (runExceptT m) mempty
@@ -107,6 +177,25 @@ runValidationT (ValidationT m) = do
107177 Left err -> (err <> warnings, Nothing)
108178 Right a -> (warnings, Just a)
109179
180+-- | Like 'runValidationT' but doesn't return the result
181+-- if any warning has occurred.
182+--
183+-- >>> :{
184+-- runValidationTEither $ do
185+-- vWarning ["warning1"]
186+-- vError ["error"]
187+-- vWarning ["warning2"]
188+-- return 8
189+-- :}
190+-- Left ["error","warning1"]
191+--
192+-- >>> :{
193+-- runValidationTEither $ do
194+-- vWarning ["warning1"]
195+-- vWarning ["warning2"]
196+-- return 8
197+-- :}
198+-- Left ["warning1","warning2"]
110199runValidationTEither
111200 :: (Monoid e, Eq e, Monad m)
112201 => ValidationT e m a
@@ -117,28 +206,71 @@ runValidationTEither action = do
117206 Just a | err == mempty -> Right a
118207 _ -> Left err
119208
209+-- | Like 'runValidationTEither', but takes an error handler instead of
210+-- returning errors and warnings.
211+--
212+-- >>> :{
213+-- handleValidationT (\_ -> return 11) $ do
214+-- vWarning ["warning1"]
215+-- vError ["error"]
216+-- vWarning ["warning2"]
217+-- return 8
218+-- :}
219+-- 11
220+--
221+-- >>> :{
222+-- handleValidationT (\_ -> return 11) $ do
223+-- vWarning ["warning1"]
224+-- vWarning ["warning2"]
225+-- return 8
226+-- :}
227+-- 11
120228handleValidationT
121229 :: (Monoid e, Monad m, Eq e)
122230 => (e -> m a)
123231 -> ValidationT e m a
124232 -> m a
125−handleValidationT handler action = do
233+handleValidationT handler action =
126234 runValidationTEither action >>= either handler return
127235
128−-- | Stops further execution of validation
236+-- | Stops further execution and appends the given error.
129237vError :: (Monad m) => e -> ValidationT e m a
130238vError e = ValidationT $ throwError e
131239
132−-- | Does not stop further execution, append warning to
240+-- | Does not stop further execution and appends the given warning.
133241vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
134242vWarning e = ValidationT $ modify' (<> e)
135243
244+-- | Like 'vError' but allows you to use a setter to insert an error somewhere
245+-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then
246+-- combined with all gathered warnings.
136247vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
137248vErrorL l a = vError $ setMempty l a
138249
250+-- | Like 'vWarning' but allows you to use a setter to insert an error somewhere
251+-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then
252+-- combined with all gathered warnings.
139253vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
140254vWarningL l a = vWarning $ setMempty l a
141255
256+-- | Allows you apply a transformation to the "e" in "ValidationT e m x".
257+--
258+-- >>> :{
259+--runValidationT . vZoom (Data.Map.singleton "password errors") $ do
260+-- vWarning ["warning1"]
261+-- vError ["error"]
262+-- vWarning ["warning2"]
263+-- return 8
264+-- :}
265+-- (fromList [("password errors",["error","warning1"])],Nothing)
266+--
267+-- >>> :{
268+-- runValidationT . vZoom (Data.Map.singleton "password errors") $ do
269+-- vWarning ["warning1"]
270+-- vWarning ["warning2"]
271+-- return 8
272+-- :}
273+-- (fromList [("password errors",["warning1","warning2"])],Just 8)
142274vZoom
143275 :: (Monad m, Monoid a, Monoid b)
144276 => (a -> b)
@@ -148,11 +280,21 @@ vZoom up action = do
148280 (err, res) <- lift $ runValidationT action
149281 case res of
150282 Nothing -> vError $ up err
151− Just a -> vWarning (up err) *> return a
283+ Just a -> vWarning (up err) $> a
152284
285+-- | Like 'vZoom' but takes a setter instead of a function.
153286vZoomL
154287 :: (Monad m, Monoid a, Monoid b)
155288 => ASetter' b a
156289 -> ValidationT a m x
157290 -> ValidationT b m x
158−vZoomL l action = vZoom (setMempty l) action
291+vZoomL l = vZoom (setMempty l)
292+
293+-- | Turn any warnings the have occurred into errors.
294+vPromote
295+ :: (Monad m, Monoid a, Eq a)
296+ => ValidationT a m x
297+ -> ValidationT a m x
298+vPromote m = do
299+ err <- lift $ runValidationTEither m
300+ either vError return err