git.iko.soy/validationt
on master help sign in
swap
c943f9229 ahead, 0 behind
.travis.ymlnew file+38
since splitsnapshots
unifiedsplit
@@ -0,0 +1,38 @@
1+sudo: true
2+language: haskell
3+
4+git:
5+ depth: 5
6+
7+cache:
8+ directories:
9+ - "$HOME/.cabal/store"
10+ - "$HOME/.stack"
11+ - "$TRAVIS_BUILD_DIR/.stack-work"
12+
13+jobs:
14+ include:
15+ - ghc: 8.6.5
16+ env: SNAPSHOT="lts-14.22"
17+ - ghc: 8.6.4
18+ env: SNAPSHOT="lts-13.19"
19+ - ghc: 8.6.3
20+ env: SNAPSHOT="lts-13.11"
21+ - ghc: 8.4.4
22+ env: SNAPSHOT="lts-12.26"
23+
24+install:
25+ - |
26+ # install stack
27+ curl -sSL https://get.haskellstack.org/ | sh
28+
29+ # build project with stack
30+ stack --version
31+ stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --resolver=$SNAPSHOT
32+
33+script:
34+ - |
35+ stack test --system-ghc
36+
37+notifications:
38+ email: false
ChangeLog.md+16−2
@@ -1,5 +1,19 @@
1# Revision history for validationt
1# Revision history for validationt
2
2
3−## 0.1.0.0 -- YYYY-mm-dd
3+## 0.3.0
4
4
5−* First version. Released on an unsuspecting world.
5+* Added documentation.
6+* Fixed `textErrors` behaviour.
7+* Dropped `transformers-lift` dependency.
8+
9+## 0.2.1.0
10+
11+* GHC 8.4 support
12+
13+## 0.2.0.0
14+
15+* Fixes
16+
17+## 0.1.0.0
18+
19+* Initial release
README.mdnew file+75
@@ -0,0 +1,75 @@
1+![Travis CI Badge](https://img.shields.io/travis/typeable/validationt)
2+
3+# ValidationT
4+
5+A very small validation data library.
6+
7+## Usage
8+
9+Suppose you want to validate some data from the user. Say, that the password adheres to some rules.
10+
11+You might do something like this:
12+
13+```haskell
14+validatePassword :: Monad m => String -> ValidationT [String] m ()
15+validatePassword password = do
16+ vLength password
17+ vAlpha password
18+ vNum password
19+ where
20+ vLength p = when (length p < 8)
21+ $ vWarning ["The password should be at least 8 characters long."]
22+ vAlpha p = unless (any isAlpha p)
23+ $ vWarning ["The password should contain at least one alphabetic character."]
24+ vNum p = unless (any isDigit p)
25+ $ vWarning ["The password should contain at least one numeric character."]
26+```
27+
28+`ValidationT e m a` essentially just gathers the errors thrown by `vWarning`.
29+
30+```haskell
31+vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
32+```
33+
34+`vWarning` `mappend`s the given `e` to the already collected errors. This is why the warnings are contained inside a list.
35+
36+There is also `vError`. The only difference between `vWarning` and `vError` is that `vError` stops further execution (and further collection of errors and warnings).
37+
38+You would use the validation like this:
39+
40+```haskell
41+main :: IO ()
42+main = do
43+ password <- getLine
44+ result <- runValidationTEither . validatePassword $ password
45+ putStrLn $ case result of
46+ Left errs -> unlines err
47+ Right () -> "You are fine."
48+```
49+
50+You could, of course, do more complicated things like use `vWarningL` and `vErrorL` to add an error to a `mempty` structure, which gets `mappend`ed with other errors.
51+
52+The library comes with a `MonoidMap` `newtype` wrapper around `Map`, which `mappend`s the values themselves on conflict. This can be useful if you have a multiple points of failure and you want to distinguich between them -- validating a username and a password for example:
53+
54+```haskell
55+data Piece
56+ = Password
57+ | UserName
58+ deriving (Eq, Show, Ord)
59+
60+validatePassword :: Monad m => String -> ValidationT (MonoidMap Piece [String]) m ()
61+validatePassword password = do
62+ vLength password
63+ vAlpha password
64+ vNum password
65+ where
66+ warning = mmSingleton UserName
67+ vLength p = when (length p < 8)
68+ $ warning ["The password should be at least 8 characters long."]
69+ vAlpha p = unless (any isAlpha p)
70+ $ warning ["The password should contain at least one alphabetic character."]
71+ vNum p = unless (any isDigit p)
72+ $ warning ["The password should contain at least one numeric character."]
73+```
74+
75+(`mmSingleton` is a covenience initializer for `MonoidMap`.)
src/Control/Monad/Validation.hs+167−42
@@ -1,43 +1,73 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE UndecidableInstances #-}
5
7
6−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+ , mmSingleton
20+ , setMempty
21+ , neConcat
22+ , textErrors
23+ , _MonoidMap
24+ , MonoidMap(..)
25+ ) where
7
26
27+import Control.Applicative
8import Control.Lens hiding ((.=))
28import Control.Lens hiding ((.=))
9import Control.Monad.Base
29import Control.Monad.Base
10import Control.Monad.Catch
30import Control.Monad.Catch
11import Control.Monad.Except
31import Control.Monad.Except
32+import Control.Monad.Fail
12import Control.Monad.State.Strict
33import Control.Monad.State.Strict
13−import Control.Monad.Trans.Lift.Local
34+import Control.Monad.Trans.Control
14import Data.Aeson
35import Data.Aeson
15import Data.Foldable as F
36import Data.Foldable as F
37+import Data.Functor
16import Data.List as L
38import Data.List as L
17import Data.Map.Strict as M
39import Data.Map.Strict as M
18import Data.Monoid
40import Data.Monoid
19−import qualified Data.Semigroup as S
20import Data.Text as T
41import Data.Text as T
21import Data.Vector as V
42import Data.Vector as V
22import Test.QuickCheck
43import Test.QuickCheck
23
44
45+
24−-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
46+-- | Collects all thrown warnings in 'StateT' and errors
25−-- through ExceptT to single value using Monoid
47+-- in 'ExceptT' into a single value using 'Monoid'.
26−-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
27newtype ValidationT e m a = ValidationT
48newtype ValidationT e m a = ValidationT
28 { unValidationT :: ExceptT e (StateT e m) a
49 { unValidationT :: ExceptT e (StateT e m) a
29 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
50 } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
30− , MonadBase b )
51+ , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant
52+ , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )
31
53
32instance MonadTrans (ValidationT e) where
54instance MonadTrans (ValidationT e) where
33 lift = ValidationT . lift . lift
55 lift = ValidationT . lift . lift
34
56
35−instance LiftLocal (ValidationT e) where
36− liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT
37−
38-- | Map with 'Monoid' instance which 'mappend' its values
57-- | 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")])
39newtype MonoidMap k v = MonoidMap (Map k v)
69newtype MonoidMap k v = MonoidMap (Map k v)
40− deriving (Eq, Ord, Show, Arbitrary)
70+ deriving (Eq, Ord, Show, Arbitrary, Foldable)
41
71
42makePrisms ''MonoidMap
72makePrisms ''MonoidMap
43
73
@@ -48,14 +78,14 @@ instance (Ord k) => Ixed (MonoidMap k v) where
48instance (Ord k) => At (MonoidMap k v) where
78instance (Ord k) => At (MonoidMap k v) where
49 at key = _MonoidMap . at key
79 at key = _MonoidMap . at key
50
80
81+#if MIN_VERSION_base(4,11,0)
51−instance (Ord k, S.Semigroup v) => S.Semigroup (MonoidMap k v) where
82+instance (Ord k, Semigroup v) => Semigroup (MonoidMap k v) where
52− (MonoidMap a) <> (MonoidMap b) =
83+ (<>) = mmAppend
53− MonoidMap $ M.unionWith (S.<>) a b
84+#endif
54
85
55instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
86instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
56 mempty = MonoidMap M.empty
87 mempty = MonoidMap M.empty
57− mappend (MonoidMap a) (MonoidMap b) =
88+ mappend = mmAppend
58− MonoidMap $ M.unionWith (<>) a b
59
89
60instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
90instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
61 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
91 toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
@@ -65,7 +95,7 @@ instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
65 , "value" .= v ]
95 , "value" .= v ]
66
96
67instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
97instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
68− parseJSON v = withArray "MonoidMap" go v
98+ parseJSON = withArray "MonoidMap" go
69 where
99 where
70 go arr = do
100 go arr = do
71 keyvals <- traverse fromObj arr
101 keyvals <- traverse fromObj arr
@@ -75,35 +105,67 @@ instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
75 val <- obj .: "value"
105 val <- obj .: "value"
76 return (key, val)
106 return (key, val)
77
107
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+
78−-- | Convenient for 'vZoom' as first artument. Will prevent generation
115+-- | Convenient for 'vZoom' as first argument. Will prevent generation
79−-- of map with 'mempty' values
116+-- of map with 'mempty' values.
80mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
117mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
118+mmSingleton k v
119+ | v == mempty = mempty
81−mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k
120+ | otherwise = MonoidMap . M.singleton k $ v
82
121
83−-- | Set given value to 'mempty'
122+-- | Sets given value to 'mempty'.
84setMempty :: (Monoid s) => ASetter' s a -> a -> s
123setMempty :: (Monoid s) => ASetter' s a -> a -> s
85setMempty setter a = set setter a mempty
124setMempty setter a = set setter a mempty
86
125
87−memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b
126+neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a
88−memptyWrap b f a
127+neConcat f a
89− | a == mempty = b
128+ | F.null a = Nothing
90− | otherwise = f a
129+ | otherwise = Just $ F.foldr1 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)
100
130
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
101textErrors :: [Text] -> Maybe Text
143textErrors :: [Text] -> Maybe Text
102textErrors = neConcat (\a b -> a <> ", " <> b)
144textErrors = neConcat (\a b -> a <> ", " <> b)
103
145
104−-- | Returns `mempty` instead of error if no warnings was occured. So, your
146+-- | Returns 'mempty' instead of error if no warnings have occured.
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'
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)
107runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
169runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
108runValidationT (ValidationT m) = do
170runValidationT (ValidationT m) = do
109 (res, warnings) <- runStateT (runExceptT m) mempty
171 (res, warnings) <- runStateT (runExceptT m) mempty
@@ -111,6 +173,25 @@ runValidationT (ValidationT m) = do
111 Left err -> (err <> warnings, Nothing)
173 Left err -> (err <> warnings, Nothing)
112 Right a -> (warnings, Just a)
174 Right a -> (warnings, Just a)
113
175
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"]
114runValidationTEither
195runValidationTEither
115 :: (Monoid e, Eq e, Monad m)
196 :: (Monoid e, Eq e, Monad m)
116 => ValidationT e m a
197 => ValidationT e m a
@@ -121,28 +202,71 @@ runValidationTEither action = do
121 Just a | err == mempty -> Right a
202 Just a | err == mempty -> Right a
122 _ -> Left err
203 _ -> Left err
123
204
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
124handleValidationT
224handleValidationT
125 :: (Monoid e, Monad m, Eq e)
225 :: (Monoid e, Monad m, Eq e)
126 => (e -> m a)
226 => (e -> m a)
127 -> ValidationT e m a
227 -> ValidationT e m a
128 -> m a
228 -> m a
129−handleValidationT handler action = do
229+handleValidationT handler action =
130 runValidationTEither action >>= either handler return
230 runValidationTEither action >>= either handler return
131
231
132−-- | Stops further execution of validation
232+-- | Stops further execution and appends the given error.
133vError :: (Monad m) => e -> ValidationT e m a
233vError :: (Monad m) => e -> ValidationT e m a
134vError e = ValidationT $ throwError e
234vError e = ValidationT $ throwError e
135
235
136−-- | Does not stop further execution, append warning to
236+-- | Does not stop further execution and appends the given warning.
137vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
237vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
138vWarning e = ValidationT $ modify' (<> e)
238vWarning e = ValidationT $ modify' (<> e)
139
239
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.
140vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
243vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
141vErrorL l a = vError $ setMempty l a
244vErrorL l a = vError $ setMempty l a
142
245
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.
143vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
249vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
144vWarningL l a = vWarning $ setMempty l a
250vWarningL l a = vWarning $ setMempty l a
145
251
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)
146vZoom
270vZoom
147 :: (Monad m, Monoid a, Monoid b)
271 :: (Monad m, Monoid a, Monoid b)
148 => (a -> b)
272 => (a -> b)
@@ -152,11 +276,12 @@ vZoom up action = do
152 (err, res) <- lift $ runValidationT action
276 (err, res) <- lift $ runValidationT action
153 case res of
277 case res of
154 Nothing -> vError $ up err
278 Nothing -> vError $ up err
155− Just a -> vWarning (up err) *> return a
279+ Just a -> vWarning (up err) $> a
156
280
281+-- | Like 'vZoom' but takes a setter instead of a function.
157vZoomL
282vZoomL
158 :: (Monad m, Monoid a, Monoid b)
283 :: (Monad m, Monoid a, Monoid b)
159 => ASetter' b a
284 => ASetter' b a
160 -> ValidationT a m x
285 -> ValidationT a m x
161 -> ValidationT b m x
286 -> ValidationT b m x
162−vZoomL l action = vZoom (setMempty l) action
287+vZoomL l = vZoom (setMempty l)
stack.yaml+2−2
@@ -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-8.14
18+resolver: lts-14.21
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.
@@ -63,4 +63,4 @@ extra-package-dbs: []
63# extra-lib-dirs: [/path/to/dir]
63# extra-lib-dirs: [/path/to/dir]
64#
64#
65# Allow a newer minor version of GHC than the snapshot specifies
65# Allow a newer minor version of GHC than the snapshot specifies
66−# compiler-check: newer-minor
66+# compiler-check: newer-minor
test/Doc.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest [ "-XOverloadedStrings", "-isrc", "src" ]
validationt.cabal+31−7
@@ -2,10 +2,10 @@
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.0.0
5+version: 0.3.0
6+synopsis: Straightforward validation monad.
6−synopsis: Straightforward validation monad. Convenient solution for validating web forms and APIs.
7+description: Convenient solution for validating web forms and APIs.
7−-- description:
8−homepage: typeable.io
8+homepage: https://github.com/typeable/validationt
9license: BSD3
9license: BSD3
10license-file: LICENSE
10license-file: LICENSE
11author: Typeable.io contributors
11author: Typeable.io contributors
@@ -15,6 +15,12 @@ category: Control
15build-type: Simple
15build-type: Simple
16extra-source-files: ChangeLog.md
16extra-source-files: ChangeLog.md
17cabal-version: >=1.10
17cabal-version: >=1.10
18+tested-with: GHC == 8.4.4
19+ , GHC == 8.6.5
20+
21+source-repository head
22+ type: git
23+ location: git@github.com:typeable/validationt.git
18
24
19library
25library
20 exposed-modules: Control.Monad.Validation
26 exposed-modules: Control.Monad.Validation
@@ -29,9 +35,27 @@ library
29 , text
35 , text
30 , transformers
36 , transformers
31 , transformers-base
37 , transformers-base
32− , transformers-lift
33 , vector
38 , vector
34− if impl(ghc < 8.0)
35− build-depends: semigroups == 0.18.*
36 hs-source-dirs: src
39 hs-source-dirs: src
37 default-language: Haskell2010
40 default-language: Haskell2010
41+ ghc-options: -fwarn-unused-binds
42+ -Wall
43+ -Wincomplete-uni-patterns
44+ -Wincomplete-record-updates
45+ -Wpartial-fields
46+ -Werror=missing-home-modules
47+ -Wmissing-home-modules
48+ -Widentities
49+ -Wredundant-constraints
50+ -Wmissing-export-lists
51+
52+test-suite doctest
53+ default-language: Haskell2010
54+ type: exitcode-stdio-1.0
55+ hs-source-dirs: test
56+ ghc-options: -Wall
57+ main-is: Doc.hs
58+ build-depends:
59+ base >= 4.10.0.0
60+ , doctest >= 0.11.4
61+ , validationt