monad-validate (empty) → 1.0.0.0

raw patch · 12 files changed

+1024/−0 lines, 12 filesdep +aesondep +aeson-qqdep +basesetup-changed

Dependencies added: aeson, aeson-qq, base, exceptions, hspec, monad-control, monad-validate, mtl, scientific, text, transformers, transformers-base, unordered-containers, vector

Files

• CHANGELOG.md +3/−0
• LICENSE +13/−0
• README.md +7/−0
• Setup.hs +7/−0
• monad-validate.cabal +82/−0
• package.yaml +91/−0
• src/Control/Monad/Validate.hs +21/−0
• src/Control/Monad/Validate/Class.hs +64/−0
• src/Control/Monad/Validate/Internal.hs +508/−0
• stack.yaml +4/−0
• test/Control/Monad/ValidateSpec.hs +223/−0
• test/Main.hs +1/−0

@@ -0,0 +1,3 @@+# 1.0.0.0 [2019-08-04]++- Initial release.

@@ -0,0 +1,13 @@+Copyright 2019 Hasura++Permission to use, copy, modify, and/or distribute this software for any purpose+with or without fee is hereby granted, provided that the above copyright notice+and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF+THIS SOFTWARE.

@@ -0,0 +1,7 @@+# monad-validate++A Haskell library providing the `ValidateT` monad transformer, designed for writing data validations that provide high-quality error reporting without much effort. `ValidateT` automatically exploits the data dependencies of your program—as encoded implicitly in uses of `fmap`, `<*>`, and `>>=`—to report as many errors as possible upon failure instead of completely aborting at the first one.++See [the documentation on Hackage][hackage] for more information and examples.++[hackage]: https://hackage.haskell.org/package/monad-validate

@@ -0,0 +1,7 @@+-- This script is used to build and install your package. Typically you don't+-- need to change it. The Cabal documentation has more information about this+-- file: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain

@@ -0,0 +1,82 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 55a4fb3ebfe9bd3e5b9df3ebd02552c9f299a050ca7d67961179a4214569126a++name:           monad-validate+version:        1.0.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+                dependencies of your program—as encoded implicitly in uses of 'fmap', '<*>', and '>>='—to report+                as many errors as possible upon failure instead of completely aborting at the first one. See+                "Control.Monad.Validate" for more information.+category:       Control+homepage:       https://github.com/hasura/monad-validate#readme+bug-reports:    https://github.com/hasura/monad-validate/issues+author:         Alexis King <lexi.lambda@gmail.com>+maintainer:     Alexis King <lexi.lambda@gmail.com>+copyright:      2019 Hasura+license:        ISC+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    CHANGELOG.md+    LICENSE+    package.yaml+    README.md+    stack.yaml++source-repository head+  type: git+  location: https://github.com/hasura/monad-validate++library+  exposed-modules:+      Control.Monad.Validate+      Control.Monad.Validate.Class+      Control.Monad.Validate.Internal+  other-modules:+      Paths_monad_validate+  hs-source-dirs:+      src+  default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >=4.11 && <5+    , exceptions >=0.9 && <1+    , monad-control >=1 && <2+    , mtl+    , transformers+    , transformers-base <1+  default-language: Haskell2010++test-suite monad-validate-test-suite+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Control.Monad.ValidateSpec+      Paths_monad_validate+  hs-source-dirs:+      test+  default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      aeson+    , aeson-qq+    , base >=4.11 && <5+    , exceptions >=0.9 && <1+    , hspec+    , monad-control >=1 && <2+    , monad-validate+    , mtl+    , scientific+    , text+    , transformers+    , transformers-base <1+    , unordered-containers+    , vector+  default-language: Haskell2010

@@ -0,0 +1,91 @@+name: monad-validate+version: 1.0.0.0+category: Control+copyright: 2019 Hasura+license: ISC+author: Alexis King <lexi.lambda@gmail.com>+github: hasura/monad-validate++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+  dependencies of your program—as encoded implicitly in uses of 'fmap', '<*>', and '>>='—to report+  as many errors as possible upon failure instead of completely aborting at the first one. See+  "Control.Monad.Validate" for more information.++extra-source-files:+- CHANGELOG.md+- LICENSE+- package.yaml+- README.md+- stack.yaml++ghc-options:+- -Wall+- -Wcompat+- -Wincomplete-record-updates+- -Wincomplete-uni-patterns+- -Wredundant-constraints++default-extensions:+- ApplicativeDo+- BangPatterns+- ConstraintKinds+- DataKinds+- DefaultSignatures+- DeriveFoldable+- DeriveFunctor+- DeriveGeneric+- DeriveLift+- DeriveTraversable+- EmptyCase+- ExistentialQuantification+- FlexibleContexts+- FlexibleInstances+- FunctionalDependencies+- GADTs+- GeneralizedNewtypeDeriving+- InstanceSigs+- KindSignatures+- LambdaCase+- MultiParamTypeClasses+- MultiWayIf+- NamedFieldPuns+- OverloadedStrings+- RankNTypes+- ScopedTypeVariables+- StandaloneDeriving+- TupleSections+- TypeApplications+- TypeFamilies++dependencies:+- base >= 4.11 && < 5+- exceptions >= 0.9 && < 1+- monad-control >= 1 && < 2+- mtl+- transformers+- transformers-base < 1++library:+  dependencies: []+  source-dirs: src++tests:+  monad-validate-test-suite:+    dependencies:+    - aeson+    - aeson-qq+    - hspec+    - monad-validate+    - scientific+    - text+    - unordered-containers+    - vector+    ghc-options:+    - -rtsopts+    - -threaded+    - -with-rtsopts=-N+    main: Main.hs+    source-dirs: test

