@@ -3,75 +3,37 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE UndecidableInstances #-}
8−module Control.Monad.Validation
7+module Control.Monad.Validation where
11− , runValidationTEither
28−import Control.Applicative
29import Control.Lens hiding ((.=))
9import Control.Lens hiding ((.=))
30import Control.Monad.Base
10import Control.Monad.Base
31import Control.Monad.Catch
11import Control.Monad.Catch
32import Control.Monad.Except
12import Control.Monad.Except
33−import Control.Monad.Fail
34import Control.Monad.State.Strict
13import Control.Monad.State.Strict
35−import Control.Monad.Trans.Control
36import Data.Aeson
14import Data.Aeson
37import Data.Foldable as F
15import Data.Foldable as F
39import Data.List as L
16import Data.List as L
40import Data.Map.Strict as M
17import Data.Map.Strict as M
41import Data.Text as T
19import Data.Text as T
42import Data.Vector as V
20import Data.Vector as V
43import Test.QuickCheck
21import Test.QuickCheck
45−#if MIN_VERSION_mtl(2,3,0)
47−import Control.Monad.Fix
50−-- | Collects all thrown warnings in 'StateT' and errors
23+-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
51−-- in 'ExceptT' into a single value using 'Monoid'.
24+-- through ExceptT to single value using Monoid
25+-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
52newtype ValidationT e m a = ValidationT
26newtype ValidationT e m a = ValidationT
53 { unValidationT :: ExceptT e (StateT e m) a
27 { unValidationT :: ExceptT e (StateT e m) a
54 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
28 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
55− , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
29+ , MonadBase b )
56− , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
58instance MonadTrans (ValidationT e) where
31instance MonadTrans (ValidationT e) where
59 lift = ValidationT . lift . lift
32 lift = ValidationT . lift . lift
61-- | Map with 'Monoid' instance which 'mappend' its values
34-- | 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")])
73newtype MonoidMap k v = MonoidMap (Map k v)
35newtype MonoidMap k v = MonoidMap (Map k v)
74− deriving (Eq, Ord, Show, Arbitrary, Foldable)
36+ deriving (Eq, Ord, Show, Arbitrary)
76makePrisms ''MonoidMap
38makePrisms ''MonoidMap
@@ -89,7 +51,7 @@ instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
90instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
52instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
91 mempty = MonoidMap M.empty
53 mempty = MonoidMap M.empty
92− mappend = (<>)
54+ mappend = mmAppend
94instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
56instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
95 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
57 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
@@ -99,7 +61,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
99 , "value" .= v ]
61 , "value" .= v ]
101instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
63instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
102− parseJSON = withArray "MonoidMap" go
64+ parseJSON v = withArray "MonoidMap" go v
104 go arr = do
66 go arr = do
105 keyvals <- traverse fromObj arr
67 keyvals <- traverse fromObj arr
@@ -116,60 +78,28 @@ mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
117mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
79mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
119−-- | Convenient for 'vZoom' as first argument. Will prevent generation
81+-- | Convenient for 'vZoom' as first artument. Will prevent generation
120−-- of map with 'mempty' values.
82+-- of map with 'mempty' values
121mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
83mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
122mmSingleton k v
84mmSingleton k v
123 | v == mempty = mempty
85 | v == mempty = mempty
124 | otherwise = MonoidMap . M.singleton k $ v
86 | otherwise = MonoidMap . M.singleton k $ v
126−-- | Sets given value to 'mempty'.
88+-- | Set given value to 'mempty'
127setMempty :: (Monoid s) => ASetter' s a -> a -> s
89setMempty :: (Monoid s) => ASetter' s a -> a -> s
128setMempty setter a = set setter a mempty
90setMempty setter a = set setter a mempty
130neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a
92neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a
131neConcat f a
93neConcat f a
132 | F.null a = Nothing
94 | F.null a = Nothing
133− | otherwise = Just $ F.foldr1 f a
95+ | otherwise = Just $ F.foldl1 f a
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"]
147textErrors :: [Text] -> Maybe Text
97textErrors :: [Text] -> Maybe Text
148textErrors = neConcat (\a b -> a <> ", " <> b)
98textErrors = neConcat (\a b -> a <> ", " <> b)
150−-- | Returns 'mempty' instead of error if no warnings have occurred.
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
151−-- Returns 'Nothing' as the second element of tuple if computation was
102+-- Nothing for second element of tuple if compuration was interruped by 'vError'
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)
173runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
103runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
174runValidationT (ValidationT m) = do
104runValidationT (ValidationT m) = do
175 (res, warnings) <- runStateT (runExceptT m) mempty
105 (res, warnings) <- runStateT (runExceptT m) mempty
@@ -177,25 +107,6 @@ runValidationT (ValidationT m) = do
177 Left err -> (err <> warnings, Nothing)
107 Left err -> (err <> warnings, Nothing)
178 Right a -> (warnings, Just a)
108 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"]
199runValidationTEither
110runValidationTEither
200 :: (Monoid e, Eq e, Monad m)
111 :: (Monoid e, Eq e, Monad m)
201 => ValidationT e m a
112 => ValidationT e m a
@@ -206,71 +117,28 @@ runValidationTEither action = do
206 Just a | err == mempty -> Right a
117 Just a | err == mempty -> Right a
207 _ -> Left err
118 _ -> 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"]
228handleValidationT
120handleValidationT
229 :: (Monoid e, Monad m, Eq e)
121 :: (Monoid e, Monad m, Eq e)
230 => (e -> m a)
122 => (e -> m a)
231 -> ValidationT e m a
123 -> ValidationT e m a
233−handleValidationT handler action =
125+handleValidationT handler action = do
234 runValidationTEither action >>= either handler return
126 runValidationTEither action >>= either handler return
236−-- | Stops further execution and appends the given error.
128+-- | Stops further execution of validation
237vError :: (Monad m) => e -> ValidationT e m a
129vError :: (Monad m) => e -> ValidationT e m a
238vError e = ValidationT $ throwError e
130vError e = ValidationT $ throwError e
240−-- | Does not stop further execution and appends the given warning.
132+-- | Does not stop further execution, append warning to
241vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
133vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
242vWarning e = ValidationT $ modify' (<> e)
134vWarning 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.
247vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
136vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
248vErrorL l a = vError $ setMempty l a
137vErrorL 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.
253vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
139vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
254vWarningL l a = vWarning $ setMempty l a
140vWarningL 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)
275 :: (Monad m, Monoid a, Monoid b)
143 :: (Monad m, Monoid a, Monoid b)
276 => (a -> b)
144 => (a -> b)
@@ -280,21 +148,11 @@ vZoom up action = do
280 (err, res) <- lift $ runValidationT action
148 (err, res) <- lift $ runValidationT action
281 case res of
149 case res of
282 Nothing -> vError $ up err
150 Nothing -> vError $ up err
283− Just a -> vWarning (up err) $> a
151+ Just a -> vWarning (up err) *> return a
285−-- | Like 'vZoom' but takes a setter instead of a function.
287 :: (Monad m, Monoid a, Monoid b)
154 :: (Monad m, Monoid a, Monoid b)
288 => ASetter' b a
155 => ASetter' b a
289 -> ValidationT a m x
156 -> ValidationT a m x
290 -> ValidationT b m x
157 -> ValidationT b m x
291−vZoomL l = vZoom (setMempty l)
158+vZoomL l action = vZoom (setMempty l) action
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