validationt 0.2.1.0 → 0.3.0

raw patch · 5 files changed

+281/−44 lines, 5 filesdep +doctestdep +validationtdep −transformers-liftdep ~QuickCheckdep ~basedep ~exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: doctest, validationt

Dependencies removed: transformers-lift

Dependency ranges changed: QuickCheck, base, exceptions, mtl

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• README.md +76/−0
• src/Control/Monad/Validation.hs +164/−36
• test/Doc.hs +6/−0
• validationt.cabal +29/−8

@@ -1,5 +1,11 @@ # Revision history for validationt +## 0.3.0++* Added documentation.+* Fixed `textErrors` behaviour.+* Dropped `transformers-lift` dependency.+ ## 0.2.1.0  * GHC 8.4 support

@@ -0,0 +1,76 @@+![Travis CI Badge](https://img.shields.io/travis/typeable/validationt)++# ValidationT++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.++## Usage++Suppose you want to validate some data from the user. Say, that the password adheres to some rules.++You might do something like this:++```haskell+validatePassword :: Monad m => String -> ValidationT [String] m ()+validatePassword password = do+  vLength password+  vAlpha password+  vNum password+  where+    vLength p = when (length p < 8)+      $ vWarning ["The password should be at least 8 characters long."]+    vAlpha p = unless (any isAlpha p)+      $ vWarning ["The password should contain at least one alphabetic character."]+    vNum p = unless (any isDigit p)+      $ vWarning ["The password should contain at least one numeric character."]+```++`ValidationT e m a` essentially just gathers the errors thrown by `vWarning`.++```haskell+vWarning :: (Monad m, Monoid e) => e -> ValidationT e m ()+```++`vWarning` `mappend`s the given `e` to the already collected errors. This is why the warnings are contained inside a list.++There is also `vError`. The only difference between `vWarning` and `vError` is that `vError` stops further execution (and further collection of errors and warnings).++You would use the validation like this:++```haskell+main :: IO ()+main = do+  password <- getLine+  result <- runValidationTEither . validatePassword $ password+  putStrLn $ case result of+    Left errs -> unlines err+    Right () -> "You are fine."+```++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.++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:++```haskell+data Piece+  = Password+  | UserName+  deriving (Eq, Show, Ord)++validatePassword :: Monad m => String -> ValidationT (MonoidMap Piece [String]) m ()+validatePassword password = do+  vLength password+  vAlpha password+  vNum password+  where+    warning = mmSingleton UserName+    vLength p = when (length p < 8)+      $ warning ["The password should be at least 8 characters long."]+    vAlpha p = unless (any isAlpha p)+      $ warning ["The password should contain at least one alphabetic character."]+    vNum p = unless (any isDigit p)+      $ warning ["The password should contain at least one numeric character."]+```++(`mmSingleton` is a covenience initializer for `MonoidMap`.)

@@ -3,17 +3,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -module Control.Monad.Validation where+module Control.Monad.Validation+  ( ValidationT(..)+  , runValidationT+  , runValidationTEither+  , handleValidationT+  , vError+  , vWarning+  , vErrorL+  , vWarningL+  , vZoom+  , vZoomL+  , vPromote+  , mmSingleton+  , setMempty+  , neConcat+  , textErrors+  , _MonoidMap+  , MonoidMap(..)+  ) where +import Control.Applicative import Control.Lens hiding ((.=)) import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Except+import Control.Monad.Fail import Control.Monad.State.Strict-import Control.Monad.Trans.Lift.Local+import Control.Monad.Trans.Control import Data.Aeson import Data.Foldable as F+import Data.Functor import Data.List as L import Data.Map.Strict as M import Data.Monoid@@ -21,23 +43,32 @@ 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++-- | Collects all thrown warnings in 'StateT' and errors+-- in 'ExceptT' into a single value using 'Monoid'. newtype ValidationT e m a = ValidationT   { unValidationT :: ExceptT e (StateT e m) a   } deriving ( Functor, Applicative, Monad, MonadThrow, MonadCatch-             , MonadBase b )+             , MonadBase b, Alternative, MonadFix, MonadFail, Contravariant+             , MonadIO, MonadPlus, MonadBaseControl b, MonadMask )  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+--+-- This can be used as the `e` in `ValidationT e m a` to provide different+-- sets of errors and warnings for different keys.+--+-- >>> :{+--   mconcat+--   [ MonoidMap $ M.fromList [(1, "foo"), (2, "hello, "), (3, "oh no")]+--   , MonoidMap $ M.fromList [(1, "bar"), (2, "world")]+--   ]+-- :}+-- MonoidMap (fromList [(1,"foobar"),(2,"hello, world"),(3,"oh no")]) newtype MonoidMap k v = MonoidMap (Map k v)-  deriving (Eq, Ord, Show, Arbitrary)+  deriving (Eq, Ord, Show, Arbitrary, Foldable)  makePrisms ''MonoidMap @@ -65,7 +96,7 @@         , "value" .= v ]  instance (Ord k, FromJSON k, FromJSON v) => FromJSON (MonoidMap k v) where-  parseJSON v = withArray "MonoidMap" go v+  parseJSON = withArray "MonoidMap" go     where       go arr = do         keyvals <- traverse fromObj arr@@ -82,35 +113,60 @@ #endif mmAppend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith (<>) a b --- | Convenient for 'vZoom' as first artument. Will prevent generation--- of map with 'mempty' values+-- | Convenient for 'vZoom' as first argument. 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+mmSingleton k v+  | v == mempty = mempty+  | otherwise   = MonoidMap . M.singleton k $ v --- | Set given value to 'mempty'+-- | Sets 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)+neConcat :: Foldable f => (a -> a -> a) -> f a -> Maybe a+neConcat f a+  | F.null a  = Nothing+  | otherwise = Just $ F.foldr1 f a +-- | Returns the strings, concatanated with @", "@ if the list is not empty.+--+-- Returns Nothing if the list is empty+--+-- >>> textErrors ["foo", "bar"]+-- Just "foo, bar"+--+-- >>> textErrors ["foo"]+-- Just "foo"+--+-- >>> textErrors []+-- Nothing 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'+-- | Returns 'mempty' instead of error if no warnings have occurred.+-- Returns 'Nothing' as the second element of tuple if computation was+-- interrupted by 'vError'.+--+-- Returns all concatenated errors and warnings and the result if no+-- errors have occurred (warnings could have occurred).+--+-- >>> :{+--  runValidationT $ do+--    vWarning ["warning1"]+--    vError ["error"]+--    vWarning ["warning2"]+--    return 8+-- :}+-- (["error","warning1"],Nothing)+--+-- >>> :{+--  runValidationT $ do+--    vWarning ["warning1"]+--    vWarning ["warning2"]+--    return 8+-- :}+-- (["warning1","warning2"],Just 8) runValidationT :: (Monoid e, Monad m) => ValidationT e m a -> m (e, Maybe a) runValidationT (ValidationT m) = do   (res, warnings) <- runStateT (runExceptT m) mempty@@ -118,6 +174,25 @@     Left err -> (err <> warnings, Nothing)     Right a  -> (warnings, Just a) +-- | Like 'runValidationT' but doesn't return the result+-- if any warning has occurred.+--+-- >>> :{+--  runValidationTEither $ do+--    vWarning ["warning1"]+--    vError ["error"]+--    vWarning ["warning2"]+--    return 8+-- :}+-- Left ["error","warning1"]+--+-- >>> :{+--  runValidationTEither $ do+--    vWarning ["warning1"]+--    vWarning ["warning2"]+--    return 8+-- :}+-- Left ["warning1","warning2"] runValidationTEither   :: (Monoid e, Eq e, Monad m)   => ValidationT e m a@@ -128,28 +203,71 @@     Just a | err == mempty -> Right a     _                      -> Left err +-- | Like 'runValidationTEither', but takes an error handler instead of+-- returning errors and warnings.+--+-- >>> :{+--  handleValidationT (\_ -> return 11) $ do+--    vWarning ["warning1"]+--    vError ["error"]+--    vWarning ["warning2"]+--    return 8+-- :}+-- 11+--+-- >>> :{+--  handleValidationT (\_ -> return 11) $ do+--    vWarning ["warning1"]+--    vWarning ["warning2"]+--    return 8+-- :}+-- 11 handleValidationT   :: (Monoid e, Monad m, Eq e)   => (e -> m a)   -> ValidationT e m a   -> m a-handleValidationT handler action = do+handleValidationT handler action =   runValidationTEither action >>= either handler return --- | Stops further execution of validation+-- | Stops further execution and appends the given error. vError :: (Monad m) => e -> ValidationT e m a vError e = ValidationT $ throwError e --- | Does not stop further execution, append warning to+-- | Does not stop further execution and appends the given warning. vWarning :: (Monad m, Monoid e) => e -> ValidationT e m () vWarning e = ValidationT $ modify' (<> e) +-- | Like 'vError' but allows you to use a setter to insert an error somewhere+-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then+-- combined with all gathered warnings. vErrorL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m x vErrorL l a = vError $ setMempty l a +-- | Like 'vWarning' but allows you to use a setter to insert an error somewhere+-- deeper into an empty ('mempty') "e" from "ValidationT e m x", which is then+-- combined with all gathered warnings. vWarningL :: (Monad m, Monoid e) => ASetter' e a -> a -> ValidationT e m () vWarningL l a = vWarning $ setMempty l a +-- | Allows you apply a transformation to the "e" in "ValidationT e m x".+--+-- >>> :{+--runValidationT . vZoom (Data.Map.singleton "password errors") $ do+--  vWarning ["warning1"]+--  vError ["error"]+--  vWarning ["warning2"]+--  return 8+-- :}+-- (fromList [("password errors",["error","warning1"])],Nothing)+--+-- >>> :{+--  runValidationT . vZoom (Data.Map.singleton "password errors") $ do+--    vWarning ["warning1"]+--    vWarning ["warning2"]+--    return 8+-- :}+-- (fromList [("password errors",["warning1","warning2"])],Just 8) vZoom   :: (Monad m, Monoid a, Monoid b)   => (a -> b)@@ -159,11 +277,21 @@   (err, res) <- lift $ runValidationT action   case res of     Nothing -> vError $ up err-    Just a  -> vWarning (up err) *> return a+    Just a  -> vWarning (up err) $> a +-- | Like 'vZoom' but takes a setter instead of a function. 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+vZoomL l = vZoom (setMempty l)++-- | Turn any warnings the have occurred into errors.+vPromote+  :: (Monad m, Monoid a, Eq a)+  => ValidationT a m x+  -> ValidationT a m x+vPromote m = do+  err <- lift $ runValidationTEither m+  either vError return err

