monad-validate 1.0.0.0 → 1.1.0.0

raw patch · 7 files changed

+153/−28 lines, 7 filesdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• monad-validate.cabal +4/−4
• package.yaml +2/−2
• src/Control/Monad/Validate.hs +2/−0
• src/Control/Monad/Validate/Class.hs +40/−6
• src/Control/Monad/Validate/Internal.hs +54/−3
• test/Control/Monad/ValidateSpec.hs +45/−13

@@ -1,3 +1,9 @@+# 1.1.0.0 [2019-08-05]++- Added the `tolerate` method to `MonadValidate`, which allows relaxing validation errors from fatal to nonfatal.+- Added the `embedValidateT` and `mapErrors` functions, which can be used together to locally alter the type of validation errors in `ValidateT` computations.+- Removed the `MonadValidate` instance for `ContT`, which is no longer possible to implement due to the addition of `tolerate`.+ # 1.0.0.0 [2019-08-04]  - Initial release.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 55a4fb3ebfe9bd3e5b9df3ebd02552c9f299a050ca7d67961179a4214569126a+-- hash: 79775fef96c91f15bf687d1020e2db81124f7fb2e493f1bf2e780efe2d7b04b5  name:           monad-validate-version:        1.0.0.0+version:        1.1.0.0 synopsis:       A monad transformer for data validation. description:    Provides the 'ValidateT' monad transformer, designed for writing data validations that provide                 high-quality error reporting without much effort. 'ValidateT' automatically exploits the data@@ -50,7 +50,7 @@     , exceptions >=0.9 && <1     , monad-control >=1 && <2     , mtl-    , transformers+    , transformers >=0.5.6     , transformers-base <1   default-language: Haskell2010 @@ -75,7 +75,7 @@     , mtl     , scientific     , text-    , transformers+    , transformers >=0.5.6     , transformers-base <1     , unordered-containers     , vector

@@ -1,5 +1,5 @@ name: monad-validate-version: 1.0.0.0+version: 1.1.0.0 category: Control copyright: 2019 Hasura license: ISC@@ -65,7 +65,7 @@ - exceptions >= 0.9 && < 1 - monad-control >= 1 && < 2 - mtl-- transformers+- transformers >= 0.5.6 - transformers-base < 1  library:

@@ -7,6 +7,8 @@     ValidateT   , runValidateT   , execValidateT+  , embedValidateT+  , mapErrors    -- * The MonadValidate class   , MonadValidate(..)

