@@ -1,73 +1,43 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE GeneralizedNewtypeDeriving #-}
32{-# LANGUAGE OverloadedStrings #-}
43{-# LANGUAGE TemplateHaskell #-}
54{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE UndecidableInstances #-}
75
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
6+module Control.Monad.Validation where
267
27−import Control.Applicative
288import Control.Lens hiding ((.=))
299import Control.Monad.Base
3010import Control.Monad.Catch
3111import Control.Monad.Except
32−import Control.Monad.Fail
3312import Control.Monad.State.Strict
34−import Control.Monad.Trans.Control
13+import Control.Monad.Trans.Lift.Local
3514import Data.Aeson
3615import Data.Foldable as F
37−import Data.Functor
3816import Data.List as L
3917import Data.Map.Strict as M
4018import Data.Monoid
19+import qualified Data.Semigroup as S
4120import Data.Text as T
4221import Data.Vector as V
4322import Test.QuickCheck
4423
45−
46−-- | Collects all thrown warnings in 'StateT' and errors
47−-- in 'ExceptT' into a single value using 'Monoid'.
24+-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
25+-- through ExceptT to single value using Monoid
26+-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
4827newtype ValidationT e m a = ValidationT
4928 { unValidationT :: ExceptT e (StateT e m) a
5029 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
51− , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
52− , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
30+ , MonadBase b )
5331
5432instance MonadTrans (ValidationT e) where
5533 lift = ValidationT . lift . lift
5634
35+instance LiftLocal (ValidationT e) where
36+ liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT
37+
5738-- | 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")])
6939newtype MonoidMap k v = MonoidMap (Map k v)
70− deriving (Eq, Ord, Show, Arbitrary, Foldable)
40+ deriving (Eq, Ord, Show, Arbitrary)
7141
7242makePrisms ''MonoidMap
7343
@@ -78,14 +48,14 @@ instance (Ord k) => Ixed (MonoidMap k v) where
7848instance (Ord k) => At (MonoidMap k v) where
7949 at key = _MonoidMap . at key
8050
81−#if MIN_VERSION_base(4,11,0)
82−instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
83− (<>) = mmAppend
84−#endif
51+instance (Ord k, S.Semigroup v) => S.Semigroup (MonoidMap k v) where
52+ (MonoidMap a) <> (MonoidMap b) =
53+ MonoidMap $ M.unionWith (S.<>) a b
8554
8655instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
8756 mempty = MonoidMap M.empty
88− mappend = mmAppend
57+ mappend (MonoidMap a) (MonoidMap b) =
58+ MonoidMap $ M.unionWith (<>) a b
8959
9060instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
9161 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
@@ -95,7 +65,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
9565 , "value" .= v ]
9666
9767instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
98− parseJSON = withArray "MonoidMap" go
68+ parseJSON v = withArray "MonoidMap" go v
9969 where
10070 go arr = do
10171 keyvals <- traverse fromObj arr
@@ -105,67 +75,35 @@ instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
10575 val <- obj .: "value"
10676 return (key, val)
10777
108−#if MIN_VERSION_base(4,11,0)
109−mmAppend :: (Ord k, Semigroup v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
110−#else
111−mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
112−#endif
113−mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
114−
115−-- | Convenient for 'vZoom' as first argument. Will prevent generation
116−-- of map with 'mempty' values.
78+-- | Convenient for 'vZoom' as first artument. Will prevent generation
79+-- of map with 'mempty' values
11780mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
118−mmSingleton k v
119− | v == mempty = mempty
120− | otherwise = MonoidMap . M.singleton k $ v
81+mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k
12182
122−-- | Sets given value to 'mempty'.
83+-- | Set given value to 'mempty'
12384setMempty :: (Monoid s) => ASetter' s a -> a -> s
12485setMempty setter a = set setter a mempty
12586
126−neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a
127−neConcat f a
128− | F.null a = Nothing
129− | otherwise = Just $ F.foldr1 f a
87+memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b
88+memptyWrap b f a
89+ | a == mempty = b
90+ | otherwise = f a
91+
92+-- | If given container is not 'mempty', then use given function to
93+-- append all its elements and return 'Just' result
94+neConcat
95+ :: (Foldable f, Eq (f a), Monoid a, Monoid (f a))
96+ => (a -> a -> a)
97+ -> f a
98+ -> Maybe a
99+neConcat f = memptyWrap Nothing (Just . F.foldl' f mempty)
130100
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
143101textErrors :: [Text] -> Maybe Text
144102textErrors = neConcat (\a b -> a <> ", " <> b)
145103
146−-- | Returns 'mempty' instead of error if no warnings have occured.
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)
104+-- | Returns `mempty` instead of error if no warnings was occured. So, your
105+-- error should have `Eq` instance to detect that any error was occured. Returns
106+-- Nothing for second element of tuple if compuration was interruped by 'vError'
169107runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
170108runValidationT (ValidationT m) = do
171109 (res, warnings) <- runStateT (runExceptT m) mempty
@@ -173,25 +111,6 @@ runValidationT (ValidationT m) = do
173111 Left err -> (err <> warnings, Nothing)
174112 Right a -> (warnings, Just a)
175113
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"]
195114runValidationTEither
196115 :: (Monoid e, Eq e, Monad m)
197116 => ValidationT e m a
@@ -202,71 +121,28 @@ runValidationTEither action = do
202121 Just a | err == mempty -> Right a
203122 _ -> Left err
204123
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
224124handleValidationT
225125 :: (Monoid e, Monad m, Eq e)
226126 => (e -> m a)
227127 -> ValidationT e m a
228128 -> m a
229−handleValidationT handler action =
129+handleValidationT handler action = do
230130 runValidationTEither action >>= either handler return
231131
232−-- | Stops further execution and appends the given error.
132+-- | Stops further execution of validation
233133vError :: (Monad m) => e -> ValidationT e m a
234134vError e = ValidationT $ throwError e
235135
236−-- | Does not stop further execution and appends the given warning.
136+-- | Does not stop further execution, append warning to
237137vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
238138vWarning e = ValidationT $ modify' (<> e)
239139
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.
243140vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
244141vErrorL l a = vError $ setMempty l a
245142
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.
249143vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
250144vWarningL l a = vWarning $ setMempty l a
251145
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)
270146vZoom
271147 :: (Monad m, Monoid a, Monoid b)
272148 => (a -> b)
@@ -276,12 +152,11 @@ vZoom up action = do
276152 (err, res) <- lift $ runValidationT action
277153 case res of
278154 Nothing -> vError $ up err
279− Just a -> vWarning (up err) $> a
155+ Just a -> vWarning (up err) *> return a
280156
281−-- | Like 'vZoom' but takes a setter instead of a function.
282157vZoomL
283158 :: (Monad m, Monoid a, Monoid b)
284159 => ASetter' b a
285160 -> ValidationT a m x
286161 -> ValidationT b m x
287−vZoomL l = vZoom (setMempty l)
162+vZoomL l action = vZoom (setMempty l) action