@@ -0,0 +1,6 @@+module Main (main) where++import Test.DocTest++main :: IO ()+main = doctest [ "-XOverloadedStrings", "-isrc", "src" ]

@@ -2,9 +2,9 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                validationt-version:             0.2.1.0-synopsis:            Straightforward validation monad.-description:         Convenient solution for validating web forms and APIs.+version:             0.3.0+synopsis:            Straightforward validation monad+description:         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. homepage:            https://github.com/typeable/validationt license:             BSD3 license-file:        LICENSE@@ -14,11 +14,12 @@ category:            Control build-type:          Simple extra-source-files:  ChangeLog.md+                   , README.md cabal-version:       >=1.10-tested-with:         GHC == 7.10.3-                   , GHC == 8.0.2-                   , GHC == 8.2.2-                   , GHC == 8.4.1+tested-with:         GHC == 8.4.4+                   , GHC == 8.6.5+                   , GHC == 8.8.4+                   , GHC == 8.10.2  source-repository head   type:     git@@ -37,7 +38,27 @@                      , text                      , transformers                      , transformers-base-                     , transformers-lift                      , vector   hs-source-dirs:      src   default-language:    Haskell2010+  ghc-options:         -fwarn-unused-binds+                       -Wall+                       -Wincomplete-uni-patterns+                       -Wincomplete-record-updates+                       -Wpartial-fields+                       -Werror=missing-home-modules+                       -Wmissing-home-modules+                       -Widentities+                       -Wredundant-constraints+                       -Wmissing-export-lists++test-suite doctest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  ghc-options: -Wall+  main-is: Doc.hs+  build-depends:+      base >= 4.10.0.0+    , doctest >= 0.11.4+    , validationt