git.iko.soy/validationt
on 7f4e7c0 help sign in
validationt/src/Control/Monad/Validation.hs
297 lines 8.5 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE UndecidableInstances #-}
8module 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
28import Control.Applicative
29import Control.Lens hiding ((.=))
30import Control.Monad.Base
31import Control.Monad.Catch
32import Control.Monad.Except
33import Control.Monad.Fail
34import Control.Monad.State.Strict
35import Control.Monad.Trans.Control
36import Data.Aeson
37import Data.Foldable as F
38import Data.Functor
39import Data.List as L
40import Data.Map.Strict as M
41import Data.Monoid
42import Data.Text as T
43import Data.Vector as V
44import Test.QuickCheck
47-- | Collects all thrown warnings in 'StateT' and errors
48-- in 'ExceptT' into a single value using 'Monoid'.
49newtype ValidationT e m a = ValidationT
50 { unValidationT :: ExceptT e (StateT e m) a
51 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
52 , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
53 , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
55instance MonadTrans (ValidationT e) where
56 lift = ValidationT . lift . lift
58-- | Map with 'Monoid' instance which 'mappend' its values
59--
60-- This can be used as the `e` in `ValidationT e m a` to provide different
61-- sets of errors and warnings for different keys.
62--
63-- >>> :{
64-- mconcat
65-- [ MonoidMap $ M.fromList [(1, "foo"), (2, "hello, "), (3, "oh no")]
66-- , MonoidMap $ M.fromList [(1, "bar"), (2, "world")]
67-- ]
68-- :}
69-- MonoidMap (fromList [(1,"foobar"),(2,"hello, world"),(3,"oh no")])
70newtype MonoidMap k v = MonoidMap (Map k v)
71 deriving (Eq, Ord, Show, Arbitrary, Foldable)
73makePrisms ''MonoidMap
75type instance IxValue (MonoidMap k v) = v
76type instance Index (MonoidMap k v) = k
77instance (Ord k) => Ixed (MonoidMap k v) where
78 ix key = _MonoidMap . ix key
79instance (Ord k) => At (MonoidMap k v) where
80 at key = _MonoidMap . at key
82#if MIN_VERSION_base(4,11,0)
83instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
84 (<>) = mmAppend
85#endif
87instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
88 mempty = MonoidMap M.empty
89 mappend = mmAppend
91instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
92 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
93 where
94 toObj (k, v) = object
95 [ "id" .= k
96 , "value" .= v ]
98instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
99 parseJSON = withArray "MonoidMap" go
100 where
101 go arr = do
102 keyvals <- traverse fromObj arr
103 return $ MonoidMap $ M.fromList $ V.toList keyvals
104 fromObj objV = flip (withObject "element of MonoidMap") objV $ \obj -> do
105 key <- obj .: "id"
106 val <- obj .: "value"
107 return (key, val)
109#if MIN_VERSION_base(4,11,0)
110mmAppend :: (Ord k, Semigroup v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
111#else
112mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
113#endif
114mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
116-- | Convenient for 'vZoom' as first argument. Will prevent generation
117-- of map with 'mempty' values.
118mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
119mmSingleton k v
120 | v == mempty = mempty
121 | otherwise = MonoidMap . M.singleton k $ v
123-- | Sets given value to 'mempty'.
124setMempty :: (Monoid s) => ASetter' s a -> a -> s
125setMempty setter a = set setter a mempty
127neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a
128neConcat f a
129 | F.null a = Nothing
130 | otherwise = Just $ F.foldr1 f a
132-- | Returns the strings, concatanated with @", "@ if the list is not empty.
133--
134-- Returns Nothing if the list is empty
135--
136-- >>> textErrors ["foo", "bar"]
137-- Just "foo, bar"
138--
139-- >>> textErrors ["foo"]
140-- Just "foo"
141--
142-- >>> textErrors []
143-- Nothing
144textErrors :: [Text] -> Maybe Text
145textErrors = neConcat (\a b -> a <> ", " <> b)
147-- | Returns 'mempty' instead of error if no warnings have occurred.
148-- Returns 'Nothing' as the second element of tuple if computation was
149-- interrupted by 'vError'.
150--
151-- Returns all concatenated errors and warnings and the result if no
152-- errors have occurred (warnings could have occurred).
153--
154-- >>> :{
155-- runValidationT $ do
156-- vWarning ["warning1"]
157-- vError ["error"]
158-- vWarning ["warning2"]
159-- return 8
160-- :}
161-- (["error","warning1"],Nothing)
162--
163-- >>> :{
164-- runValidationT $ do
165-- vWarning ["warning1"]
166-- vWarning ["warning2"]
167-- return 8
168-- :}
169-- (["warning1","warning2"],Just 8)
170runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
171runValidationT (ValidationT m) = do
172 (res, warnings) <- runStateT (runExceptT m) mempty
173 return $ case res of
174 Left err -> (err <> warnings, Nothing)
175 Right a -> (warnings, Just a)
177-- | Like 'runValidationT' but doesn't return the result
178-- if any warning has occurred.
179--
180-- >>> :{
181-- runValidationTEither $ do
182-- vWarning ["warning1"]
183-- vError ["error"]
184-- vWarning ["warning2"]
185-- return 8
186-- :}
187-- Left ["error","warning1"]
188--
189-- >>> :{
190-- runValidationTEither $ do
191-- vWarning ["warning1"]
192-- vWarning ["warning2"]
193-- return 8
194-- :}
195-- Left ["warning1","warning2"]
196runValidationTEither
197 :: (Monoid e, Eq e, Monad m)
198 => ValidationT e m a
199 -> m (Either e a)
200runValidationTEither action = do
201 (err, res) <- runValidationT action
202 return $ case res of
203 Just a | err == mempty -> Right a
204 _ -> Left err
206-- | Like 'runValidationTEither', but takes an error handler instead of
207-- returning errors and warnings.
208--
209-- >>> :{
210-- handleValidationT (\_ -> return 11) $ do
211-- vWarning ["warning1"]
212-- vError ["error"]
213-- vWarning ["warning2"]
214-- return 8
215-- :}
216-- 11
217--
218-- >>> :{
219-- handleValidationT (\_ -> return 11) $ do
220-- vWarning ["warning1"]
221-- vWarning ["warning2"]
222-- return 8
223-- :}
224-- 11
225handleValidationT
226 :: (Monoid e, Monad m, Eq e)
227 => (e -> m a)
228 -> ValidationT e m a
229 -> m a
230handleValidationT handler action =
231 runValidationTEither action >>= either handler return
233-- | Stops further execution and appends the given error.
234vError :: (Monad m) => e -> ValidationT e m a
235vError e = ValidationT $ throwError e
237-- | Does not stop further execution and appends the given warning.
238vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
239vWarning e = ValidationT $ modify' (<> e)
241-- | Like 'vError' but allows you to use a setter to insert an error somewhere
242-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then
243-- combined with all gathered warnings.
244vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
245vErrorL l a = vError $ setMempty l a
247-- | Like 'vWarning' but allows you to use a setter to insert an error somewhere
248-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then
249-- combined with all gathered warnings.
250vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
251vWarningL l a = vWarning $ setMempty l a
253-- | Allows you apply a transformation to the "e" in "ValidationT e m x".
254--
255-- >>> :{
256--runValidationT . vZoom (Data.Map.singleton "password errors") $ do
257-- vWarning ["warning1"]
258-- vError ["error"]
259-- vWarning ["warning2"]
260-- return 8
261-- :}
262-- (fromList [("password errors",["error","warning1"])],Nothing)
263--
264-- >>> :{
265-- runValidationT . vZoom (Data.Map.singleton "password errors") $ do
266-- vWarning ["warning1"]
267-- vWarning ["warning2"]
268-- return 8
269-- :}
270-- (fromList [("password errors",["warning1","warning2"])],Just 8)
271vZoom
272 :: (Monad m, Monoid a, Monoid b)
273 => (a -> b)
274 -> ValidationT a m x
275 -> ValidationT b m x
276vZoom up action = do
277 (err, res) <- lift $ runValidationT action
278 case res of
279 Nothing -> vError $ up err
280 Just a -> vWarning (up err) $> a
282-- | Like 'vZoom' but takes a setter instead of a function.
283vZoomL
284 :: (Monad m, Monoid a, Monoid b)
285 => ASetter' b a
286 -> ValidationT a m x
287 -> ValidationT b m x
288vZoomL l = vZoom (setMempty l)
290-- | Turn any warnings the have occurred into errors.
291vPromote
292 :: (Monad m, Monoid a, Eq a)
293 => ValidationT a m x
294 -> ValidationT a m x
295vPromote m = do
296 err <- lift $ runValidationTEither m
297 either vError return err