Initial release

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for validationt
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2017, Denis Redozubov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Denis Redozubov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

src/Control/Monad/Validation.hs

@@ -0,0 +1,153 @@
+
+module Common.Validation where
+
+import Control.Lens hiding ((.=))
+import Control.Monad.Base
+import Control.Monad.Catch
+import Control.Monad.Except
+import Control.Monad.State.Strict
+import Control.Monad.Trans.Lift.Local
+import Data.Aeson
+import Data.Foldable as F
+import Data.List as L
+import Data.Map.Strict as M
+import Data.Monoid
+import Data.Text as T
+import Data.Vector as V
+import Test.QuickCheck
+
+-- | Collects all throwed "warnings" throwed through StateT and "errors" throwed
+-- through ExceptT to single value using Monoid
+--  FIXME: give more instances like HReaderT and MonadBaseControl/MonadMask
+newtype ValidationT e m a = ValidationT
+  { unValidationT :: ExceptT e (StateT e m) a
+  } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch
+             , MonadBase b )
+
+instance MonadTrans (ValidationT e) where
+  lift = ValidationT . lift . lift
+
+instance LiftLocal (ValidationT e) where
+  liftLocal _ l f = ValidationT . mapExceptT (mapStateT $ l f) . unValidationT
+
+-- | Map with 'Monoid' instance which 'mappend' its values
+newtype MonoidMap k v = MonoidMap (Map k v)
+  deriving (Eq, Ord, Show, Arbitrary)
+
+makePrisms ''MonoidMap
+
+type instance IxValue (MonoidMap k v) = v
+type instance Index (MonoidMap k v) = k
+instance (Ord k) => Ixed (MonoidMap k v) where
+  ix key = _MonoidMap . ix key
+instance (Ord k) => At (MonoidMap k v) where
+  at key = _MonoidMap . at key
+
+instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
+  mempty = MonoidMap M.empty
+  mappend (MonoidMap a) (MonoidMap b) =
+    MonoidMap $ M.unionWith (<>) a b
+
+instance (ToJSON k, ToJSON v) => ToJSON (MonoidMap k v) where
+  toJSON (MonoidMap m) = toJSON $ L.map toObj $ M.toList m
+    where
+      toObj (k, v) = object
+        [ "id" .= k
+        , "value" .= v ]
+
+instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where
+  parseJSON v = withArray "MonoidMap" go v
+    where
+      go arr = do
+        keyvals <- traverse fromObj arr
+        return $ MonoidMap $ M.fromList $ V.toList keyvals
+      fromObj objV = flip (withObject "element of MonoidMap") objV $ \obj -> do
+        key <- obj .: "id"
+        val <- obj .: "value"
+        return (key, val)
+
+-- | Convenient for 'vZoom' as first artument. Will prevent generation
+-- of map with 'mempty' values
+mmSingleton :: (Eq v, Monoid v, Ord k) => k -> v -> MonoidMap k v
+mmSingleton k = memptyWrap mempty $ MonoidMap . M.singleton k
+
+-- | Set given value to 'mempty'
+setMempty :: (Monoid s) => ASetter' s a -> a -> s
+setMempty setter a = set setter a mempty
+
+memptyWrap :: (Eq a, Monoid a) => b -> (a -> b) -> a -> b
+memptyWrap b f a
+  | a == mempty = b
+  | otherwise = f a
+
+-- | If given container is not 'mempty', then use given function to
+-- append all its elements and return 'Just' result
+neConcat
+  :: (Foldable f, Eq (f a), Monoid a, Monoid (f a))
+  => (a -> a -> a)
+  -> f a
+  -> Maybe a
+neConcat f = memptyWrap Nothing (Just . F.foldl' f mempty)
+
+textErrors :: [Text] -> Maybe Text
+textErrors = neConcat (\a b -> a <> ", " <> b)
+
+-- | Returns `mempty` instead of error if no warnings was occured. So, your
+-- error should have `Eq` instance to detect that any error was occured. Returns
+-- Nothing for second element of tuple if compuration was interruped by 'vError'
+runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a)
+runValidationT (ValidationT m) = do
+  (res, warnings) <- runStateT (runExceptT m) mempty
+  return $ case res of
+    Left err -> (err <> warnings, Nothing)
+    Right a  -> (warnings, Just a)
+
+runValidationTEither
+  :: (Monoid e, Eq e, Monad m)
+  => ValidationT e m a
+  -> m (Either e a)
+runValidationTEither action = do
+  (err, res) <- runValidationT action
+  return $ case res of
+    Just a | err == mempty -> Right a
+    _                      -> Left err
+
+handleValidationT
+  :: (Monoid e, Monad m, Eq e)
+  => (e -> m a)
+  -> ValidationT e m a
+  -> m a
+handleValidationT handler action = do
+  runValidationTEither action >>= either handler return
+
+-- | Stops further execution of validation
+vError :: (Monad m) => e -> ValidationT e m a
+vError e = ValidationT $ throwError e
+
+-- | Does not stop further execution, append warning to
+vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()
+vWarning e = ValidationT $ modify' (<> e)
+
+vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x
+vErrorL l a = vError $ setMempty l a
+
+vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m ()
+vWarningL l a = vWarning $ setMempty l a
+
+vZoom
+  :: (Monad m, Monoid a, Monoid b)
+  => (a -> b)
+  -> ValidationT a m x
+  -> ValidationT b m x
+vZoom up action = do
+  (err, res) <- lift $ runValidationT action
+  case res of
+    Nothing -> vError $ up err
+    Just a  -> vWarning (up err) *> return a
+
+vZoomL
+  :: (Monad m, Monoid a, Monoid b)
+  => ASetter' b a
+  -> ValidationT a m x
+  -> ValidationT b m x
+vZoomL l action = vZoom (setMempty l) action

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-8.14
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.4"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

validationt.cabal

@@ -0,0 +1,28 @@
+-- Initial validationt.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                validationt
+version:             0.1.0.0
+synopsis:            Straightforward validation monad. Convenient solution for validating web forms and APIs.
+-- description:
+homepage:            typeable.io
+license:             BSD3
+license-file:        LICENSE
+author:              Typeable.io contributors
+maintainer:          makeit@typeable.io
+-- copyright:
+category:            Control
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  -- exposed-modules:
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base >=4.8
+                     , aeson >= 1.0
+                     , transformers
+                     , lens
+  hs-source-dirs:      src
+  default-language:    Haskell2010