@@ -0,0 +1,21 @@+-- | This module defines the 'ValidateT' monad transformer and 'MonadValidate' typeclass. As the+-- names imply, they are intended to be used to write data validators, but they are general enough+-- that you may find other uses for them, too. For an overview of this library’s functionality, see+-- the documentation for 'ValidateT'.+module Control.Monad.Validate (+  -- * The ValidateT monad transformer+    ValidateT+  , runValidateT+  , execValidateT++  -- * The MonadValidate class+  , MonadValidate(..)++  -- * The Validate monad+  , Validate+  , runValidate+  , execValidate+  ) where++import Control.Monad.Validate.Class+import Control.Monad.Validate.Internal

@@ -0,0 +1,64 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE UndecidableInstances #-}++module Control.Monad.Validate.Class+  ( MonadValidate(..)+  ) where++import qualified Control.Monad.Trans.RWS.CPS as CPS+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.CPS as CPS+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Control.Monad.Trans.Class+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader++{-| 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+'Control.Monad.Error.Class.MonadError' and 'Control.Monad.Writer.Class.MonadWriter', but it isn’t+entirely like either. The two essential differences are:++  1. Unlike 'Control.Monad.Error.Class.throwError', raising an error using 'refute' does not always+     abort the entire computation—it may only abort a local part of it.++  2. Unlike 'Control.Monad.Writer.Class.tell', raising an error using 'dispute' still causes the+     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'.+-}+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).+  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.+  dispute :: e -> m ()++  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++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)

