git.iko.soy/typeable/validationt
on master help sign in
Initial release
916e38cDenis Redozubov
ChangeLog.mdnew file+5
compare with master
unifiedsplit
@@ -0,0 +1,5 @@
1+# Revision history for validationt
2+
3+## 0.1.0.0 -- YYYY-mm-dd
4+
5+* First version. Released on an unsuspecting world.
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2017, Denis Redozubov
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Denis Redozubov nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
src/Control/Monad/Validation.hsnew file+153
@@ -0,0 +1,153 @@
1+
2+module Common.Validation where
3+
4+import Control.Lens hiding ((.=))
5+import Control.Monad.Base
6+import Control.Monad.Catch
7+import Control.Monad.Except
8+import Control.Monad.State.Strict
9+import Control.Monad.Trans.Lift.Local
10+import Data.Aeson
11+import Data.Foldable as F
12+import Data.List as L
13+import Data.Map.Strict as M
14+import Data.Monoid
15+import Data.Text as T
16+import Data.Vector as V
17+import Test.QuickCheck
18+
19+-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
20+-- through ExceptT to single value using Monoid
21+-- FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
22+newtype ValidationT e m a = ValidationT
23+ { unValidationT :: ExceptT e (StateT e m) a
24+ } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
25+ , MonadBase b )
26+
27+instance MonadTrans (ValidationT e) where
28+ lift = ValidationT . lift . lift
29+
30+instance LiftLocal (ValidationT e) where
31+ liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT
32+
33+-- | Map with 'Monoid' instance which 'mappend' its values
34+newtype MonoidMap k v = MonoidMap (Map k v)
35+ deriving (Eq, Ord, Show, Arbitrary)
36+
37+makePrisms ''MonoidMap
38+
39+type instance IxValue (MonoidMap k v) = v
40+type instance Index (MonoidMap k v) = k
41+instance (Ord k) => Ixed (MonoidMap k v) where
42+ ix key = _MonoidMap . ix key
43+instance (Ord k) => At (MonoidMap k v) where
44+ at key = _MonoidMap . at key
45+
46+instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
47+ mempty = MonoidMap M.empty
48+ mappend (MonoidMap a) (MonoidMap b) =
49+ MonoidMap $ M.unionWith (<>) a b
50+
51+instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
52+ toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
53+ where
54+ toObj (k, v) = object
55+ [ "id" .= k
56+ , "value" .= v ]
57+
58+instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
59+ parseJSON v = withArray "MonoidMap" go v
60+ where
61+ go arr = do
62+ keyvals <- traverse fromObj arr
63+ return $ MonoidMap $ M.fromList $ V.toList keyvals
64+ fromObj objV = flip (withObject "element of MonoidMap") objV $ \obj -> do
65+ key <- obj .: "id"
66+ val <- obj .: "value"
67+ return (key, val)
68+
69+-- | Convenient for 'vZoom' as first artument. Will prevent generation
70+-- of map with 'mempty' values
71+mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
72+mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k
73+
74+-- | Set given value to 'mempty'
75+setMempty :: (Monoid s) => ASetter' s a -> a -> s
76+setMempty setter a = set setter a mempty
77+
78+memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b
79+memptyWrap b f a
80+ | a == mempty = b
81+ | otherwise = f a
82+
83+-- | If given container is not 'mempty', then use given function to
84+-- append all its elements and return 'Just' result
85+neConcat
86+ :: (Foldable f, Eq (f a), Monoid a, Monoid (f a))
87+ => (a -> a -> a)
88+ -> f a
89+ -> Maybe a
90+neConcat f = memptyWrap Nothing (Just . F.foldl' f mempty)
91+
92+textErrors :: [Text] -> Maybe Text
93+textErrors = neConcat (\a b -> a <> ", " <> b)
94+
95+-- | Returns `mempty` instead of error if no warnings was occured. So, your
96+-- error should have `Eq` instance to detect that any error was occured. Returns
97+-- Nothing for second element of tuple if compuration was interruped by 'vError'
98+runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
99+runValidationT (ValidationT m) = do
100+ (res, warnings) <- runStateT (runExceptT m) mempty
101+ return $ case res of
102+ Left err -> (err <> warnings, Nothing)
103+ Right a -> (warnings, Just a)
104+
105+runValidationTEither
106+ :: (Monoid e, Eq e, Monad m)
107+ => ValidationT e m a
108+ -> m (Either e a)
109+runValidationTEither action = do
110+ (err, res) <- runValidationT action
111+ return $ case res of
112+ Just a | err == mempty -> Right a
113+ _ -> Left err
114+
115+handleValidationT
116+ :: (Monoid e, Monad m, Eq e)
117+ => (e -> m a)
118+ -> ValidationT e m a
119+ -> m a
120+handleValidationT handler action = do
121+ runValidationTEither action >>= either handler return
122+
123+-- | Stops further execution of validation
124+vError :: (Monad m) => e -> ValidationT e m a
125+vError e = ValidationT $ throwError e
126+
127+-- | Does not stop further execution, append warning to
128+vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
129+vWarning e = ValidationT $ modify' (<> e)
130+
131+vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
132+vErrorL l a = vError $ setMempty l a
133+
134+vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
135+vWarningL l a = vWarning $ setMempty l a
136+
137+vZoom
138+ :: (Monad m, Monoid a, Monoid b)
139+ => (a -> b)
140+ -> ValidationT a m x
141+ -> ValidationT b m x
142+vZoom up action = do
143+ (err, res) <- lift $ runValidationT action
144+ case res of
145+ Nothing -> vError $ up err
146+ Just a -> vWarning (up err) *> return a
147+
148+vZoomL
149+ :: (Monad m, Monoid a, Monoid b)
150+ => ASetter' b a
151+ -> ValidationT a m x
152+ -> ValidationT b m x
153+vZoomL l action = vZoom (setMempty l) action
stack.yamlnew file+66
@@ -0,0 +1,66 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# http://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghc-7.10.2
14+# resolver: ghcjs-0.1.0_ghc-7.10.2
15+# resolver:
16+# name: custom-snapshot
17+# location: "./custom-snapshot.yaml"
18+resolver: lts-8.14
19+
20+# User packages to be built.
21+# Various formats can be used as shown in the example below.
22+#
23+# packages:
24+# - some-directory
25+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
26+# - location:
27+# git: https://github.com/commercialhaskell/stack.git
28+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30+# extra-dep: true
31+# subdirs:
32+# - auto-update
33+# - wai
34+#
35+# A package marked 'extra-dep: true' will only be built if demanded by a
36+# non-dependency (i.e. a user package), and its test suites and benchmarks
37+# will not be run. This is useful for tweaking upstream packages.
38+packages:
39+- '.'
40+# Dependency packages to be pulled from upstream that are not in the resolver
41+# (e.g., acme-missiles-0.3)
42+extra-deps: []
43+
44+# Override default flag values for local packages and extra-deps
45+flags: {}
46+
47+# Extra package databases containing global packages
48+extra-package-dbs: []
49+
50+# Control whether we use the GHC we find on the path
51+# system-ghc: true
52+#
53+# Require a specific version of stack, using version ranges
54+# require-stack-version: -any # Default
55+# require-stack-version: ">=1.4"
56+#
57+# Override the architecture used by stack, especially useful on Windows
58+# arch: i386
59+# arch: x86_64
60+#
61+# Extra directories used by stack for building
62+# extra-include-dirs: [/path/to/dir]
63+# extra-lib-dirs: [/path/to/dir]
64+#
65+# Allow a newer minor version of GHC than the snapshot specifies
66+# compiler-check: newer-minor
validationt.cabalnew file+28
@@ -0,0 +1,28 @@
1+-- Initial validationt.cabal generated by cabal init. For further
2+-- documentation, see http://haskell.org/cabal/users-guide/
3+
4+name: validationt
5+version: 0.1.0.0
6+synopsis: Straightforward validation monad. Convenient solution for validating web forms and APIs.
7+-- description:
8+homepage: typeable.io
9+license: BSD3
10+license-file: LICENSE
11+author: Typeable.io contributors
12+maintainer: makeit@typeable.io
13+-- copyright:
14+category: Control
15+build-type: Simple
16+extra-source-files: ChangeLog.md
17+cabal-version: >=1.10
18+
19+library
20+ -- exposed-modules:
21+ -- other-modules:
22+ -- other-extensions:
23+ build-depends: base >=4.8
24+ , aeson >= 1.0
25+ , transformers
26+ , lens
27+ hs-source-dirs: src
28+ default-language: Haskell2010