@@ -3,75 +3,42 @@
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE TemplateHaskell #-}
55{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE UndecidableInstances #-}
76
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
7+module Control.Monad.Validation where
278
28−import Control.Applicative
299import Control.Lens hiding ((.=))
3010import Control.Monad.Base
3111import Control.Monad.Catch
3212import Control.Monad.Except
33−import Control.Monad.Fail
3413import Control.Monad.State.Strict
35−import Control.Monad.Trans.Control
14+import Control.Monad.Trans.Lift.Local
3615import Data.Aeson
3716import Data.Foldable as F
38−import Data.Functor
3917import Data.List as L
4018import Data.Map.Strict as M
19+import Data.Monoid
20+import qualified Data.Semigroup as S
4121import Data.Text as T
4222import Data.Vector as V
4323import Test.QuickCheck
4424
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'.
25+-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
26+-- through ExceptT to single value using Monoid
27+-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
5228newtype ValidationT e m a = ValidationT
5329 { unValidationT :: ExceptT e (StateT e m) a
5430 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
55− , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
56− , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
31+ , MonadBase b )
5732
5833instance MonadTrans (ValidationT e) where
5934 lift = ValidationT . lift . lift
6035
36+instance LiftLocal (ValidationT e) where
37+ liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT
38+
6139-- | 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")])
7340newtype MonoidMap k v = MonoidMap (Map k v)
74− deriving (Eq, Ord, Show, Arbitrary, Foldable)
41+ deriving (Eq, Ord, Show, Arbitrary)
7542
7643makePrisms ''MonoidMap
7744
@@ -83,13 +50,13 @@ instance (Ord k) => At (MonoidMap k v) where
8350 at key = _MonoidMap . at key
8451
8552#if MIN_VERSION_base(4,11,0)
86−instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
53+instance (Ord k, S.Semigroup v) => S.Semigroup (MonoidMap k v) where
8754 (<>) = mmAppend
8855#endif
8956
9057instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
9158 mempty = MonoidMap M.empty
92− mappend = (<>)
59+ mappend = mmAppend
9360
9461instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
9562 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
@@ -99,7 +66,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
9966 , "value" .= v ]
10067
10168instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
102− parseJSON = withArray "MonoidMap" go
69+ parseJSON v = withArray "MonoidMap" go v
10370 where
10471 go arr = do
10572 keyvals <- traverse fromObj arr
@@ -110,66 +77,42 @@ instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
11077 return (key, val)
11178
11279#if MIN_VERSION_base(4,11,0)
113−mmAppend :: (Ord k, Semigroup v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
80+mmAppend :: (Ord k, S.Semigroup v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
81+mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (S.<>) a b
11482#else
11583mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
116−#endif
11784mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
85+#endif
11886
119−-- | Convenient for 'vZoom' as first argument. Will prevent generation
120−-- of map with 'mempty' values.
87+-- | Convenient for 'vZoom' as first artument. Will prevent generation
88+-- of map with 'mempty' values
12189mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
122−mmSingleton k v
123− | v == mempty = mempty
124− | otherwise = MonoidMap . M.singleton k $ v
90+mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k
12591
126−-- | Sets given value to 'mempty'.
92+-- | Set given value to 'mempty'
12793setMempty :: (Monoid s) => ASetter' s a -> a -> s
12894setMempty setter a = set setter a mempty
12995
130−neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a
131−neConcat f a
132− | F.null a = Nothing
133− | otherwise = Just $ F.foldr1 f a
96+memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b
97+memptyWrap b f a
98+ | a == mempty = b
99+ | otherwise = f a
100+
101+-- | If given container is not 'mempty', then use given function to
102+-- append all its elements and return 'Just' result
103+neConcat
104+ :: (Foldable f, Eq (f a), Monoid a, Monoid (f a))
105+ => (a -> a -> a)
106+ -> f a
107+ -> Maybe a
108+neConcat f = memptyWrap Nothing (Just . F.foldl' f mempty)
134109
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
147110textErrors :: [Text] -> Maybe Text
148111textErrors = neConcat (\a b -> a <> ", " <> b)
149112
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)
113+-- | Returns `mempty` instead of error if no warnings was occured. So, your
114+-- error should have `Eq` instance to detect that any error was occured. Returns
115+-- Nothing for second element of tuple if compuration was interruped by 'vError'
173116runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
174117runValidationT (ValidationT m) = do
175118 (res, warnings) <- runStateT (runExceptT m) mempty
@@ -177,25 +120,6 @@ runValidationT (ValidationT m) = do
177120 Left err -> (err <> warnings, Nothing)
178121 Right a -> (warnings, Just a)
179122
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"]
199123runValidationTEither
200124 :: (Monoid e, Eq e, Monad m)
201125 => ValidationT e m a
@@ -206,71 +130,28 @@ runValidationTEither action = do
206130 Just a | err == mempty -> Right a
207131 _ -> Left err
208132
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
228133handleValidationT
229134 :: (Monoid e, Monad m, Eq e)
230135 => (e -> m a)
231136 -> ValidationT e m a
232137 -> m a
233−handleValidationT handler action =
138+handleValidationT handler action = do
234139 runValidationTEither action >>= either handler return
235140
236−-- | Stops further execution and appends the given error.
141+-- | Stops further execution of validation
237142vError :: (Monad m) => e -> ValidationT e m a
238143vError e = ValidationT $ throwError e
239144
240−-- | Does not stop further execution and appends the given warning.
145+-- | Does not stop further execution, append warning to
241146vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
242147vWarning e = ValidationT $ modify' (<> e)
243148
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.
247149vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
248150vErrorL l a = vError $ setMempty l a
249151
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.
253152vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
254153vWarningL l a = vWarning $ setMempty l a
255154
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)
274155vZoom
275156 :: (Monad m, Monoid a, Monoid b)
276157 => (a -> b)
@@ -280,21 +161,11 @@ vZoom up action = do
280161 (err, res) <- lift $ runValidationT action
281162 case res of
282163 Nothing -> vError $ up err
283− Just a -> vWarning (up err) $> a
164+ Just a -> vWarning (up err) *> return a
284165
285−-- | Like 'vZoom' but takes a setter instead of a function.
286166vZoomL
287167 :: (Monad m, Monoid a, Monoid b)
288168 => ASetter' b a
289169 -> ValidationT a m x
290170 -> ValidationT b m x
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
171+vZoomL l action = vZoom (setMempty l) action