git.iko.soy/typeable/validationt
on master help sign in
swap
a01827123 ahead, 0 behind
.travis.yml+14−27
since splitsnapshots
unifiedsplit
@@ -4,48 +4,35 @@ language: haskell
4git:
4git:
5 depth: 5
5 depth: 5
6
6
7−cabal: "2.4"
8−
9cache:
7cache:
10 directories:
8 directories:
11 - "$HOME/.cabal/store"
9 - "$HOME/.cabal/store"
12 - "$HOME/.stack"
10 - "$HOME/.stack"
13 - "$TRAVIS_BUILD_DIR/.stack-work"
11 - "$TRAVIS_BUILD_DIR/.stack-work"
14
12
15−matrix:
13+jobs:
16 include:
14 include:
17−
15+ - ghc: 8.10.2
18− # Cabal
16+ env: SNAPSHOT="nightly-2020-11-03"
19− - ghc: 8.4.4
17+ - ghc: 8.8.4
18+ env: SNAPSHOT="lts-16.20"
20 - ghc: 8.6.5
19 - ghc: 8.6.5
21−
20+ env: SNAPSHOT="lts-14.22"
22− # Stack
23− - ghc: 8.6.5
21+ - ghc: 8.4.4
24− env: STACK_YAML="$TRAVIS_BUILD_DIR/stack.yaml"
22+ env: SNAPSHOT="lts-12.26"
25
23
26install:
24install:
27 - |
25 - |
28− if [ -z "$STACK_YAML" ]; then
29− ghc --version
30− cabal --version
31− cabal new-update
32− cabal new-build --enable-tests --enable-benchmarks
33− else
34− # install stack
26+ # install stack
35− curl -sSL https://get.haskellstack.org/ | sh
27+ curl -sSL https://get.haskellstack.org/ | sh
36
28
37− # build project with stack
29+ # build project with stack
38− stack --version
30+ stack --version
39− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
31+ stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --resolver=$SNAPSHOT
40− fi
41
32
42script:
33script:
43 - |
34 - |
44− if [ -z "$STACK_YAML" ]; then
45− cabal new-test --enable-tests
46− else
47− stack test --system-ghc
35+ stack test --system-ghc
48− fi
49
36
50notifications:
37notifications:
51 email: false
38 email: false
ChangeLog.md+6
@@ -1,5 +1,11 @@
1# Revision history for validationt
1# Revision history for validationt
2
2
3+## 0.3.0
4+
5+* Added documentation.
6+* Fixed `textErrors` behaviour.
7+* Dropped `transformers-lift` dependency.
8+
3## 0.2.1.0
9## 0.2.1.0
4
10
5* GHC 8.4 support
11* GHC 8.4 support
README.md+2−1
@@ -2,7 +2,8 @@
2
2
3# ValidationT
3# ValidationT
4
4
5−A very small validation data library.
5+A simple data validation library. The main idea is to provide an easy way to
6+validate web form data by aggregating errors for each field.
6
7
7## Usage
8## Usage
8
9
src/Control/Monad/Validation.hs+162−20
@@ -3,37 +3,75 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE UndecidableInstances #-}
6
7
7−module Control.Monad.Validation where
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
8
27
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
35+import Control.Monad.Trans.Control
14import Data.Aeson
36import Data.Aeson
15import Data.Foldable as F
37import Data.Foldable as F
38+import Data.Functor
16import Data.List as L
39import Data.List as L
17import Data.Map.Strict as M
40import Data.Map.Strict as M
18−import Data.Monoid
19import Data.Text as T
41import Data.Text as T
20import Data.Vector as V
42import Data.Vector as V
21import Test.QuickCheck
43import Test.QuickCheck
22
44
45+#if MIN_VERSION_mtl(2,3,0)
46+import Control.Monad
47+import Control.Monad.Fix
48+#endif
49+
23−-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
50+-- | Collects all thrown warnings in 'StateT' and errors
24−-- through ExceptT to single value using Monoid
51+-- in 'ExceptT' into a single value using 'Monoid'.
25−-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
26newtype ValidationT e m a = ValidationT
52newtype ValidationT e m a = ValidationT
27 { unValidationT :: ExceptT e (StateT e m) a
53 { unValidationT :: ExceptT e (StateT e m) a
28 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
54 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
29− , MonadBase b )
55+ , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
56+ , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
30
57
31instance MonadTrans (ValidationT e) where
58instance MonadTrans (ValidationT e) where
32 lift = ValidationT . lift . lift
59 lift = ValidationT . lift . lift
33
60
34-- | Map with 'Monoid' instance which 'mappend' its values
61-- | 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")])
35newtype MonoidMap k v = MonoidMap (Map k v)
73newtype MonoidMap k v = MonoidMap (Map k v)
36− deriving (Eq, Ord, Show, Arbitrary)
74+ deriving (Eq, Ord, Show, Arbitrary, Foldable)
37
75
38makePrisms ''MonoidMap
76makePrisms ''MonoidMap
39
77
@@ -51,7 +89,7 @@ instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
51
89
52instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
90instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
53 mempty = MonoidMap M.empty
91 mempty = MonoidMap M.empty
54− mappend = mmAppend
92+ mappend = (<>)
55
93
56instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
94instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
57 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
95 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
@@ -61,7 +99,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
61 , "value" .= v ]
99 , "value" .= v ]
62
100
63instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
101instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
64− parseJSON v = withArray "MonoidMap" go v
102+ parseJSON = withArray "MonoidMap" go
65 where
103 where
66 go arr = do
104 go arr = do
67 keyvals <- traverse fromObj arr
105 keyvals <- traverse fromObj arr
@@ -78,14 +116,14 @@ mmAppend :: (Ord k, Monoid v) => MonoidMap k v -> MonoidMap k v -> MonoidMap k v
78#endif
116#endif
79mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
117mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b
80
118
81−-- | Convenient for 'vZoom' as first artument. Will prevent generation
119+-- | Convenient for 'vZoom' as first argument. Will prevent generation
82−-- of map with 'mempty' values
120+-- of map with 'mempty' values.
83mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
121mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
84mmSingleton k v
122mmSingleton k v
85 | v == mempty = mempty
123 | v == mempty = mempty
86 | otherwise = MonoidMap . M.singleton k $ v
124 | otherwise = MonoidMap . M.singleton k $ v
87
125
88−-- | Set given value to 'mempty'
126+-- | Sets given value to 'mempty'.
89setMempty :: (Monoid s) => ASetter' s a -> a -> s
127setMempty :: (Monoid s) => ASetter' s a -> a -> s
90setMempty setter a = set setter a mempty
128setMempty setter a = set setter a mempty
91
129
@@ -94,12 +132,44 @@ neConcat f a
94 | F.null a = Nothing
132 | F.null a = Nothing
95 | otherwise = Just $ F.foldr1 f a
133 | otherwise = Just $ F.foldr1 f a
96
134
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
97textErrors :: [Text] -> Maybe Text
147textErrors :: [Text] -> Maybe Text
98textErrors = neConcat (\a b -> a <> ", " <> b)
148textErrors = neConcat (\a b -> a <> ", " <> b)
99
149
100−-- | Returns `mempty` instead of error if no warnings was occured. So, your
150+-- | Returns 'mempty' instead of error if no warnings have occurred.
101−-- error should have `Eq` instance to detect that any error was occured. Returns
102−-- 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'.
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)
103runValidationT :: (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)
104runValidationT (ValidationT m) = do
174runValidationT (ValidationT m) = do
105 (res, warnings) <- runStateT (runExceptT m) mempty
175 (res, warnings) <- runStateT (runExceptT m) mempty
@@ -107,6 +177,25 @@ runValidationT (ValidationT m) = do
107 Left err -> (err <> warnings, Nothing)
177 Left err -> (err <> warnings, Nothing)
108 Right a -> (warnings, Just a)
178 Right a -> (warnings, Just a)
109
179
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"]
110runValidationTEither
199runValidationTEither
111 :: (Monoid e, Eq e, Monad m)
200 :: (Monoid e, Eq e, Monad m)
112 => ValidationT e m a
201 => ValidationT e m a
@@ -117,28 +206,71 @@ runValidationTEither action = do
117 Just a | err == mempty -> Right a
206 Just a | err == mempty -> Right a
118 _ -> Left err
207 _ -> Left err
119
208
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
120handleValidationT
228handleValidationT
121 :: (Monoid e, Monad m, Eq e)
229 :: (Monoid e, Monad m, Eq e)
122 => (e -> m a)
230 => (e -> m a)
123 -> ValidationT e m a
231 -> ValidationT e m a
124 -> m a
232 -> m a
125−handleValidationT handler action = do
233+handleValidationT handler action =
126 runValidationTEither action >>= either handler return
234 runValidationTEither action >>= either handler return
127
235
128−-- | Stops further execution of validation
236+-- | Stops further execution and appends the given error.
129vError :: (Monad m) => e -> ValidationT e m a
237vError :: (Monad m) => e -> ValidationT e m a
130vError e = ValidationT $ throwError e
238vError e = ValidationT $ throwError e
131
239
132−-- | Does not stop further execution, append warning to
240+-- | Does not stop further execution and appends the given warning.
133vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
241vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
134vWarning e = ValidationT $ modify' (<> e)
242vWarning e = ValidationT $ modify' (<> e)
135
243
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.
136vErrorL :: (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
137vErrorL l a = vError $ setMempty l a
248vErrorL l a = vError $ setMempty l a
138
249
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.
139vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
253vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
140vWarningL l a = vWarning $ setMempty l a
254vWarningL l a = vWarning $ setMempty l a
141
255
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)
142vZoom
274vZoom
143 :: (Monad m, Monoid a, Monoid b)
275 :: (Monad m, Monoid a, Monoid b)
144 => (a -> b)
276 => (a -> b)
@@ -148,11 +280,21 @@ vZoom up action = do
148 (err, res) <- lift $ runValidationT action
280 (err, res) <- lift $ runValidationT action
149 case res of
281 case res of
150 Nothing -> vError $ up err
282 Nothing -> vError $ up err
151− Just a -> vWarning (up err) *> return a
283+ Just a -> vWarning (up err) $> a
152
284
285+-- | Like 'vZoom' but takes a setter instead of a function.
153vZoomL
286vZoomL
154 :: (Monad m, Monoid a, Monoid b)
287 :: (Monad m, Monoid a, Monoid b)
155 => ASetter' b a
288 => ASetter' b a
156 -> ValidationT a m x
289 -> ValidationT a m x
157 -> ValidationT b m x
290 -> ValidationT b m x
158−vZoomL l action = vZoom (setMempty l) action
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
stack.yaml+1−1
@@ -15,7 +15,7 @@
15# resolver:
15# resolver:
16# name: custom-snapshot
16# name: custom-snapshot
17# location: "./custom-snapshot.yaml"
17# location: "./custom-snapshot.yaml"
18−resolver: lts-14.21
18+resolver: lts-22.4
19
19
20# User packages to be built.
20# User packages to be built.
21# Various formats can be used as shown in the example below.
21# Various formats can be used as shown in the example below.
test/Doc.hs+1−1
@@ -3,4 +3,4 @@ module Main (main) where
3import Test.DocTest
3import Test.DocTest
4
4
5main :: IO ()
5main :: IO ()
6−main = doctest [ "-XOverloadedStrings", "src" ]
6+main = doctest [ "-XOverloadedStrings", "-isrc", "src" ]
validationt.cabal+18−22
@@ -2,9 +2,11 @@
2-- documentation, see http://haskell.org/cabal/users-guide/
2-- documentation, see http://haskell.org/cabal/users-guide/
3
3
4name: validationt
4name: validationt
5−version: 0.2.1.0
5+version: 0.3.0
6−synopsis: Straightforward validation monad.
6+synopsis: Straightforward validation monad
7−description: Convenient solution for validating web forms and APIs.
7+description:
8+ A simple data validation library. The main idea is to provide an easy way to validate web form data by aggregating errors for each field.
9+ .
8homepage: https://github.com/typeable/validationt
10homepage: https://github.com/typeable/validationt
9license: BSD3
11license: BSD3
10license-file: LICENSE
12license-file: LICENSE
@@ -14,9 +16,12 @@ maintainer: makeit@typeable.io
14category: Control
16category: Control
15build-type: Simple
17build-type: Simple
16extra-source-files: ChangeLog.md
18extra-source-files: ChangeLog.md
19+ , README.md
17cabal-version: >=1.10
20cabal-version: >=1.10
18tested-with: GHC == 8.4.4
21tested-with: GHC == 8.4.4
19 , GHC == 8.6.5
22 , GHC == 8.6.5
23+ , GHC == 8.8.4
24+ , GHC == 8.10.2
20
25
21source-repository head
26source-repository head
22 type: git
27 type: git
@@ -24,14 +29,14 @@ source-repository head
24
29
25library
30library
26 exposed-modules: Control.Monad.Validation
31 exposed-modules: Control.Monad.Validation
27− build-depends: base >=4.8 && < 5
32+ build-depends: base >=4.10 && < 5
28− , aeson >= 1.0
33+ , aeson >=1.0
29 , containers
34 , containers
30− , exceptions
35+ , exceptions >=0.9
31 , lens
36 , lens
32 , monad-control
37 , monad-control
33− , mtl
38+ , mtl <2.3 || >2.3
34− , QuickCheck
39+ , QuickCheck >=2.8.2
35 , text
40 , text
36 , transformers
41 , transformers
37 , transformers-base
42 , transformers-base
@@ -50,21 +55,12 @@ library
50 -Wmissing-export-lists
55 -Wmissing-export-lists
51
56
52test-suite doctest
57test-suite doctest
58+ default-language: Haskell2010
53 type: exitcode-stdio-1.0
59 type: exitcode-stdio-1.0
54 hs-source-dirs: test
60 hs-source-dirs: test
55 ghc-options: -Wall
61 ghc-options: -Wall
56 main-is: Doc.hs
62 main-is: Doc.hs
57− build-depends: base >=4.8 && < 5
63+ build-depends:
58− , aeson >= 1.0
64+ base >= 4.10.0.0
59− , doctest
65+ , doctest >= 0.11.4
60− , containers
66+ , validationt
61− , exceptions
62− , lens
63− , monad-control
64− , mtl
65− , QuickCheck
66− , text
67− , transformers
68− , transformers-base
69− , vector
70− , doctest