@@ -0,0 +1,508 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE UndecidableInstances #-}++-- | __This is an internal module.__ Backwards compatibility will not be maintained. See+-- "Control.Monad.Validate" for the public interface.+module Control.Monad.Validate.Internal where++import Control.Monad.IO.Class+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Except+import Control.Monad.Reader.Class+import Control.Monad.State.Strict+import Control.Monad.Trans.Control+import Control.Monad.Writer.Class+import Data.Functor+import Data.Functor.Identity+import Data.Tuple (swap)+import GHC.Stack (HasCallStack)++import Control.Monad.Validate.Class++{-| 'ValidateT' is a monad transformer for writing validations. Like 'ExceptT', 'ValidateT' is+primarily concerned with the production of errors, but it differs from 'ExceptT' in that 'ValidateT'+is designed not to necessarily halt on the first error. Instead, it provides a mechanism for+collecting many warnings or errors, ideally as many as possible, before failing. In that sense,+'ValidateT' is also somewhat like 'Control.Monad.Writer.WriterT', but it is not /just/ a combination+of 'ExceptT' and 'Control.Monad.Writer.WriterT'. Specifically, it differs in the following two+respects:++  1. 'ValidateT' automatically collects errors from all branches of an 'Applicative' expression,+     making it possible to write code in the same style that one would use with 'ExceptT' and+     automatically get additional information for free. (This is especially true when used in+     combination with the @ApplicativeDo@ language extension.)++  2. 'ValidateT' provides error signaling operators, 'refute' and 'dispute', which are similar to+     'throwError' and 'tell', respectively. However, both operators combine raised errors into a+     single value (using an arbitrary 'Semigroup'), so the relative ordering of validation errors is+     properly respected. (Of course, if the order doesn’t matter to you, you can choose to+     accumulate errors into an unordered container.)++== An introduction to 'ValidateT'++The first of the above two points is by far the most interesting feature of 'ValidateT'. Let’s make+it more concrete with an example:++@+>>> 'runValidate' ('refute' ["bang"] '*>' 'refute' ["boom"])+'Left' ["bang", "boom"]+@++At first blush, the above example may lead you to believe that 'refute' is like 'tell' from+'Control.Monad.Writer.WriterT', but it is actually more like 'throwError'. Consider its type:++@+'refute' :: 'MonadValidate' e m => e -> m a+@++Note that, like 'throwError', 'refute' is polymorphic in its return type, which is to say it never+returns. Indeed, if we introduce a dependency on a computation that fails using 'refute' via+'>>=', the downstream computation will not be run:++@+>>> let getString = 'refute' ["bang"] '*>' 'pure' "boom"+        useString a = 'refute' [a]+    in 'runValidate' (getString '>>=' useString)+'Left' ["bang"]+@++This works because although the 'Monad' instance for 'ValidateT' fails as soon as the first 'refute'+is executed (as it must due to the way the second argument of '>>=' depends on the result of its+first argument), the 'Applicative' instance runs all branches of '<*>' and combines the errors+produced by all of them. When @ApplicativeDo@ is enabled, this can lead to some “magical” looking+error reporting where validation automatically continues on each sub-piece of a piece of data until+it absolutely cannot proceed any further. As an example, this package’s test suite includes the+following function:++@+validateQueryRequest :: ('MonadReader' Env m, 'MonadValidate' [Error] m) => Value -> m QueryRequest+validateQueryRequest req = withObject "request" req '$' \o -> do+  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") '$'+    validateQuery qrTable tableInfo (atIsAdmin qrAuth) qrQuery+  'pure' QueryRequest { qrAuth, qrTable, qrQuery }+@++The above @do@ block parses and validates some JSON, and it’s written as straight line code, but+with @ApplicativeDo@ enabled (along with the @-foptimal-applicative-do@ option, which makes GHC try+a little harder), it still produces errors for all parts of the input document at once:++@+>>> 'flip' 'Control.Monad.Reader.runReader' env '.' 'runValidateT' '$' validateQueryRequest [aesonQQ|+      { "auth_token": 123+      , "table": { "name": "users" }+      , "query": { "add":+        [ { "lit": "42" }+        , { "select": "points" } ]}+      }|]+'Left' [ Error ["auth_token"] (JSONBadValue "string" (Number 123))+     , Error ["table"] (JSONMissingKey "schema")+     , Error ["query", "add", "lit"] (JSONBadValue "number" (String "42")) ]+@++The penultimate statement in the @do@ block—the one with the call to @validateQuery@—depends on+several of the bindings bound earlier in the same @do@ block, namely @qrAuth@, @info@, and+@qrQuery@. Because of that, @validateQuery@ will not be executed so long as any of its dependencies+fail. As soon as they all succeed, their results will be passed to @validateQuery@ as usual, and+validation will continue.++== The full details++Although 'ValidateT' (with @ApplicativeDo@) may seem magical, of course, it is not. As alluded to+above, 'ValidateT' simply provides a '<*>' implementation that collects errors produced by both+arguments rather than short-circuiting as soon as the first error is raised.++However, that explanation alone may raise some additional questions. What about the monad laws? When+'ValidateT' is used in a monad transformer stack, what happens to side effects? And what are+'ValidateT'’s performance characteristics? The remainder of this section discusses those topics.++=== 'ValidateT' and the 'Monad' laws++'ValidateT'’s 'Applicative' and 'Monad' instances do not conform to a strict interpretation of the+'Monad' laws, which dictate that '<*>' must be equivalent to 'ap'. For 'ValidateT', this is not true+if we consider “equivalent” to mean '=='. However, if we accept a slightly weaker notion of+equivalence, we can satisfy the laws. Specifically, we may use the definition that some 'Validate'+action @a@ is equivalent to another action @b@ iff++  * if @'runValidate' a@ produces @'Right' x@, then @'runValidate' b@ must produce @'Right' y@ where+    @x '==' y@ (and '==' is the usual Haskell '=='),++  * and if @'runValidate' a@ produces @'Left' x@, then @'runValidate' b@ must produce @'Left' y@+    (but @x@ and @y@ may be unrelated).++In other words, our definition of equivalence is like '==', except that we make no guarantees about+the /contents/ of an error should one occur. However, we /do/ guarantee that replacing '<*>' with+'ap' or vice versa will never change an error to a success or a success to an error, nor will it+change the value of a successful result in any way. To put it another way, 'ValidateT' provides+“best effort” error reporting: it will never return fewer errors than an equivalent use of+'ExceptT', but it might return more.++=== Using 'ValidateT' with other monad transformers++'ValidateT' is a valid, lawful, generally well-behaved monad transformer, and it is safe to use+within a larger monad transformer stack. Instances for the most common @mtl@-style typeclasses are+provided. __However__, be warned: many common monad transformers do not have sufficiently+order-independent 'Applicative' instances for 'ValidateT'’s 'Applicative' instance to actually+collect errors from multiple branches of a computation.++To understand why that might be, consider that 'StateT' must enforce a left-to-right evaluation+order for '<*>' in order to thread the state through the computation. If the @a@ action in an+expression @a '<*>' b@ fails, then it is simply not possible to run @b@ since @b@ may still depend+on the state that would have been produced by @a@. Similarly, 'ExceptT' enforces a left-to-right+evaluation because it aborts a computation as soon as an error is thrown. Using 'ValidateT' with+these kinds of monad transformers will cause it to effectively degrade to+'Control.Monad.Writer.WriterT' over 'ExceptT' since it will not be able to gather any errors+produced by 'refute' beyond the first one.++However, even that isn’t the whole story, since the relative order of monads in a monad transformer+stack can affect things further. For example, while the 'StateT' monad transformer enforces+left-to-right evaluation order, it only does this for the monad /underneath/ it, so although+@'StateT' s ('ValidateT' e)@ will not be able to collect multiple errors, @'ValidateT' e+('State' s)@ will. Note, however, that those two types differ in other ways, too—running each to+completion results in different types:++@+'runState' ('runValidateT' m) s :: ('Either' e a, s)+'runValidate' ('runStateT' m s) :: 'Either' e (a, s)+@++That kind of difference is generally true when using monad transformers—the two combinations of+'ExceptT' and 'StateT' have the same types as above, for example—but because 'ValidateT' needs to be+on top of certain transformers for it to be useful, combining 'ValidateT' with certain transformers+may be of little practical use.++One way to identify which monad transformers are uncooperative in the aforementioned way is to look+at the constraints included in the context of the transformer’s 'Applicative' instance. Transformers+like 'Control.Monad.State.StateT' have instances of the shape++@+instance 'Monad' m => 'Applicative' ('StateT' s m)+@++which notably require 'Monad' instances just to implement 'Applicative'! However, this is not always+sufficient for distinguishing which functions or instances use '<*>' and which use '>>=', especially+since many older libraries (which predate 'Applicative') may include 'Monad' contraints even when+they only use features of 'Applicative'. The only way to be certain is to examine the+implementation (or conservatively write code that is explicitly restricted to 'Applicative').++(As it happens, 'ValidateT'’s 'Applicative' is actually one such “uncooperative” instance itself: it+has a 'Monad' constraint in its context. It is possible to write an implementation of 'ValidateT'+without that constraint, but its '<*>' would necessarily leak space in the same way+'Control.Monad.Writer.WriterT'’s '>>=' leaks space. If you have a reason to want the less efficient+but more permissive variant, please let the author of this library know, as she would probably find+it interesting.)++== Performance characteristics of 'ValidateT'++Although the interface to 'ValidateT' is minimal, there are surprisingly many different ways to+implement it, each with its own set of performance tradeoffs. Here is a quick summary of the choices+'ValidateT' makes:++  1. 'ValidateT' is __strict__ in the set of errors it accumulates, which is to say it reduces them+     to weak head normal form (WHNF) via 'seq' immediately upon any call to 'refute' or 'dispute'.++  2. Furthermore, all of 'ValidateT'’s operations, including '<*>', operate in __constant space__.+     This means, for example, that evaluating @'sequence_' xs@ will consume constant space+     regardless of the size of @xs@, not counting any space consumed purely due to the relevant+     'Foldable' instance’s traversal of @xs@.++  3. Finally, 'ValidateT' accumulates errors in a __left-associative__ manner, which is to say that+     any uses of 'refute' or 'dispute' combine the existing set of errors, @e@, with the added set+     of errors, @e'@, via the expression @e '<>' e'@.++A good rule of thumb is that 'ValidateT' has similar performance characteristics to+@'Data.Foldable.foldl'' ('<>')@, while types like @Validation@ from the @either@ package tend to+have similar performance characteristics to @'foldr' ('<>')@. That decision has both significant+advantages and significant disadvantages; the following subsections elaborate further.++=== '<*>' takes constant space++Great care has been taken in the implementation of '<*>' to ensure it does not leak space. Notably,+the same /cannot/ be said for many existing implementations of similar concepts. For example, you+will find that executing the expression++@+let m () = 'pure' () '*>' m () in m ()+@++may continuously allocate memory until it is exhausted for types such as @Validation@ (from the+@either@ package), but 'ValidateT' will execute it in constant space. This point may seem silly,+since the above definition of @m ()@ will never do anything useful, anyway, but the same point also+applies to operations like 'sequence_'.++In practice, this issue matters far less for types like @Validation@ than it does for 'ValidateT',+as @Validation@ and its cousins don’t have a 'Monad' instance and do not generally experience the+same usage patterns. (The additional laziness they are capable of can sometimes even avoid the space+leak altogether.) However, it can be relevant more often for 'ValidateT', so this implementation+makes choices to avoid the potential for the leak altogether.++=== Errors are accumulated using strict, left-associated '<>'++A major consequence of the decision to both strictly accumulate state and maintain constant space is+that 'ValidateT'’s internal applications of '<>' to combine errors are naturally strict and+left-associated, not lazy and right-associated like they are for types like @Validation@. If the+number of errors your validation generates is small, this difference is irrelevant, but if it is+large, the difference in association can prove disastrous if the 'Semigroup' you choose to+accumulate errors in is @[a]@!++To make it painfully explicit why using @[a]@ can come back to bite you, consider that each time+'ValidateT' executes @'refute' e'@, given some existing collection of errors @e@, it (strictly)+evalutes @e '<>' e'@ to obtain a new collection of errors. Now consider the implications of that+if @e@ is a ten thousand element list: '<>' will have to traverse /all/ ten thousand elements and+reallocate a fresh cons cell for every single one in order to build the new list, even if just one+element is being appended to the end! Unfortunately, the ubiquitous, built-in @[a]@ type is clearly+an exceptionally poor choice for this pattern of accumulation.++Fortunately, the solution is quite simple: use a different data structure. If order doesn’t matter,+use a @Set@ or @HashSet@. If it does, but either LIFO consumption of the data is okay or you are+okay with paying to reverse the data once after collecting the errors, @'Data.Semigroup.Dual' [a]@+to accumulate elements in an efficient manner. If neither is true, use a data structure like @Seq@+that provides an efficient implementation of a functional queue. You can always convert back to a+plain list at the end once you’re done, if you have to. -}+newtype ValidateT e m a = ValidateT+  { getValidateT :: forall s. StateT (MonoMaybe s e) (ExceptT e m) a }+-- Sadly, GeneralizedNewtypeDeriving can’t help us here due to the inner forall, but we can at least+-- derive the Functor instance.+deriving instance (Functor m) => Functor (ValidateT e m)++validateT+  :: forall e m a. (Functor m)+  => (forall s. MonoMaybe s e -> m (Either e (MonoMaybe s e, a)))+  -> ValidateT e m a+validateT f = ValidateT (StateT (ExceptT . (fmap (fmap swap) . f)))+{-# INLINE validateT #-}++unValidateT+  :: forall s e m a. (Functor m)+  => MonoMaybe s e -> ValidateT e m a -> m (Either e (MonoMaybe s e, a))+unValidateT e (ValidateT m) = runExceptT (swap <$> runStateT m e)+{-# INLINE unValidateT #-}++instance (Monad m) => Applicative (ValidateT e m) where+  pure v = ValidateT (pure v)+  {-# INLINE pure #-}++  m1 <*> m2 = validateT $ \e0 ->+    unValidateT e0 m1 >>= \case+      Left e1 -> unValidateT (MJust @'SJust e1) m2 <&> \case+        Left e2 -> Left e2+        Right (MJust e2, _) -> Left e2+      Right (e1, v1) -> unValidateT e1 m2 <&> \case+        Left e2 -> Left e2+        Right (e2, v2) -> Right (e2, v1 v2)+  {-# INLINABLE (<*>) #-}++instance (Monad m) => Monad (ValidateT e m) where+  ValidateT x >>= f = ValidateT (x >>= (getValidateT . f))+  {-# INLINE (>>=) #-}++instance MonadTrans (ValidateT e) where+  lift m = ValidateT (lift $ lift m)+  {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (ValidateT e m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}++instance (MonadBase b m) => MonadBase b (ValidateT e m) where+  liftBase = lift . liftBase+  {-# INLINE liftBase #-}++-- | An opaque type used to capture the current state of a 'ValidateT' computation, used as the+-- 'StT' instance for 'ValidateT'. It is opaque in an attempt to protect internal invariants about+-- the state, but it is unfortunately still theoretically possible for it to be misused (but such+-- misuses are exceedingly unlikely).+data ValidateTState e a = forall s. ValidateTState+  { getValidateTState :: Either e (MonoMaybe s e, a) }+deriving instance (Show e, Show a) => Show (ValidateTState e a)+deriving instance Functor (ValidateTState e)++instance MonadTransControl (ValidateT e) where+  type StT (ValidateT e) a = ValidateTState e a++  liftWith f = validateT $ \e ->+    Right . (e,) <$> f (fmap ValidateTState . unValidateT e)+  {-# INLINABLE liftWith #-}++  restoreT :: (HasCallStack, Monad m) => m (StT (ValidateT e) a) -> ValidateT e m a+  restoreT m = validateT $ \e1 -> do+    ValidateTState r <- m+    case e1 of+      MNothing -> case r of+        Left e2             -> pure $ Left e2+        Right (MJust e2, v) -> pure $ Right (MJust e2, v)+        Right (MNothing, v) -> pure $ Right (MNothing, v)+      MJust _ -> case r of+        Left e2             -> pure $ Left e2+        Right (MJust e2, v) -> pure $ Right (MJust e2, v)+        Right (MNothing, _) -> error+          $  "Control.Monad.Validate.ValidateT#restoreT: panic!\n"+          <> "  An attempt was made to restore from a state captured before any validation\n"+          <> "  errors occurred into a context with validation errors. This is probably the\n"+          <> "  result of an incorrect use of MonadBaseControl (as validation errors should\n"+          <> "  strictly increase). Ensure that all state is restored immediately upon\n"+          <> "  returning from the base monad (or is not restored at all).\n"+          <> "\n"+          <> "  If you believe your use of MonadBaseControl is not in error, and this is a bug\n"+          <> "  in ValidateT, please submit a bug report."+  {-# INLINABLE restoreT #-}++instance (MonadBaseControl b m) => MonadBaseControl b (ValidateT e m) where+  type StM (ValidateT e m) a = ComposeSt (ValidateT e) m a+  liftBaseWith = defaultLiftBaseWith+  restoreM = defaultRestoreM+  {-# INLINE liftBaseWith #-}+  {-# INLINE restoreM #-}++liftCatch+  :: (Functor m)+  => (forall b. m b -> (e -> m b) -> m b)+  -> ValidateT d m a -> (e -> ValidateT d m a) -> ValidateT d m a+liftCatch catchE m f = validateT $ \e ->+  catchE (unValidateT e m) (unValidateT e . f)+{-# INLINE liftCatch #-}++instance (MonadError e m) => MonadError e (ValidateT a m) where+  throwError = lift . throwError+  catchError = liftCatch catchError+  {-# INLINE throwError #-}+  {-# INLINE catchError #-}++instance (MonadReader r m) => MonadReader r (ValidateT e m) where+  ask = lift ask+  local f (ValidateT m) = ValidateT (local f m)+  reader = lift . reader+  {-# INLINE ask #-}+  {-# INLINE local #-}+  {-# INLINE reader #-}++instance (MonadState s m) => MonadState s (ValidateT e m) where+  get = lift get+  put = lift . put+  state = lift . state+  {-# INLINE get #-}+  {-# INLINE put #-}+  {-# INLINE state #-}++instance (MonadWriter w m) => MonadWriter w (ValidateT e m) where+  writer = lift . writer+  tell = lift . tell+  listen (ValidateT m) = ValidateT (listen m)+  pass (ValidateT m) = ValidateT (pass m)+  {-# INLINE writer #-}+  {-# INLINE tell #-}+  {-# INLINE listen #-}+  {-# INLINE pass #-}++instance (MonadThrow m) => MonadThrow (ValidateT e m) where+  throwM = lift . throwM+  {-# INLINE throwM #-}++instance (MonadCatch m) => MonadCatch (ValidateT e m) where+  catch = liftCatch catch+  {-# INLINE catch #-}++liftMask+  :: (Functor m)+  => (forall c. ((forall a. m a -> m a) -> m c) -> m c)+  -> ((forall a. ValidateT e m a -> ValidateT e m a) -> ValidateT e m b) -> ValidateT e m b+liftMask maskE f = validateT $ \e1 ->+  maskE $ \unmask ->+    unValidateT e1 $ f $ \m ->+      validateT $ \e2 ->+        unmask $ unValidateT e2 m+{-# INLINE liftMask #-}++instance (MonadMask m) => MonadMask (ValidateT e m) where+  mask = liftMask mask+  uninterruptibleMask = liftMask uninterruptibleMask+  generalBracket m f g = ValidateT $ generalBracket+    (getValidateT m)+    (\a b -> getValidateT $ f a b)+    (\a -> getValidateT $ g a)+  {-# INLINE mask #-}+  {-# INLINE uninterruptibleMask #-}+  {-# INLINE generalBracket #-}++instance (Monad m, Semigroup e) => MonadValidate e (ValidateT e m) where+  refute e2 = validateT $ \e1 ->+    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, ()))+  {-# INLINABLE refute #-}+  {-# INLINABLE dispute #-}++-- | Runs a 'ValidateT' computation, returning the errors raised by 'refute' or 'dispute' if any,+-- otherwise returning the computation’s result.+runValidateT :: forall e m a. (Functor m) => ValidateT e m a -> m (Either e a)+runValidateT m = unValidateT MNothing m <&> \case+  Left e              -> Left e+  Right (MJust e, _)  -> Left e+  Right (MNothing, v) -> Right v++-- | Runs a 'ValidateT' computation, returning the errors on failure or 'mempty' on success. The+-- computation’s result, if any, is discarded.+--+-- >>> execValidate (refute ["bang"])+-- ["bang"]+-- >>> execValidate @[] (pure 42)+-- []+execValidateT :: forall e m a. (Monoid e, Functor m) => ValidateT e m a -> m e+execValidateT = fmap (either id mempty) . runValidateT++-- | '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++-- | See 'execValidateT'.+execValidate :: forall e a. (Monoid e) => Validate e a -> e+execValidate = runIdentity . execValidateT++{-| Monotonically increasing 'Maybe' values. A function with the type++@+forall s. 'MonoMaybe' s Foo -> 'MonoMaybe' s Bar+@++may return 'MNothing' only when given 'MNothing', but it may return 'MJust' for any input. This+is useful for keeping track of the error state within 'ValidateT', since we want to statically+prevent the possibility of a 'ValidateT' action being passed a nonempty set of errors but returning+no errors.++The benefit of this additional type tracking shows up most prominently in the implementation of+'<*>'. Consider an expression @x '<*>' y@, where @x@ is an action that fails, but @y@ is an action+that succeeds. We pass the errors returned by @x@ to @y@, then pattern-match on @y@’s result. If @y@+succeeds, we’ll end up with a tuple of type @('MonoMaybe' ''SJust' e, a)@. We can’t use the second+element of that tuple at all because we need to return a value of type @b@, but the only way to get+one is to apply a function of type @a -> b@ returned by @x@… which we don’t have, since @x@ failed.++Since we can’t produce a value of type @'Right' b@, our only option is to return a value of type+@'Left' e@. But if the first element of the tuple had type @'Maybe' e@, we’d now be in a sticky+situation! Its value could be 'Nothing', but we need it to be @'Just' e@ since we only have a+'Semigroup' instance for @e@, not a 'Monoid' instance, so we can’t produce an @e@ out of thin air.+However, by returning a 'MonoMaybe', we guarantee that the result will be @'MJust' e@, and we can+proceed safely.+-}+data MonoMaybe s a where+  MNothing :: MonoMaybe 'SMaybe a+  MJust :: forall s a. !a -> MonoMaybe s a+deriving instance (Show a) => Show (MonoMaybe s a)+deriving instance (Eq a) => Eq (MonoMaybe s a)+deriving instance (Ord a) => Ord (MonoMaybe s a)+deriving instance Functor (MonoMaybe s)++-- | The kind of types used to track the current state of a 'MonoMaybe' value.+data MonoMaybeS = SMaybe | SJust++-- | Like 'maybe' but for 'MonoMaybe'.+monoMaybe :: (s ~ 'SMaybe => b) -> (a -> b) -> MonoMaybe s a -> b+monoMaybe v f = \case+  MNothing -> v+  MJust x  -> f x+{-# INLINE monoMaybe #-}