@@ -15,11 +15,12 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict  import Control.Monad.Trans.Class-import Control.Monad.Trans.Cont+import Control.Monad.Trans.Control import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader+import Data.Functor  {-| The class of validation monads, intended to be used to validate data structures while collecting errors along the way. In a sense, 'MonadValidate' is like a combination of@@ -33,32 +34,65 @@      computation to globally fail, it just doesn’t affect local execution.  For a more thorough explanation, with examples, see the documentation for-'Control.Monad.Validate.ValidateT'.--}+'Control.Monad.Validate.ValidateT'. -} class (Monad m, Semigroup e) => MonadValidate e m | m -> e where   -- | Raises a fatal validation error. Aborts the current branch of the validation (i.e. does not   -- return).+  --+  -- @+  -- >>> 'Control.Monad.Validate.runValidate' ('refute' ["boom"] '>>' 'refute' ["bang"])+  -- 'Left' ["boom"]+  -- @   refute :: e -> m a    -- | Raises a non-fatal validation error. The overall validation fails, and the error is recorded,   -- but validation continues in an attempt to try and discover more errors.+  --+  -- @+  -- >>> 'Control.Monad.Validate.runValidate' ('dispute' ["boom"] '>>' 'dispute' ["bang"])+  -- 'Left' ["boom", "bang"]+  -- @   dispute :: e -> m () +  -- | @'tolerate' m@ behaves like @m@, except that any fatal errors raised by 'refute' are altered+  -- to non-fatal errors that return 'Nothing'. This allows @m@’s result to be used for further+  -- validation if it succeeds without preventing further validation from occurring upon failure.+  --+  -- @+  -- >>> 'Control.Monad.Validate.runValidate' ('tolerate' ('refute' ["boom"]) '>>' 'refute' ["bang"])+  -- 'Left' ["boom", "bang"]+  -- @+  --+  -- @since 1.1.0.0+  tolerate :: m a -> m (Maybe a)+   default refute :: (MonadTrans t, MonadValidate e m', m ~ t m') => e -> m a   refute = lift . refute   default dispute :: (MonadTrans t, MonadValidate e m', m ~ t m') => e -> m ()   dispute = lift . dispute+  default tolerate :: (MonadTransControl t, MonadValidate e m', m ~ t m') => m a -> m (Maybe a)+  tolerate m = liftWith (\run -> tolerate (run m)) >>=+    maybe (pure Nothing) (fmap Just . restoreT . pure)+  {-# INLINE refute #-}+  {-# INLINE dispute #-}+  {-# INLINE tolerate #-} -instance (MonadValidate e m) => MonadValidate e (ContT r m) instance (MonadValidate e m) => MonadValidate e (ExceptT a m) instance (MonadValidate e m) => MonadValidate e (IdentityT m) instance (MonadValidate e m) => MonadValidate e (MaybeT m) instance (MonadValidate e m) => MonadValidate e (ReaderT r m)-instance (MonadValidate e m) => MonadValidate e (CPS.RWST r w s m) instance (MonadValidate e m, Monoid w) => MonadValidate e (Lazy.RWST r w s m) instance (MonadValidate e m, Monoid w) => MonadValidate e (Strict.RWST r w s m) instance (MonadValidate e m) => MonadValidate e (Lazy.StateT s m) instance (MonadValidate e m) => MonadValidate e (Strict.StateT s m)-instance (MonadValidate e m) => MonadValidate e (CPS.WriterT w m) instance (MonadValidate e m, Monoid w) => MonadValidate e (Lazy.WriterT w m) instance (MonadValidate e m, Monoid w) => MonadValidate e (Strict.WriterT w m)++instance (MonadValidate e m, Monoid w) => MonadValidate e (CPS.WriterT w m) where+  tolerate m = CPS.writerT $ tolerate (CPS.runWriterT m) <&>+    maybe (Nothing, mempty) (\(v, w) -> (Just v, w))+  {-# INLINE tolerate #-}+instance (MonadValidate e m, Monoid w) => MonadValidate e (CPS.RWST r w s m) where+  tolerate m = CPS.rwsT $ \r s1 -> tolerate (CPS.runRWST m r s1) <&>+    maybe (Nothing, s1, mempty) (\(v, s2, w) -> (Just v, s2, w))+  {-# INLINE tolerate #-}

@@ -81,7 +81,7 @@   qrAuth           <- withKey o "auth_token" parseAuthToken   ~(qrTable, info) <- withKey o "table" parseTableName   qrQuery          <- withKey o "query" parseQuery-  'Data.Foldable.for_' info $ \tableInfo -> 'local' (pushPath "query") '$'+  'Data.Foldable.for_' info '$' \tableInfo -> pushPath "query" '$'     validateQuery qrTable tableInfo (atIsAdmin qrAuth) qrQuery   'pure' QueryRequest { qrAuth, qrTable, qrQuery } @@@ -432,8 +432,11 @@     let !e3 = monoMaybe e2 (<> e2) e1 in pure (Left e3)   dispute e2 = validateT $ \e1 ->     let !e3 = monoMaybe e2 (<> e2) e1 in pure (Right (MJust e3, ()))+  tolerate m = validateT $ \e1 ->+    Right . either (\e2 -> (MJust e2, Nothing)) (fmap Just) <$> unValidateT e1 m   {-# INLINABLE refute #-}   {-# INLINABLE dispute #-}+  {-# INLINABLE tolerate #-}  -- | Runs a 'ValidateT' computation, returning the errors raised by 'refute' or 'dispute' if any, -- otherwise returning the computation’s result.@@ -446,23 +449,71 @@ -- | Runs a 'ValidateT' computation, returning the errors on failure or 'mempty' on success. The -- computation’s result, if any, is discarded. ----- >>> execValidate (refute ["bang"])+-- @+-- >>> 'execValidate' ('refute' ["bang"]) -- ["bang"]--- >>> execValidate @[] (pure 42)+-- >>> 'execValidate' @[] ('pure' 42) -- []+-- @ execValidateT :: forall e m a. (Monoid e, Functor m) => ValidateT e m a -> m e execValidateT = fmap (either id mempty) . runValidateT +{-| Runs a 'ValidateT' transformer by interpreting it in an underlying transformer with a+'MonadValidate' instance. That might seem like a strange thing to do, but it can be useful in+combination with 'mapErrors' to locally alter the error type in a larger 'ValidateT' computation.+For example:++@+throwsIntegers :: 'MonadValidate' ['Integer'] m => m ()+throwsIntegers = 'dispute' [42]++throwsBools :: 'MonadValidate' ['Bool'] m => m ()+throwsBools = 'dispute' ['False']++throwsBoth :: 'MonadValidate' ['Either' 'Integer' 'Bool'] m => m ()+throwsBoth = do+  'embedValidateT' '$' 'mapErrors' ('map' 'Left') throwsIntegers+  'embedValidateT' '$' 'mapErrors' ('map' 'Right') throwsBools++>>> 'runValidate' throwsBoth+'Left' ['Left' 42, 'Right' False]+@++@since 1.1.0.0 -}+embedValidateT :: forall e m a. (MonadValidate e m) => ValidateT e m a -> m a+embedValidateT m = unValidateT MNothing m >>= \case+  Left e              -> refute e+  Right (MJust e, v)  -> dispute e $> v+  Right (MNothing, v) -> pure v++-- | Applies a function to all validation errors produced by a 'ValidateT' computation.+--+-- @+-- >>> 'runValidate' '$' 'mapErrors' ('map' 'show') ('refute' [11, 42])+-- 'Left' ["11", "42"]+-- @+--+-- @since 1.1.0.0+mapErrors+  :: forall e e' m a. (Monad m, Semigroup e')+  => (e -> e') -> ValidateT e m a -> ValidateT e' m a+mapErrors f m = lift (unValidateT MNothing m) >>= \case+  Left e              -> refute (f e)+  Right (MJust e, v)  -> dispute (f e) $> v+  Right (MNothing, v) -> pure v+ -- | 'ValidateT' specialized to the 'Identity' base monad. See 'ValidateT' for usage information. type Validate e = ValidateT e Identity  -- | See 'runValidateT'. runValidate :: forall e a. Validate e a -> Either e a runValidate = runIdentity . runValidateT+{-# INLINE runValidate #-}  -- | See 'execValidateT'. execValidate :: forall e a. (Monoid e) => Validate e a -> e execValidate = runIdentity . execValidateT+{-# INLINE execValidate #-}  {-| Monotonically increasing 'Maybe' values. A function with the type 

@@ -15,7 +15,6 @@ import Data.Aeson.QQ (aesonQQ) import Data.Foldable import Data.Functor-import Data.Maybe import Data.Scientific (toBoundedInteger) import Data.Text (Text) import Data.Typeable@@ -73,7 +72,7 @@   qrAuth           <- withKey o "auth_token" parseAuthToken   ~(qrTable, info) <- withKey o "table" parseTableName   qrQuery          <- withKey o "query" parseQuery-  for_ info $ \tableInfo -> local (pushPath "query") $+  for_ info $ \tableInfo -> pushPath "query" $     validateQuery qrTable tableInfo (atIsAdmin qrAuth) qrQuery   pure QueryRequest { qrAuth, qrTable, qrQuery }   where@@ -86,11 +85,13 @@      parseTableName v = withObject "table name" v $ \o -> do       name <- TableName <$> withKey o "schema" asString <*> withKey o "name" asString-      info <- lookup name <$> asks envTables-      when (isNothing info) $-        disputeErr $ UnknownTableName name+      info <- tolerate $ validateTableName name       pure (name, info) +    validateTableName name = do+      info <- lookup name <$> asks envTables+      maybe (refuteErr $ UnknownTableName name) pure info+     parseQuery :: forall a. (Typeable a) => Value -> m (Query a)     parseQuery q = withSingleKeyObject "query expression" q $ \k v -> case k of       "lit"    -> withType $ QLit <$> asInteger v@@ -105,21 +106,23 @@       loop :: Query a -> m ()       loop = \case         QLit _ -> pure ()-        QSelect colName -> local (pushPath "select") $ case lookup colName tableInfo of+        QSelect colName -> pushPath "select" $ case lookup colName tableInfo of           Just colInfo             | ciAdminOnly colInfo && not isAdmin             -> disputeErr $ InsufficientPermissions tableName colName             | otherwise -> pure ()           Nothing -> disputeErr $ UnknownColumnName tableName colName-        QAdd a b -> local (pushPath "add") $ loop a *> loop b-        QEqual a b -> local (pushPath "equal") $ loop a *> loop b-        QIf a b c -> local (pushPath "if") $ loop a *> loop b *> loop c+        QAdd a b -> pushPath "add" $ loop a *> loop b+        QEqual a b -> pushPath "equal" $ loop a *> loop b+        QIf a b c -> pushPath "if" $ loop a *> loop b *> loop c      parseColumnName = fmap ColumnName . asString -    pushPath path env = env { envPath = path : envPath env }+    pushPath :: Text -> m a -> m a+    pushPath path = local (\env -> env { envPath = path : envPath env })     mkErr info = asks envPath <&> \path -> Error (reverse path) info     refuteErr = mkErr >=> \err -> refute [err]+    disputeErr :: ErrorInfo -> m ()     disputeErr = mkErr >=> \err -> dispute [err]      withType :: forall a b. (Typeable a, Typeable b) => m (Query a) -> m (Query b)@@ -139,14 +142,43 @@     withObject name v f = case v of { Object o -> f o; _ -> refuteErr $ JSONBadValue name v }      withKey :: Object -> Text -> (Value -> m a) -> m a-    withKey o k f = maybe (refuteErr $ JSONMissingKey k) (local (pushPath k) . f) $ M.lookup k o+    withKey o k f = maybe (refuteErr $ JSONMissingKey k) (pushPath k . f) $ M.lookup k o      withSingleKeyObject :: Text -> Value -> (Text -> Value -> m a) -> m a     withSingleKeyObject name i f = withObject name i $ \o -> case M.toList o of-      { [(k, v)] -> local (pushPath k) $ f k v; _ -> refuteErr $ JSONBadValue name i }+      { [(k, v)] -> pushPath k $ f k v; _ -> refuteErr $ JSONBadValue name i }  spec :: Spec-spec = describe "ValidateT" $+spec = describe "ValidateT" $ do+  describe "tolerate" $ do+    it "has no effect on computations without fatal errors" $ do+      runValidate ((dispute ["boom"] $> ["bang"]) >>= dispute)+        `shouldBe` Left (["boom", "bang"] :: [Text])+      runValidate (tolerate (dispute ["boom"] $> ["bang"]) >>= traverse_ dispute)+        `shouldBe` Left (["boom", "bang"] :: [Text])++    it "converts fatal errors to non-fatal errors" $ do+      runValidate (refute ["boom"] >> dispute ["bang"])+        `shouldBe` Left (["boom"] :: [Text])+      runValidate (tolerate (refute ["boom"]) >> dispute ["bang"])+        `shouldBe` Left (["boom", "bang"] :: [Text])++  describe "mapErrors" $ do+    it "applies a function to all validation errors" $+      runValidate (mapErrors (map show) (refute [True] *> dispute [False]))+        `shouldBe` Left ["True", "False"]++    it "can be used with embedValidateT to locally change the type of errors" $ do+      let foo :: (MonadValidate [Integer] m) => m ()+          foo = dispute [42]+          bar :: (MonadValidate [Bool] m) => m ()+          bar = dispute [False]+          baz :: (MonadValidate [Either Integer Bool] m) => m ()+          baz = do+            embedValidateT $ mapErrors (map Left) foo+            embedValidateT $ mapErrors (map Right) bar+      runValidate baz `shouldBe` Left [Left 42, Right False]+   it "collects validation information from all sub-branches of <*>" $ do     let tables =           [ (TableName "public" "users",