@@ -3,42 +3,75 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE UndecidableInstances #-}
7−module Control.Monad.Validation where
8+module Control.Monad.Validation
11+ , runValidationTEither
28+import Control.Applicative
9import Control.Lens hiding ((.=))
29import Control.Lens hiding ((.=))
10import Control.Monad.Base
30import Control.Monad.Base
11import Control.Monad.Catch
31import Control.Monad.Catch
12import Control.Monad.Except
32import Control.Monad.Except
33+import Control.Monad.Fail
13import Control.Monad.State.Strict
34import Control.Monad.State.Strict
14−import Control.Monad.Trans.Lift.Local
35+import Control.Monad.Trans.Control
15import Data.Aeson
36import Data.Aeson
16import Data.Foldable as F
37import Data.Foldable as F
17import Data.List as L
39import Data.List as L
18import Data.Map.Strict as M
40import Data.Map.Strict as M
20−import qualified Data.Semigroup as S
21import Data.Text as T
41import Data.Text as T
22import Data.Vector as V
42import Data.Vector as V
23import Test.QuickCheck
43import Test.QuickCheck
45+#if MIN_VERSION_mtl(2,3,0)
47+import Control.Monad.Fix
25−-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
50+-- | Collects all thrown warnings in 'StateT' and errors
26−-- through ExceptT to single value using Monoid
51+-- in 'ExceptT' into a single value using 'Monoid'.
27−-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
28newtype ValidationT e m a = ValidationT
52newtype ValidationT e m a = ValidationT
29 { unValidationT :: ExceptT e (StateT e m) a
53 { unValidationT :: ExceptT e (StateT e m) a
30 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
54 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
31− , MonadBase b )
55+ , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
56+ , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
33instance MonadTrans (ValidationT e) where
58instance MonadTrans (ValidationT e) where
34 lift = ValidationT . lift . lift
59 lift = ValidationT . lift . lift
36−instance LiftLocal (ValidationT e) where
37− liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT
39-- | Map with 'Monoid' instance which 'mappend' its values
61-- | Map with 'Monoid' instance which 'mappend' its values
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.
68+-- [ MonoidMap $ M.fromList [(1, "foo"), (2, "hello, "), (3, "oh no")]
69+-- , MonoidMap $ M.fromList [(1, "bar"), (2, "world")]
72+-- MonoidMap (fromList [(1,"foobar"),(2,"hello, world"),(3,"oh no")])
40newtype MonoidMap k v = MonoidMap (Map k v)
73newtype MonoidMap k v = MonoidMap (Map k v)
41− deriving (Eq, Ord, Show, Arbitrary)
74+ deriving (Eq, Ord, Show, Arbitrary, Foldable)
43makePrisms ''MonoidMap
76makePrisms ''MonoidMap
@@ -50,13 +83,13 @@ instance (Ord k) => At (MonoidMap k v) where
50 at key = _MonoidMap . at key
83 at key = _MonoidMap . at key
52#if MIN_VERSION_base(4,11,0)
85#if MIN_VERSION_base(4,11,0)
53−instance (Ord k, S.Semigroup v) => S.Semigroup (MonoidMap k v) where
86+instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
54 (<>) = mmAppend
87 (<>) = mmAppend
57instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
90instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
58 mempty = MonoidMap M.empty
91 mempty = MonoidMap M.empty
59− mappend = mmAppend
92+ mappend = (<>)
61instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
94instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
62 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
95 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
@@ -66,7 +99,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
66 , "value" .= v ]
99 , "value" .= v ]
68instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
101instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
69− parseJSON v = withArray "MonoidMap" go v
102+ parseJSON = withArray "MonoidMap" go
71 go arr = do
104 go arr = do
72 keyvals <- traverse fromObj arr
105 keyvals <- traverse fromObj arr
@@ -77,42 +110,66 @@ instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
77 return (key, val)
110 return (key, val)
79#if MIN_VERSION_base(4,11,0)
112#if MIN_VERSION_base(4,11,0)
80−mmAppend :: (Ord k, S.Semigroup v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
113+mmAppend :: (Ord k, Semigroup v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
81−mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (S.<>) a b
83mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
115mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
84−mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
117+mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
87−-- | Convenient for 'vZoom' as first artument. Will prevent generation
119+-- | Convenient for 'vZoom' as first argument. Will prevent generation
88−-- of map with 'mempty' values
120+-- of map with 'mempty' values.
89mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
121mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
123+ | v == mempty = mempty
90−mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k
124+ | otherwise = MonoidMap . M.singleton k $ v
92−-- | Set given value to 'mempty'
126+-- | Sets given value to 'mempty'.
93setMempty :: (Monoid s) => ASetter' s a -> a -> s
127setMempty :: (Monoid s) => ASetter' s a -> a -> s
94setMempty setter a = set setter a mempty
128setMempty setter a = set setter a mempty
96−memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b
130+neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a
97−memptyWrap b f a
131+neConcat f a
98− | a == mempty = b
132+ | F.null a = Nothing
99− | otherwise = f a
133+ | otherwise = Just $ F.foldr1 f a
101−-- | If given container is not 'mempty', then use given function to
102−-- append all its elements and return 'Just' result
104− :: (Foldable f, Eq (f a), Monoid a, Monoid (f a))
108−neConcat f = memptyWrap Nothing (Just . F.foldl' f mempty)
135+-- | Returns the strings, concatanated with @", "@ if the list is not empty.
137+-- Returns Nothing if the list is empty
139+-- >>> textErrors ["foo", "bar"]
142+-- >>> textErrors ["foo"]
110textErrors :: [Text] -> Maybe Text
147textErrors :: [Text] -> Maybe Text
111textErrors = neConcat (\a b -> a <> ", " <> b)
148textErrors = neConcat (\a b -> a <> ", " <> b)
113−-- | Returns `mempty` instead of error if no warnings was occured. So, your
150+-- | Returns 'mempty' instead of error if no warnings have occurred.
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'
151+-- Returns 'Nothing' as the second element of tuple if computation was
152+-- interrupted by 'vError'.
154+-- Returns all concatenated errors and warnings and the result if no
155+-- errors have occurred (warnings could have occurred).
158+-- runValidationT $ do
159+-- vWarning ["warning1"]
161+-- vWarning ["warning2"]
164+-- (["error","warning1"],Nothing)
167+-- runValidationT $ do
168+-- vWarning ["warning1"]
169+-- vWarning ["warning2"]
172+-- (["warning1","warning2"],Just 8)
116runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
173runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
117runValidationT (ValidationT m) = do
174runValidationT (ValidationT m) = do
118 (res, warnings) <- runStateT (runExceptT m) mempty
175 (res, warnings) <- runStateT (runExceptT m) mempty
@@ -120,6 +177,25 @@ runValidationT (ValidationT m) = do
120 Left err -> (err <> warnings, Nothing)
177 Left err -> (err <> warnings, Nothing)
121 Right a -> (warnings, Just a)
178 Right a -> (warnings, Just a)
180+-- | Like 'runValidationT' but doesn't return the result
181+-- if any warning has occurred.
184+-- runValidationTEither $ do
185+-- vWarning ["warning1"]
187+-- vWarning ["warning2"]
190+-- Left ["error","warning1"]
193+-- runValidationTEither $ do
194+-- vWarning ["warning1"]
195+-- vWarning ["warning2"]
198+-- Left ["warning1","warning2"]
123runValidationTEither
199runValidationTEither
124 :: (Monoid e, Eq e, Monad m)
200 :: (Monoid e, Eq e, Monad m)
125 => ValidationT e m a
201 => ValidationT e m a
@@ -130,28 +206,71 @@ runValidationTEither action = do
130 Just a | err == mempty -> Right a
206 Just a | err == mempty -> Right a
131 _ -> Left err
207 _ -> Left err
209+-- | Like 'runValidationTEither', but takes an error handler instead of
210+-- returning errors and warnings.
213+-- handleValidationT (\_ -> return 11) $ do
214+-- vWarning ["warning1"]
216+-- vWarning ["warning2"]
222+-- handleValidationT (\_ -> return 11) $ do
223+-- vWarning ["warning1"]
224+-- vWarning ["warning2"]
133handleValidationT
228handleValidationT
134 :: (Monoid e, Monad m, Eq e)
229 :: (Monoid e, Monad m, Eq e)
135 => (e -> m a)
230 => (e -> m a)
136 -> ValidationT e m a
231 -> ValidationT e m a
138−handleValidationT handler action = do
233+handleValidationT handler action =
139 runValidationTEither action >>= either handler return
234 runValidationTEither action >>= either handler return
141−-- | Stops further execution of validation
236+-- | Stops further execution and appends the given error.
142vError :: (Monad m) => e -> ValidationT e m a
237vError :: (Monad m) => e -> ValidationT e m a
143vError e = ValidationT $ throwError e
238vError e = ValidationT $ throwError e
145−-- | Does not stop further execution, append warning to
240+-- | Does not stop further execution and appends the given warning.
146vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
241vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
147vWarning e = ValidationT $ modify' (<> e)
242vWarning e = ValidationT $ modify' (<> e)
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.
149vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
247vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
150vErrorL l a = vError $ setMempty l a
248vErrorL l a = vError $ setMempty l a
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.
152vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
253vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
153vWarningL l a = vWarning $ setMempty l a
254vWarningL l a = vWarning $ setMempty l a
256+-- | Allows you apply a transformation to the "e" in "ValidationT e m x".
259+--runValidationT . vZoom (Data.Map.singleton "password errors") $ do
260+-- vWarning ["warning1"]
262+-- vWarning ["warning2"]
265+-- (fromList [("password errors",["error","warning1"])],Nothing)
268+-- runValidationT . vZoom (Data.Map.singleton "password errors") $ do
269+-- vWarning ["warning1"]
270+-- vWarning ["warning2"]
273+-- (fromList [("password errors",["warning1","warning2"])],Just 8)
156 :: (Monad m, Monoid a, Monoid b)
275 :: (Monad m, Monoid a, Monoid b)
157 => (a -> b)
276 => (a -> b)
@@ -161,11 +280,21 @@ vZoom up action = do
161 (err, res) <- lift $ runValidationT action
280 (err, res) <- lift $ runValidationT action
162 case res of
281 case res of
163 Nothing -> vError $ up err
282 Nothing -> vError $ up err
164− Just a -> vWarning (up err) *> return a
283+ Just a -> vWarning (up err) $> a
285+-- | Like 'vZoom' but takes a setter instead of a function.
167 :: (Monad m, Monoid a, Monoid b)
287 :: (Monad m, Monoid a, Monoid b)
168 => ASetter' b a
288 => ASetter' b a
169 -> ValidationT a m x
289 -> ValidationT a m x
170 -> ValidationT b m x
290 -> ValidationT b m x
171−vZoomL l action = vZoom (setMempty l) action
291+vZoomL l = vZoom (setMempty l)
293+-- | Turn any warnings the have occurred into errors.
295+ :: (Monad m, Monoid a, Eq a)
296+ => ValidationT a m x
297+ -> ValidationT a m x
299+ err <- lift $ runValidationTEither m
300+ either vError return err