@@ -0,0 +1,4 @@+resolver: lts-13.30+packages: [.]+extra-deps: []+flags: {}

@@ -0,0 +1,223 @@+{-# OPTIONS_GHC -foptimal-applicative-do #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Monad.ValidateSpec (spec) where++import qualified Data.HashMap.Strict as M+import qualified Data.Text as T+import qualified Data.Vector as V++import Control.Monad+import Control.Monad.Reader+import Data.Aeson (Object, Value(..))+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+import Test.Hspec++import Control.Monad.Validate++data AuthToken = AuthToken { atBearer :: Text, atIsAdmin :: Bool }+  deriving (Show, Eq)++data TableName = TableName { tnSchema :: Text, tnName :: Text }+  deriving (Show, Eq)+newtype ColumnName = ColumnName { cnName :: Text }+  deriving (Show, Eq)++type TableInfo = [(ColumnName, ColumnInfo)]+newtype ColumnInfo = ColumnInfo { ciAdminOnly :: Bool }+  deriving (Show, Eq)++data Env = Env+  { envTables :: [(TableName, TableInfo)]+  , envPath :: [Text] }+  deriving (Show, Eq)++data Query a where+  QLit :: Integer -> Query Integer+  QSelect :: ColumnName -> Query Integer+  QAdd :: Query Integer -> Query Integer -> Query Integer+  QEqual :: Query Integer -> Query Integer -> Query Bool+  QIf :: Query Bool -> Query a -> Query a -> Query a+deriving instance Show (Query a)+deriving instance Eq (Query a)++data QueryRequest = QueryRequest+  { qrAuth :: AuthToken+  , qrTable :: TableName+  , qrQuery :: Query Integer }+  deriving (Show, Eq)++data Error = Error { errPath :: [Text], errInfo :: ErrorInfo }+  deriving (Show, Eq)+data ErrorInfo+  = JSONBadValue Text Value+  | JSONMissingKey Text+  | InvalidAuthToken Text+  | UnknownTableName TableName+  | UnknownQueryOperator Text+  | TypeError TypeRep TypeRep+  | UnknownColumnName TableName ColumnName+  | InsufficientPermissions TableName ColumnName+  deriving (Show, Eq)++validateQueryRequest :: forall m. (MonadReader Env m, MonadValidate [Error] m) => Value -> m QueryRequest+validateQueryRequest req = withObject "request" req $ \o -> do+  qrAuth           <- withKey o "auth_token" parseAuthToken+  ~(qrTable, info) <- withKey o "table" parseTableName+  qrQuery          <- withKey o "query" parseQuery+  for_ info $ \tableInfo -> local (pushPath "query") $+    validateQuery qrTable tableInfo (atIsAdmin qrAuth) qrQuery+  pure QueryRequest { qrAuth, qrTable, qrQuery }+  where+    parseAuthToken v = do+      str <- asString v+      case T.splitOn ":" str of+        [bearer]                                -> pure $ AuthToken bearer False+        [bearer, "super_secret_admin_password"] -> pure $ AuthToken bearer True+        _                                       -> refuteErr $ InvalidAuthToken str++    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+      pure (name, 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+      "select" -> withType $ QSelect <$> parseColumnName v+      "add"    -> withType $ asPair v >>= \(a, b) -> QAdd <$> parseQuery a <*> parseQuery b+      "equal"  -> withType $ asPair v >>= \(a, b) -> QEqual <$> parseQuery a <*> parseQuery b+      "if"     -> withType @a $ asTriple v >>= \(a, b, c) ->+                    QIf <$> parseQuery a <*> parseQuery b <*> parseQuery c+      _        -> refuteErr $ UnknownQueryOperator k++    validateQuery tableName tableInfo isAdmin = loop where+      loop :: Query a -> m ()+      loop = \case+        QLit _ -> pure ()+        QSelect colName -> local (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++    parseColumnName = fmap ColumnName . asString++    pushPath path env = env { envPath = path : envPath env }+    mkErr info = asks envPath <&> \path -> Error (reverse path) info+    refuteErr = mkErr >=> \err -> refute [err]+    disputeErr = mkErr >=> \err -> dispute [err]++    withType :: forall a b. (Typeable a, Typeable b) => m (Query a) -> m (Query b)+    withType m = case eqT @a @b of+      Just Refl -> m+      Nothing -> refuteErr $ TypeError (typeRep (Proxy @a)) (typeRep (Proxy @b))++    asString = \case { String s -> pure s; v -> refuteErr $ JSONBadValue "string" v }+    asNumber = \case { Number n -> pure n; v -> refuteErr $ JSONBadValue "number" v }+    asInteger v = asNumber v >>=+      maybe (refuteErr $ JSONBadValue "integer" v) (pure . toInteger) . toBoundedInteger @Int+    asArray = \case { Array v -> pure $ V.toList v; v -> refuteErr $ JSONBadValue "array" v }+    asPair v = asArray v >>= \case { [a, b] -> pure (a, b); _ -> refuteErr $ JSONBadValue "pair" v }+    asTriple v = asArray v >>= \case { [a, b, c] -> pure (a, b, c); _ -> refuteErr $ JSONBadValue "triple" v }++    withObject :: Text -> Value -> (Object -> m a) -> m a+    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++    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 }++spec :: Spec+spec = describe "ValidateT" $+  it "collects validation information from all sub-branches of <*>" $ do+    let tables =+          [ (TableName "public" "users",+            [ (ColumnName "name", ColumnInfo False)+            , (ColumnName "password", ColumnInfo True)+            , (ColumnName "points", ColumnInfo False) ])+          , (TableName "private" "tables",+            [ (ColumnName "id", ColumnInfo False)+            , (ColumnName "schema", ColumnInfo False) ]) ]+        env = Env tables []+        testCase input = runReader (runValidateT (validateQueryRequest input)) env++    testCase [aesonQQ| {} |] `shouldBe` Left+      [ Error [] $ JSONMissingKey "auth_token"+      , Error [] $ JSONMissingKey "table"+      , Error [] $ JSONMissingKey "query" ]++    testCase [aesonQQ| { "auth_token": null, "table": null, "query": null } |] `shouldBe` Left+      [ Error ["auth_token"] $ JSONBadValue "string" Null+      , Error ["table"] $ JSONBadValue "table name" Null+      , Error ["query"] $ JSONBadValue "query expression" Null ]++    testCase [aesonQQ|+      { "auth_token": "abc123"+      , "table": { "schema": "public", "name": "people" }+      , "query": { "lit": "42" }+      } |] `shouldBe` Left+      [ Error ["table"] $ UnknownTableName (TableName "public" "people")+      , Error ["query", "lit"] $ JSONBadValue "number" (String "42") ]++    testCase [aesonQQ|+      { "auth_token": "abc123"+      , "table": { "schema": "public", "name": "users" }+      , "query": { "lit": 42 }+      } |] `shouldBe` Right QueryRequest+      { qrAuth = AuthToken "abc123" False+      , qrTable = TableName "public" "users"+      , qrQuery = QLit 42 }++    testCase [aesonQQ|+      { "auth_token": "abc123"+      , "table": { "schema": "public", "name": "users" }+      , "query": { "add":+        [ { "select": "password" }+        , { "select": "email" } ]}+      } |] `shouldBe` Left+      [ Error ["query", "add", "select"] $ InsufficientPermissions+          (TableName "public" "users")+          (ColumnName "password")+      , Error ["query", "add", "select"] $ UnknownColumnName+          (TableName "public" "users")+          (ColumnName "email") ]++    testCase [aesonQQ|+      { "auth_token": "abc123:super_secret_admin_password"+      , "table": { "schema": "public", "name": "users" }+      , "query": { "add":+        [ { "select": "name" }+        , { "select": "password" } ]}+      } |] `shouldBe` Right QueryRequest+      { qrAuth = AuthToken "abc123" True+      , qrTable = TableName "public" "users"+      , qrQuery = QAdd (QSelect (ColumnName "name")) (QSelect (ColumnName "password")) }++    testCase [aesonQQ|+      { "auth_token": 123+      , "table": { "name": "users" }+      , "query": { "add":+        [ { "lit": "42" }+        , { "select": "points" } ]}+      } |] `shouldBe` Left+      [ Error ["auth_token"] (JSONBadValue "string" (Number 123))+      , Error ["table"] (JSONMissingKey "schema")+      , Error ["query", "add", "lit"] (JSONBadValue "number" (String "42")) ]

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}