├── .github └── workflows │ └── build.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── cabal.project.ci ├── monad-validate.cabal ├── src └── Control │ └── Monad │ ├── Validate.hs │ └── Validate │ ├── Class.hs │ └── Internal.hs └── test ├── Control └── Monad │ └── ValidateSpec.hs └── Main.hs /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: [push, pull_request] 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | strategy: 7 | fail-fast: false 8 | matrix: 9 | ghc: ['8.6.5', '8.8.4', '8.10.7', '9.0.2', '9.2.8', '9.4.6', '9.6.2'] 10 | name: Build with GHC ${{ matrix.ghc }} 11 | steps: 12 | - uses: actions/checkout@v2 13 | - name: Setup Haskell 14 | uses: haskell/actions/setup@v1 15 | with: 16 | ghc-version: ${{ matrix.ghc }} 17 | 18 | - run: cp cabal.project.ci cabal.project.local 19 | - run: cabal v2-update 20 | - run: cabal v2-freeze 21 | - uses: actions/cache@v2 22 | with: 23 | path: ~/.cabal/store 24 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 25 | restore-keys: | 26 | ${{ runner.os }}-${{ matrix.ghc }}- 27 | 28 | - run: cabal v2-build 29 | - run: cabal v2-test 30 | - run: cabal v2-sdist 31 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle 2 | /cabal.project.local 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.3.0.0 [2023-08-17] 2 | 3 | - Added `MonadFix` instance for `ValidateT`. 4 | 5 | # 1.2.0.2 [2023-08-17] 6 | 7 | - Added support for mtl 2.3. 8 | 9 | # 1.2.0.1 [2022-07-05] 10 | 11 | - Added support for GHC 9.0 and 9.2. 12 | 13 | # 1.2.0.0 [2019-08-09] 14 | 15 | - Added the `exceptToValidate`, `exceptToValidateWith`, `validateToError`, and `validateToErrorWith` functions for converting between different error-raising monads. 16 | - Removed the `DefaultSignatures`-based default methods for `MonadValidate` in favor of a `WrappedMonadTrans` newtype available from `Control.Monad.Validate.Class` that can be used to derive instances using `DerivingVia`. 17 | - Added a default implementation of `dispute` in terms of `refute` and `tolerate` and added their equivalence as a law for `MonadValidate`. 18 | 19 | # 1.1.0.0 [2019-08-05] 20 | 21 | - Added the `tolerate` method to `MonadValidate`, which allows relaxing validation errors from fatal to nonfatal. 22 | - Added the `embedValidateT` and `mapErrors` functions, which can be used together to locally alter the type of validation errors in `ValidateT` computations. 23 | - Removed the `MonadValidate` instance for `ContT`, which is no longer possible to implement due to the addition of `tolerate`. 24 | 25 | # 1.0.0.0 [2019-08-04] 26 | 27 | - Initial release. 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Hasura, 2022 Alexis King 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 13 | THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # monad-validate [![Build Status](https://img.shields.io/github/actions/workflow/status/lexi-lambda/monad-validate/build.yml?branch=master)](https://github.com/lexi-lambda/monad-validate/actions/workflows/build.yml) [![Hackage](https://img.shields.io/badge/hackage-1.3.0.0-5e5184)][hackage] 2 | 3 | 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. 4 | 5 | See [the documentation on Hackage][hackage] for more information and examples. 6 | 7 | [hackage]: https://hackage.haskell.org/package/monad-validate 8 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | jobs: $ncpus 3 | 4 | package monad-validate 5 | ghc-options: -j 6 | -------------------------------------------------------------------------------- /cabal.project.ci: -------------------------------------------------------------------------------- 1 | package monad-validate 2 | ghc-options: 3 | -Werror 4 | -- harmless unused import with GHC mtl <2.3 5 | -Wwarn=unused-imports 6 | -- warning generated by derived MonadTrans instance with GHC 9.6 7 | -Wwarn=redundant-constraints 8 | documentation: true 9 | benchmarks: true 10 | tests: true 11 | -------------------------------------------------------------------------------- /monad-validate.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: monad-validate 3 | version: 1.3.0.0 4 | category: Control 5 | build-type: Simple 6 | 7 | synopsis: A monad transformer for data validation. 8 | description: 9 | Provides the 'ValidateT' monad transformer, designed for writing data 10 | validations that provide high-quality error reporting without much effort. 11 | 'ValidateT' automatically exploits the data dependencies of your program—as 12 | encoded implicitly in uses of 'fmap', '<*>', and '>>='—to report as many 13 | errors as possible upon failure instead of completely aborting at the first 14 | one. See "Control.Monad.Validate" for more information. 15 | 16 | author: Alexis King 17 | maintainer: Alexis King 18 | copyright: 2019 Hasura, 2022 Alexis King 19 | license: ISC 20 | license-file: LICENSE 21 | homepage: https://github.com/lexi-lambda/monad-validate 22 | bug-reports: https://github.com/lexi-lambda/monad-validate/issues 23 | 24 | extra-source-files: 25 | CHANGELOG.md 26 | LICENSE 27 | README.md 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/lexi-lambda/monad-validate 32 | 33 | common common 34 | ghc-options: 35 | -Wall 36 | -Wcompat 37 | -Wincomplete-record-updates 38 | -Wincomplete-uni-patterns 39 | -Wredundant-constraints 40 | 41 | default-language: Haskell2010 42 | default-extensions: 43 | ApplicativeDo 44 | BangPatterns 45 | ConstraintKinds 46 | DataKinds 47 | DeriveFoldable 48 | DeriveFunctor 49 | DeriveGeneric 50 | DeriveLift 51 | DeriveTraversable 52 | DerivingVia 53 | EmptyCase 54 | ExistentialQuantification 55 | FlexibleContexts 56 | FlexibleInstances 57 | FunctionalDependencies 58 | GADTs 59 | GeneralizedNewtypeDeriving 60 | InstanceSigs 61 | KindSignatures 62 | LambdaCase 63 | MultiParamTypeClasses 64 | MultiWayIf 65 | NamedFieldPuns 66 | OverloadedStrings 67 | RankNTypes 68 | ScopedTypeVariables 69 | StandaloneDeriving 70 | TupleSections 71 | TypeApplications 72 | TypeFamilies 73 | TypeOperators 74 | 75 | build-depends: 76 | , base >=4.12 && <5 77 | , exceptions >=0.9 && <1 78 | , monad-control ==1.* 79 | , mtl 80 | , transformers >=0.5.6 81 | , transformers-base <1 82 | 83 | library 84 | import: common 85 | hs-source-dirs: src 86 | exposed-modules: 87 | Control.Monad.Validate 88 | Control.Monad.Validate.Class 89 | Control.Monad.Validate.Internal 90 | 91 | test-suite monad-validate-test-suite 92 | import: common 93 | type: exitcode-stdio-1.0 94 | 95 | ghc-options: -rtsopts -threaded -with-rtsopts=-N 96 | build-depends: 97 | , aeson >=2 && <3 98 | , aeson-qq 99 | , hspec 100 | , monad-validate 101 | , scientific 102 | , text 103 | , unordered-containers 104 | , vector 105 | build-tool-depends: 106 | , hspec-discover:hspec-discover 107 | 108 | hs-source-dirs: test 109 | main-is: Main.hs 110 | other-modules: 111 | Control.Monad.ValidateSpec 112 | -------------------------------------------------------------------------------- /src/Control/Monad/Validate.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines the 'ValidateT' monad transformer and 'MonadValidate' typeclass. As the 2 | -- names imply, they are intended to be used to write data validators, but they are general enough 3 | -- that you may find other uses for them, too. For an overview of this library’s functionality, see 4 | -- the documentation for 'ValidateT'. 5 | module Control.Monad.Validate ( 6 | -- * The @ValidateT@ monad transformer 7 | ValidateT 8 | , runValidateT 9 | , execValidateT 10 | , embedValidateT 11 | , mapErrors 12 | 13 | -- * The @MonadValidate@ class 14 | , MonadValidate(..) 15 | 16 | -- * Converting between monads 17 | , exceptToValidate 18 | , exceptToValidateWith 19 | , validateToError 20 | , validateToErrorWith 21 | 22 | -- * The @Validate@ monad 23 | , Validate 24 | , runValidate 25 | , execValidate 26 | ) where 27 | 28 | import Control.Monad.Validate.Class 29 | import Control.Monad.Validate.Internal 30 | -------------------------------------------------------------------------------- /src/Control/Monad/Validate/Class.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Control.Monad.Validate.Class 5 | ( MonadValidate(..) 6 | , exceptToValidate 7 | , exceptToValidateWith 8 | 9 | -- * Deriving @MonadValidate@ instances with @DerivingVia@ 10 | , WrappedMonadTrans(..) 11 | ) where 12 | 13 | import qualified Control.Monad.Trans.RWS.CPS as CPS 14 | import qualified Control.Monad.Trans.RWS.Lazy as Lazy 15 | import qualified Control.Monad.Trans.RWS.Strict as Strict 16 | import qualified Control.Monad.Trans.State.Lazy as Lazy 17 | import qualified Control.Monad.Trans.State.Strict as Strict 18 | import qualified Control.Monad.Trans.Writer.CPS as CPS 19 | import qualified Control.Monad.Trans.Writer.Lazy as Lazy 20 | import qualified Control.Monad.Trans.Writer.Strict as Strict 21 | 22 | import Control.Monad 23 | import Control.Monad.Trans.Class 24 | import Control.Monad.Trans.Control 25 | import Control.Monad.Trans.Except 26 | import Control.Monad.Trans.Identity 27 | import Control.Monad.Trans.Maybe 28 | import Control.Monad.Trans.Reader 29 | import Data.Functor 30 | import Data.Kind (Type) 31 | 32 | {-| The class of validation monads, intended to be used to validate data structures while collecting 33 | errors along the way. In a sense, 'MonadValidate' is like a combination of 34 | 'Control.Monad.Error.Class.MonadError' and 'Control.Monad.Writer.Class.MonadWriter', but it isn’t 35 | entirely like either. The two essential differences are: 36 | 37 | 1. Unlike 'Control.Monad.Error.Class.throwError', raising an error using 'refute' does not always 38 | abort the entire computation—it may only abort a local part of it. 39 | 40 | 2. Unlike 'Control.Monad.Writer.Class.tell', raising an error using 'dispute' still causes the 41 | computation to globally fail, it just doesn’t affect local execution. 42 | 43 | Instances must obey the following law: 44 | 45 | @ 46 | 'dispute' ≡ 'void' '.' 'tolerate' '.' 'refute' 47 | @ 48 | 49 | For a more thorough explanation, with examples, see the documentation for 50 | 'Control.Monad.Validate.ValidateT'. -} 51 | class (Monad m, Semigroup e) => MonadValidate e m | m -> e where 52 | -- | Raises a fatal validation error. Aborts the current branch of the validation (i.e. does not 53 | -- return). 54 | -- 55 | -- @ 56 | -- >>> 'Control.Monad.Validate.runValidate' ('refute' ["boom"] '>>' 'refute' ["bang"]) 57 | -- 'Left' ["boom"] 58 | -- @ 59 | refute :: e -> m a 60 | 61 | -- | Raises a non-fatal validation error. The overall validation fails, and the error is recorded, 62 | -- but validation continues in an attempt to try and discover more errors. 63 | -- 64 | -- @ 65 | -- >>> 'Control.Monad.Validate.runValidate' ('dispute' ["boom"] '>>' 'dispute' ["bang"]) 66 | -- 'Left' ["boom", "bang"] 67 | -- @ 68 | -- 69 | -- If not explicitly implemented, the default implementation is @'void' '.' 'tolerate' '.' 70 | -- 'refute'@ (which must behave equivalently by law), but it is sometimes possible to provide a 71 | -- more efficient implementation. 72 | dispute :: e -> m () 73 | dispute = void . tolerate . refute 74 | {-# INLINE dispute #-} 75 | 76 | -- | @'tolerate' m@ behaves like @m@, except that any fatal errors raised by 'refute' are altered 77 | -- to non-fatal errors that return 'Nothing'. This allows @m@’s result to be used for further 78 | -- validation if it succeeds without preventing further validation from occurring upon failure. 79 | -- 80 | -- @ 81 | -- >>> 'Control.Monad.Validate.runValidate' ('tolerate' ('refute' ["boom"]) '>>' 'refute' ["bang"]) 82 | -- 'Left' ["boom", "bang"] 83 | -- @ 84 | -- 85 | -- @since 1.1.0.0 86 | tolerate :: m a -> m (Maybe a) 87 | 88 | {-| Runs an 'ExceptT' computation, and if it raised an error, re-raises it using 'refute'. This 89 | effectively converts a computation that uses 'ExceptT' (or 'Control.Monad.Except.MonadError') into 90 | one that uses 'MonadValidate'. 91 | 92 | @ 93 | >>> 'Control.Monad.Validate.runValidate' '$' 'exceptToValidate' ('pure' 42) 94 | 'Right' 42 95 | >>> 'Control.Monad.Validate.runValidate' '$' 'exceptToValidate' ('Control.Monad.Except.throwError' ["boom"]) 96 | 'Left' "boom" 97 | @ 98 | 99 | @since 1.2.0.0 -} 100 | exceptToValidate :: forall e m a. (MonadValidate e m) => ExceptT e m a -> m a 101 | exceptToValidate = exceptToValidateWith id 102 | {-# INLINE exceptToValidate #-} 103 | 104 | {-| Like 'exceptToValidate', but additionally accepts a function, which is applied to the error 105 | raised by 'ExceptT' before passing it to 'refute'. This can be useful if the original error type is 106 | not a 'Semigroup'. 107 | 108 | @ 109 | >>> 'Control.Monad.Validate.runValidate' '$' 'exceptToValidateWith' (:[]) ('pure' 42) 110 | 'Right' 42 111 | >>> 'Control.Monad.Validate.runValidate' '$' 'exceptToValidateWith' (:[]) ('Control.Monad.Except.throwError' "boom") 112 | 'Left' ["boom"] 113 | @ 114 | 115 | @since 1.2.0.0 -} 116 | exceptToValidateWith :: forall e1 e2 m a. (MonadValidate e2 m) => (e1 -> e2) -> ExceptT e1 m a -> m a 117 | exceptToValidateWith f = either (refute . f) pure <=< runExceptT 118 | {-# INLINE exceptToValidateWith #-} 119 | 120 | {-| If you have a monad transformer that implements the 'MonadTransControl' class, this newtype 121 | wrapper can be used to automatically derive instances of 'MonadValidate' using the @DerivingVia@ 122 | GHC extension. 123 | 124 | Example: 125 | 126 | @ 127 | {\-\# LANGUAGE DerivingVia \#-\} 128 | 129 | newtype CustomT c m a = CustomT { runCustomT :: ... } 130 | deriving ('MonadValidate' e) via ('WrappedMonadTrans' (CustomT c) m) 131 | @ 132 | 133 | @since 1.2.0.0 -} 134 | newtype WrappedMonadTrans (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) (a :: Type) 135 | = WrapMonadTrans { unwrapMonadTrans :: t m a } 136 | deriving (Functor, Applicative, Monad, MonadTrans, MonadTransControl) 137 | 138 | instance (MonadTransControl t, Monad (t m), MonadValidate e m) 139 | => MonadValidate e (WrappedMonadTrans t m) where 140 | refute = lift . refute 141 | dispute = lift . dispute 142 | tolerate m = liftWith (\run -> tolerate (run m)) >>= 143 | maybe (pure Nothing) (fmap Just . restoreT . pure) 144 | {-# INLINE refute #-} 145 | {-# INLINE dispute #-} 146 | {-# INLINE tolerate #-} 147 | 148 | deriving via (WrappedMonadTrans IdentityT m) instance (MonadValidate e m) => MonadValidate e (IdentityT m) 149 | deriving via (WrappedMonadTrans (ExceptT a) m) instance (MonadValidate e m) => MonadValidate e (ExceptT a m) 150 | deriving via (WrappedMonadTrans MaybeT m) instance (MonadValidate e m) => MonadValidate e (MaybeT m) 151 | deriving via (WrappedMonadTrans (ReaderT r) m) instance (MonadValidate e m) => MonadValidate e (ReaderT r m) 152 | deriving via (WrappedMonadTrans (Lazy.RWST r w s) m) instance (MonadValidate e m, Monoid w) => MonadValidate e (Lazy.RWST r w s m) 153 | deriving via (WrappedMonadTrans (Strict.RWST r w s) m) instance (MonadValidate e m, Monoid w) => MonadValidate e (Strict.RWST r w s m) 154 | deriving via (WrappedMonadTrans (Lazy.StateT s) m) instance (MonadValidate e m) => MonadValidate e (Lazy.StateT s m) 155 | deriving via (WrappedMonadTrans (Strict.StateT s) m) instance (MonadValidate e m) => MonadValidate e (Strict.StateT s m) 156 | deriving via (WrappedMonadTrans (Lazy.WriterT w) m) instance (MonadValidate e m, Monoid w) => MonadValidate e (Lazy.WriterT w m) 157 | deriving via (WrappedMonadTrans (Strict.WriterT w) m) instance (MonadValidate e m, Monoid w) => MonadValidate e (Strict.WriterT w m) 158 | 159 | instance (MonadValidate e m, Monoid w) => MonadValidate e (CPS.WriterT w m) where 160 | refute = lift . refute 161 | dispute = lift . dispute 162 | tolerate m = CPS.writerT $ tolerate (CPS.runWriterT m) <&> 163 | maybe (Nothing, mempty) (\(v, w) -> (Just v, w)) 164 | {-# INLINE refute #-} 165 | {-# INLINE dispute #-} 166 | {-# INLINE tolerate #-} 167 | instance (MonadValidate e m, Monoid w) => MonadValidate e (CPS.RWST r w s m) where 168 | refute = lift . refute 169 | dispute = lift . dispute 170 | tolerate m = CPS.rwsT $ \r s1 -> tolerate (CPS.runRWST m r s1) <&> 171 | maybe (Nothing, s1, mempty) (\(v, s2, w) -> (Just v, s2, w)) 172 | {-# INLINE refute #-} 173 | {-# INLINE dispute #-} 174 | {-# INLINE tolerate #-} 175 | -------------------------------------------------------------------------------- /src/Control/Monad/Validate/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | -- | __This is an internal module.__ Backwards compatibility will not be maintained. See 5 | -- "Control.Monad.Validate" for the public interface. 6 | module Control.Monad.Validate.Internal where 7 | 8 | import Control.Monad ((<=<)) 9 | import Control.Monad.IO.Class 10 | import Control.Monad.Base 11 | import Control.Monad.Catch 12 | import Control.Monad.Except 13 | import Control.Monad.Fix 14 | import Control.Monad.Reader.Class 15 | import Control.Monad.State.Strict 16 | import Control.Monad.Trans.Control 17 | import Control.Monad.Writer.Class 18 | import Data.Functor 19 | import Data.Functor.Identity 20 | import Data.Tuple (swap) 21 | 22 | import Control.Monad.Validate.Class 23 | 24 | {-| 'ValidateT' is a monad transformer for writing validations. Like 'ExceptT', 'ValidateT' is 25 | primarily concerned with the production of errors, but it differs from 'ExceptT' in that 'ValidateT' 26 | is designed not to necessarily halt on the first error. Instead, it provides a mechanism for 27 | collecting many warnings or errors, ideally as many as possible, before failing. In that sense, 28 | 'ValidateT' is also somewhat like 'Control.Monad.Writer.WriterT', but it is not /just/ a combination 29 | of 'ExceptT' and 'Control.Monad.Writer.WriterT'. Specifically, it differs in the following two 30 | respects: 31 | 32 | 1. 'ValidateT' automatically collects errors from all branches of an 'Applicative' expression, 33 | making it possible to write code in the same style that one would use with 'ExceptT' and 34 | automatically get additional information for free. (This is especially true when used in 35 | combination with the @ApplicativeDo@ language extension.) 36 | 37 | 2. 'ValidateT' provides error signaling operators, 'refute' and 'dispute', which are similar to 38 | 'throwError' and 'tell', respectively. However, both operators combine raised errors into a 39 | single value (using an arbitrary 'Semigroup'), so the relative ordering of validation errors is 40 | properly respected. (Of course, if the order doesn’t matter to you, you can choose to 41 | accumulate errors into an unordered container.) 42 | 43 | == An introduction to 'ValidateT' 44 | 45 | The first of the above two points is by far the most interesting feature of 'ValidateT'. Let’s make 46 | it more concrete with an example: 47 | 48 | @ 49 | >>> 'runValidate' ('refute' ["bang"] '*>' 'refute' ["boom"]) 50 | 'Left' ["bang", "boom"] 51 | @ 52 | 53 | At first blush, the above example may lead you to believe that 'refute' is like 'tell' from 54 | 'Control.Monad.Writer.WriterT', but it is actually more like 'throwError'. Consider its type: 55 | 56 | @ 57 | 'refute' :: 'MonadValidate' e m => e -> m a 58 | @ 59 | 60 | Note that, like 'throwError', 'refute' is polymorphic in its return type, which is to say it never 61 | returns. Indeed, if we introduce a dependency on a computation that fails using 'refute' via 62 | '>>=', the downstream computation will not be run: 63 | 64 | @ 65 | >>> let getString = 'refute' ["bang"] '*>' 'pure' "boom" 66 | useString a = 'refute' [a] 67 | in 'runValidate' (getString '>>=' useString) 68 | 'Left' ["bang"] 69 | @ 70 | 71 | This works because although the 'Monad' instance for 'ValidateT' fails as soon as the first 'refute' 72 | is executed (as it must due to the way the second argument of '>>=' depends on the result of its 73 | first argument), the 'Applicative' instance runs all branches of '<*>' and combines the errors 74 | produced by all of them. When @ApplicativeDo@ is enabled, this can lead to some “magical” looking 75 | error reporting where validation automatically continues on each sub-piece of a piece of data until 76 | it absolutely cannot proceed any further. As an example, this package’s test suite includes the 77 | following function: 78 | 79 | @ 80 | validateQueryRequest :: ('MonadReader' Env m, 'MonadValidate' [Error] m) => Value -> m QueryRequest 81 | validateQueryRequest req = withObject "request" req '$' \o -> do 82 | qrAuth <- withKey o "auth_token" parseAuthToken 83 | ~(qrTable, info) <- withKey o "table" parseTableName 84 | qrQuery <- withKey o "query" parseQuery 85 | 'Data.Foldable.for_' info '$' \tableInfo -> pushPath "query" '$' 86 | validateQuery qrTable tableInfo (atIsAdmin qrAuth) qrQuery 87 | 'pure' QueryRequest { qrAuth, qrTable, qrQuery } 88 | @ 89 | 90 | The above @do@ block parses and validates some JSON, and it’s written as straight line code, but 91 | with @ApplicativeDo@ enabled (along with the @-foptimal-applicative-do@ option, which makes GHC try 92 | a little harder), it still produces errors for all parts of the input document at once: 93 | 94 | @ 95 | >>> 'flip' 'Control.Monad.Reader.runReader' env '.' 'runValidateT' '$' validateQueryRequest [aesonQQ| 96 | { "auth_token": 123 97 | , "table": { "name": "users" } 98 | , "query": { "add": 99 | [ { "lit": "42" } 100 | , { "select": "points" } ]} 101 | }|] 102 | 'Left' [ Error ["auth_token"] (JSONBadValue "string" (Number 123)) 103 | , Error ["table"] (JSONMissingKey "schema") 104 | , Error ["query", "add", "lit"] (JSONBadValue "number" (String "42")) ] 105 | @ 106 | 107 | The penultimate statement in the @do@ block—the one with the call to @validateQuery@—depends on 108 | several of the bindings bound earlier in the same @do@ block, namely @qrAuth@, @info@, and 109 | @qrQuery@. Because of that, @validateQuery@ will not be executed so long as any of its dependencies 110 | fail. As soon as they all succeed, their results will be passed to @validateQuery@ as usual, and 111 | validation will continue. 112 | 113 | == The full details 114 | 115 | Although 'ValidateT' (with @ApplicativeDo@) may seem magical, of course, it is not. As alluded to 116 | above, 'ValidateT' simply provides a '<*>' implementation that collects errors produced by both 117 | arguments rather than short-circuiting as soon as the first error is raised. 118 | 119 | However, that explanation alone may raise some additional questions. What about the monad laws? When 120 | 'ValidateT' is used in a monad transformer stack, what happens to side effects? And what are 121 | 'ValidateT'’s performance characteristics? The remainder of this section discusses those topics. 122 | 123 | === 'ValidateT' and the 'Monad' laws 124 | 125 | 'ValidateT'’s 'Applicative' and 'Monad' instances do not conform to a strict interpretation of the 126 | 'Monad' laws, which dictate that '<*>' must be equivalent to 'ap'. For 'ValidateT', this is not true 127 | if we consider “equivalent” to mean '=='. However, if we accept a slightly weaker notion of 128 | equivalence, we can satisfy the laws. Specifically, we may use the definition that some 'Validate' 129 | action @a@ is equivalent to another action @b@ iff 130 | 131 | * if @'runValidate' a@ produces @'Right' x@, then @'runValidate' b@ must produce @'Right' y@ where 132 | @x '==' y@ (and '==' is the usual Haskell '=='), 133 | 134 | * and if @'runValidate' a@ produces @'Left' x@, then @'runValidate' b@ must produce @'Left' y@ 135 | (but @x@ and @y@ may be unrelated). 136 | 137 | In other words, our definition of equivalence is like '==', except that we make no guarantees about 138 | the /contents/ of an error should one occur. However, we /do/ guarantee that replacing '<*>' with 139 | 'ap' or vice versa will never change an error to a success or a success to an error, nor will it 140 | change the value of a successful result in any way. To put it another way, 'ValidateT' provides 141 | “best effort” error reporting: it will never return fewer errors than an equivalent use of 142 | 'ExceptT', but it might return more. 143 | 144 | === Using 'ValidateT' with other monad transformers 145 | 146 | 'ValidateT' is a valid, lawful, generally well-behaved monad transformer, and it is safe to use 147 | within a larger monad transformer stack. Instances for the most common @mtl@-style typeclasses are 148 | provided. __However__, be warned: many common monad transformers do not have sufficiently 149 | order-independent 'Applicative' instances for 'ValidateT'’s 'Applicative' instance to actually 150 | collect errors from multiple branches of a computation. 151 | 152 | To understand why that might be, consider that 'StateT' must enforce a left-to-right evaluation 153 | order for '<*>' in order to thread the state through the computation. If the @a@ action in an 154 | expression @a '<*>' b@ fails, then it is simply not possible to run @b@ since @b@ may still depend 155 | on the state that would have been produced by @a@. Similarly, 'ExceptT' enforces a left-to-right 156 | evaluation because it aborts a computation as soon as an error is thrown. Using 'ValidateT' with 157 | these kinds of monad transformers will cause it to effectively degrade to 158 | 'Control.Monad.Writer.WriterT' over 'ExceptT' since it will not be able to gather any errors 159 | produced by 'refute' beyond the first one. 160 | 161 | However, even that isn’t the whole story, since the relative order of monads in a monad transformer 162 | stack can affect things further. For example, while the 'StateT' monad transformer enforces 163 | left-to-right evaluation order, it only does this for the monad /underneath/ it, so although 164 | @'StateT' s ('ValidateT' e)@ will not be able to collect multiple errors, @'ValidateT' e 165 | ('State' s)@ will. Note, however, that those two types differ in other ways, too—running each to 166 | completion results in different types: 167 | 168 | @ 169 | 'runState' ('runValidateT' m) s :: ('Either' e a, s) 170 | 'runValidate' ('runStateT' m s) :: 'Either' e (a, s) 171 | @ 172 | 173 | That kind of difference is generally true when using monad transformers—the two combinations of 174 | 'ExceptT' and 'StateT' have the same types as above, for example—but because 'ValidateT' needs to be 175 | on top of certain transformers for it to be useful, combining 'ValidateT' with certain transformers 176 | may be of little practical use. 177 | 178 | One way to identify which monad transformers are uncooperative in the aforementioned way is to look 179 | at the constraints included in the context of the transformer’s 'Applicative' instance. Transformers 180 | like 'Control.Monad.State.StateT' have instances of the shape 181 | 182 | @ 183 | instance 'Monad' m => 'Applicative' ('StateT' s m) 184 | @ 185 | 186 | which notably require 'Monad' instances just to implement 'Applicative'! However, this is not always 187 | sufficient for distinguishing which functions or instances use '<*>' and which use '>>=', especially 188 | since many older libraries (which predate 'Applicative') may include 'Monad' contraints even when 189 | they only use features of 'Applicative'. The only way to be certain is to examine the 190 | implementation (or conservatively write code that is explicitly restricted to 'Applicative'). 191 | 192 | (As it happens, 'ValidateT'’s 'Applicative' is actually one such “uncooperative” instance itself: it 193 | has a 'Monad' constraint in its context. It is possible to write an implementation of 'ValidateT' 194 | without that constraint, but its '<*>' would necessarily leak space in the same way 195 | 'Control.Monad.Writer.WriterT'’s '>>=' leaks space. If you have a reason to want the less efficient 196 | but more permissive variant, please let the author of this library know, as she would probably find 197 | it interesting.) 198 | 199 | == Performance characteristics of 'ValidateT' 200 | 201 | Although the interface to 'ValidateT' is minimal, there are surprisingly many different ways to 202 | implement it, each with its own set of performance tradeoffs. Here is a quick summary of the choices 203 | 'ValidateT' makes: 204 | 205 | 1. 'ValidateT' is __strict__ in the set of errors it accumulates, which is to say it reduces them 206 | to weak head normal form (WHNF) via 'seq' immediately upon any call to 'refute' or 'dispute'. 207 | 208 | 2. Furthermore, all of 'ValidateT'’s operations, including '<*>', operate in __constant space__. 209 | This means, for example, that evaluating @'sequence_' xs@ will consume constant space 210 | regardless of the size of @xs@, not counting any space consumed purely due to the relevant 211 | 'Foldable' instance’s traversal of @xs@. 212 | 213 | 3. Finally, 'ValidateT' accumulates errors in a __left-associative__ manner, which is to say that 214 | any uses of 'refute' or 'dispute' combine the existing set of errors, @e@, with the added set 215 | of errors, @e'@, via the expression @e '<>' e'@. 216 | 217 | A good rule of thumb is that 'ValidateT' has similar performance characteristics to 218 | @'Data.Foldable.foldl'' ('<>')@, while types like @Validation@ from the @either@ package tend to 219 | have similar performance characteristics to @'foldr' ('<>')@. That decision has both significant 220 | advantages and significant disadvantages; the following subsections elaborate further. 221 | 222 | === '<*>' takes constant space 223 | 224 | Great care has been taken in the implementation of '<*>' to ensure it does not leak space. Notably, 225 | the same /cannot/ be said for many existing implementations of similar concepts. For example, you 226 | will find that executing the expression 227 | 228 | @ 229 | let m () = 'pure' () '*>' m () in m () 230 | @ 231 | 232 | may continuously allocate memory until it is exhausted for types such as @Validation@ (from the 233 | @either@ package), but 'ValidateT' will execute it in constant space. This point may seem silly, 234 | since the above definition of @m ()@ will never do anything useful, anyway, but the same point also 235 | applies to operations like 'sequence_'. 236 | 237 | In practice, this issue matters far less for types like @Validation@ than it does for 'ValidateT', 238 | as @Validation@ and its cousins don’t have a 'Monad' instance and do not generally experience the 239 | same usage patterns. (The additional laziness they are capable of can sometimes even avoid the space 240 | leak altogether.) However, it can be relevant more often for 'ValidateT', so this implementation 241 | makes choices to avoid the potential for the leak altogether. 242 | 243 | === Errors are accumulated using strict, left-associated '<>' 244 | 245 | A major consequence of the decision to both strictly accumulate state and maintain constant space is 246 | that 'ValidateT'’s internal applications of '<>' to combine errors are naturally strict and 247 | left-associated, not lazy and right-associated like they are for types like @Validation@. If the 248 | number of errors your validation generates is small, this difference is irrelevant, but if it is 249 | large, the difference in association can prove disastrous if the 'Semigroup' you choose to 250 | accumulate errors in is @[a]@! 251 | 252 | To make it painfully explicit why using @[a]@ can come back to bite you, consider that each time 253 | 'ValidateT' executes @'refute' e'@, given some existing collection of errors @e@, it (strictly) 254 | evalutes @e '<>' e'@ to obtain a new collection of errors. Now consider the implications of that 255 | if @e@ is a ten thousand element list: '<>' will have to traverse /all/ ten thousand elements and 256 | reallocate a fresh cons cell for every single one in order to build the new list, even if just one 257 | element is being appended to the end! Unfortunately, the ubiquitous, built-in @[a]@ type is clearly 258 | an exceptionally poor choice for this pattern of accumulation. 259 | 260 | Fortunately, the solution is quite simple: use a different data structure. If order doesn’t matter, 261 | use a @Set@ or @HashSet@. If it does, but either LIFO consumption of the data is okay or you are 262 | okay with paying to reverse the data once after collecting the errors, use @'Data.Semigroup.Dual' 263 | [a]@ to accumulate elements in an efficient manner. If neither is true, use a data structure like 264 | @Seq@ that provides an efficient implementation of a functional queue. You can always convert back 265 | to a plain list at the end once you’re done, if you have to. -} 266 | newtype ValidateT e m a = ValidateT 267 | { getValidateT :: forall s. StateT (MonoMaybe s e) (ExceptT e m) a } 268 | -- Sadly, GeneralizedNewtypeDeriving can’t help us here due to the inner forall, but we can at least 269 | -- derive the Functor instance. 270 | deriving instance (Functor m) => Functor (ValidateT e m) 271 | 272 | validateT 273 | :: forall e m a. (Functor m) 274 | => (forall s. MonoMaybe s e -> m (Either e (MonoMaybe s e, a))) 275 | -> ValidateT e m a 276 | validateT f = ValidateT (StateT (ExceptT . (fmap (fmap swap) . f))) 277 | {-# INLINE validateT #-} 278 | 279 | unValidateT 280 | :: forall s e m a. (Functor m) 281 | => MonoMaybe s e -> ValidateT e m a -> m (Either e (MonoMaybe s e, a)) 282 | unValidateT e (ValidateT m) = runExceptT (swap <$> runStateT m e) 283 | {-# INLINE unValidateT #-} 284 | 285 | instance (Monad m) => Applicative (ValidateT e m) where 286 | pure v = ValidateT (pure v) 287 | {-# INLINE pure #-} 288 | 289 | m1 <*> m2 = validateT $ \e0 -> 290 | unValidateT e0 m1 >>= \case 291 | Left e1 -> unValidateT (MJust @'SJust e1) m2 <&> \case 292 | Left e2 -> Left e2 293 | Right (MJust e2, _) -> Left e2 294 | Right (e1, v1) -> unValidateT e1 m2 <&> \case 295 | Left e2 -> Left e2 296 | Right (e2, v2) -> Right (e2, v1 v2) 297 | {-# INLINABLE (<*>) #-} 298 | 299 | instance (Monad m) => Monad (ValidateT e m) where 300 | ValidateT m >>= f = ValidateT (m >>= \x -> getValidateT (f x)) 301 | {-# INLINE (>>=) #-} 302 | 303 | instance MonadTrans (ValidateT e) where 304 | lift m = ValidateT (lift $ lift m) 305 | {-# INLINE lift #-} 306 | 307 | instance (MonadFix m) => MonadFix (ValidateT e m) where 308 | mfix f = ValidateT $ mfix (\x -> getValidateT (f x)) 309 | {-# INLINE mfix #-} 310 | 311 | instance (MonadIO m) => MonadIO (ValidateT e m) where 312 | liftIO = lift . liftIO 313 | {-# INLINE liftIO #-} 314 | 315 | instance (MonadBase b m) => MonadBase b (ValidateT e m) where 316 | liftBase = lift . liftBase 317 | {-# INLINE liftBase #-} 318 | 319 | -- | An opaque type used to capture the current state of a 'ValidateT' computation, used as the 320 | -- 'StT' instance for 'ValidateT'. It is opaque in an attempt to protect internal invariants about 321 | -- the state, but it is unfortunately still theoretically possible for it to be misused (but such 322 | -- misuses are exceedingly unlikely). 323 | data ValidateTState e a = forall s. ValidateTState 324 | { getValidateTState :: Either e (MonoMaybe s e, a) } 325 | deriving instance (Show e, Show a) => Show (ValidateTState e a) 326 | deriving instance Functor (ValidateTState e) 327 | 328 | instance MonadTransControl (ValidateT e) where 329 | type StT (ValidateT e) a = ValidateTState e a 330 | 331 | liftWith f = validateT $ \e -> 332 | Right . (e,) <$> f (fmap ValidateTState . unValidateT e) 333 | {-# INLINABLE liftWith #-} 334 | 335 | restoreT m = validateT $ \e1 -> do 336 | ValidateTState r <- m 337 | case e1 of 338 | MNothing -> case r of 339 | Left e2 -> pure $ Left e2 340 | Right (MJust e2, v) -> pure $ Right (MJust e2, v) 341 | Right (MNothing, v) -> pure $ Right (MNothing, v) 342 | MJust _ -> case r of 343 | Left e2 -> pure $ Left e2 344 | Right (MJust e2, v) -> pure $ Right (MJust e2, v) 345 | Right (MNothing, _) -> invalidRestoreError 346 | {-# INLINABLE restoreT #-} 347 | 348 | invalidRestoreError :: a 349 | invalidRestoreError = error 350 | "Control.Monad.Validate.ValidateT#restoreT: panic!\n\ 351 | \ An attempt was made to restore from a state captured before any validation\n\ 352 | \ errors occurred into a context with validation errors. This is probably the\n\ 353 | \ result of an incorrect use of MonadBaseControl (as validation errors should\n\ 354 | \ strictly increase). Ensure that all state is restored immediately upon\n\ 355 | \ returning from the base monad (or is not restored at all).\n\ 356 | \\n\ 357 | \ If you believe your use of MonadBaseControl is not in error, and this is a\n\ 358 | \ bug in ValidateT, please submit a bug report." 359 | 360 | instance (MonadBaseControl b m) => MonadBaseControl b (ValidateT e m) where 361 | type StM (ValidateT e m) a = ComposeSt (ValidateT e) m a 362 | liftBaseWith = defaultLiftBaseWith 363 | restoreM = defaultRestoreM 364 | {-# INLINE liftBaseWith #-} 365 | {-# INLINE restoreM #-} 366 | 367 | liftCatch 368 | :: (Functor m) 369 | => (forall b. m b -> (e -> m b) -> m b) 370 | -> ValidateT d m a -> (e -> ValidateT d m a) -> ValidateT d m a 371 | liftCatch catchE m f = validateT $ \e -> 372 | catchE (unValidateT e m) (unValidateT e . f) 373 | {-# INLINE liftCatch #-} 374 | 375 | instance (MonadError e m) => MonadError e (ValidateT a m) where 376 | throwError = lift . throwError 377 | catchError = liftCatch catchError 378 | {-# INLINE throwError #-} 379 | {-# INLINE catchError #-} 380 | 381 | instance (MonadReader r m) => MonadReader r (ValidateT e m) where 382 | ask = lift ask 383 | local f (ValidateT m) = ValidateT (local f m) 384 | reader = lift . reader 385 | {-# INLINE ask #-} 386 | {-# INLINE local #-} 387 | {-# INLINE reader #-} 388 | 389 | instance (MonadState s m) => MonadState s (ValidateT e m) where 390 | get = lift get 391 | put = lift . put 392 | state = lift . state 393 | {-# INLINE get #-} 394 | {-# INLINE put #-} 395 | {-# INLINE state #-} 396 | 397 | instance (MonadWriter w m) => MonadWriter w (ValidateT e m) where 398 | writer = lift . writer 399 | tell = lift . tell 400 | listen (ValidateT m) = ValidateT (listen m) 401 | pass (ValidateT m) = ValidateT (pass m) 402 | {-# INLINE writer #-} 403 | {-# INLINE tell #-} 404 | {-# INLINE listen #-} 405 | {-# INLINE pass #-} 406 | 407 | instance (MonadThrow m) => MonadThrow (ValidateT e m) where 408 | throwM = lift . throwM 409 | {-# INLINE throwM #-} 410 | 411 | instance (MonadCatch m) => MonadCatch (ValidateT e m) where 412 | catch = liftCatch catch 413 | {-# INLINE catch #-} 414 | 415 | liftMask 416 | :: (Functor m) 417 | => (forall c. ((forall a. m a -> m a) -> m c) -> m c) 418 | -> ((forall a. ValidateT e m a -> ValidateT e m a) -> ValidateT e m b) -> ValidateT e m b 419 | liftMask maskE f = validateT $ \e1 -> 420 | maskE $ \unmask -> 421 | unValidateT e1 $ f $ \m -> 422 | validateT $ \e2 -> 423 | unmask $ unValidateT e2 m 424 | {-# INLINE liftMask #-} 425 | 426 | instance (MonadMask m) => MonadMask (ValidateT e m) where 427 | mask = liftMask mask 428 | uninterruptibleMask = liftMask uninterruptibleMask 429 | generalBracket m f g = ValidateT $ generalBracket 430 | (getValidateT m) 431 | (\a b -> getValidateT $ f a b) 432 | (\a -> getValidateT $ g a) 433 | {-# INLINE mask #-} 434 | {-# INLINE uninterruptibleMask #-} 435 | {-# INLINE generalBracket #-} 436 | 437 | instance (Monad m, Semigroup e) => MonadValidate e (ValidateT e m) where 438 | refute e2 = validateT $ \e1 -> 439 | let !e3 = monoMaybe e2 (<> e2) e1 in pure (Left e3) 440 | dispute e2 = validateT $ \e1 -> 441 | let !e3 = monoMaybe e2 (<> e2) e1 in pure (Right (MJust e3, ())) 442 | tolerate m = validateT $ \e1 -> 443 | Right . either (\e2 -> (MJust e2, Nothing)) (fmap Just) <$> unValidateT e1 m 444 | {-# INLINABLE refute #-} 445 | {-# INLINABLE dispute #-} 446 | {-# INLINABLE tolerate #-} 447 | 448 | -- | Runs a 'ValidateT' computation, returning the errors raised by 'refute' or 'dispute' if any, 449 | -- otherwise returning the computation’s result. 450 | runValidateT :: forall e m a. (Functor m) => ValidateT e m a -> m (Either e a) 451 | runValidateT m = unValidateT MNothing m <&> \case 452 | Left e -> Left e 453 | Right (MJust e, _) -> Left e 454 | Right (MNothing, v) -> Right v 455 | 456 | -- | Runs a 'ValidateT' computation, returning the errors on failure or 'mempty' on success. The 457 | -- computation’s result, if any, is discarded. 458 | -- 459 | -- @ 460 | -- >>> 'execValidate' ('refute' ["bang"]) 461 | -- ["bang"] 462 | -- >>> 'execValidate' @[] ('pure' 42) 463 | -- [] 464 | -- @ 465 | execValidateT :: forall e m a. (Monoid e, Functor m) => ValidateT e m a -> m e 466 | execValidateT = fmap (either id mempty) . runValidateT 467 | 468 | {-| Runs a 'ValidateT' transformer by interpreting it in an underlying transformer with a 469 | 'MonadValidate' instance. That might seem like a strange thing to do, but it can be useful in 470 | combination with 'mapErrors' to locally alter the error type in a larger 'ValidateT' computation. 471 | For example: 472 | 473 | @ 474 | throwsIntegers :: 'MonadValidate' ['Integer'] m => m () 475 | throwsIntegers = 'dispute' [42] 476 | 477 | throwsBools :: 'MonadValidate' ['Bool'] m => m () 478 | throwsBools = 'dispute' ['False'] 479 | 480 | throwsBoth :: 'MonadValidate' ['Either' 'Integer' 'Bool'] m => m () 481 | throwsBoth = do 482 | 'embedValidateT' '$' 'mapErrors' ('map' 'Left') throwsIntegers 483 | 'embedValidateT' '$' 'mapErrors' ('map' 'Right') throwsBools 484 | 485 | >>> 'runValidate' throwsBoth 486 | 'Left' ['Left' 42, 'Right' False] 487 | @ 488 | 489 | @since 1.1.0.0 -} 490 | embedValidateT :: forall e m a. (MonadValidate e m) => ValidateT e m a -> m a 491 | embedValidateT m = unValidateT MNothing m >>= \case 492 | Left e -> refute e 493 | Right (MJust e, v) -> dispute e $> v 494 | Right (MNothing, v) -> pure v 495 | 496 | -- | Applies a function to all validation errors produced by a 'ValidateT' computation. 497 | -- 498 | -- @ 499 | -- >>> 'runValidate' '$' 'mapErrors' ('map' 'show') ('refute' [11, 42]) 500 | -- 'Left' ["11", "42"] 501 | -- @ 502 | -- 503 | -- @since 1.1.0.0 504 | mapErrors 505 | :: forall e1 e2 m a. (Monad m, Semigroup e2) 506 | => (e1 -> e2) -> ValidateT e1 m a -> ValidateT e2 m a 507 | mapErrors f m = lift (unValidateT MNothing m) >>= \case 508 | Left e -> refute (f e) 509 | Right (MJust e, v) -> dispute (f e) $> v 510 | Right (MNothing, v) -> pure v 511 | 512 | {-| Runs a 'ValidateT' computation, and if it raised any errors, re-raises them using 'throwError'. 513 | This effectively converts a computation that uses 'ValidateT' (or 'MonadValidate') into one that 514 | uses 'MonadError'. 515 | 516 | @ 517 | >>> 'runExcept' '$' 'validateToError' ('pure' 42) 518 | 'Right' 42 519 | >>> 'runExcept' '$' 'validateToError' ('refute' ["boom"] *> 'refute' ["bang"]) 520 | 'Left' ["boom", "bang"] 521 | @ 522 | 523 | @since 1.2.0.0 -} 524 | validateToError :: forall e m a. (MonadError e m) => ValidateT e m a -> m a 525 | validateToError = validateToErrorWith id 526 | {-# INLINE validateToError #-} 527 | 528 | {-| Like 'validateToError', but additionally accepts a function, which is applied to the errors 529 | raised by 'ValidateT' before passing them to 'throwError'. This can be useful to concatenate 530 | multiple errors into one. 531 | 532 | @ 533 | >>> 'runExcept' '$' 'validateToErrorWith' 'mconcat' ('pure' 42) 534 | 'Right' 42 535 | >>> 'runExcept' '$' 'validateToErrorWith' 'mconcat' ('refute' ["boom"] *> 'refute' ["bang"]) 536 | 'Left' "boombang" 537 | @ 538 | 539 | @since 1.2.0.0 -} 540 | validateToErrorWith :: forall e1 e2 m a. (MonadError e2 m) => (e1 -> e2) -> ValidateT e1 m a -> m a 541 | validateToErrorWith f = either (throwError . f) pure <=< runValidateT 542 | {-# INLINE validateToErrorWith #-} 543 | 544 | -- | 'ValidateT' specialized to the 'Identity' base monad. See 'ValidateT' for usage information. 545 | type Validate e = ValidateT e Identity 546 | 547 | -- | See 'runValidateT'. 548 | runValidate :: forall e a. Validate e a -> Either e a 549 | runValidate = runIdentity . runValidateT 550 | {-# INLINE runValidate #-} 551 | 552 | -- | See 'execValidateT'. 553 | execValidate :: forall e a. (Monoid e) => Validate e a -> e 554 | execValidate = runIdentity . execValidateT 555 | {-# INLINE execValidate #-} 556 | 557 | {-| Monotonically increasing 'Maybe' values. A function with the type 558 | 559 | @ 560 | forall s. 'MonoMaybe' s Foo -> 'MonoMaybe' s Bar 561 | @ 562 | 563 | may return 'MNothing' only when given 'MNothing', but it may return 'MJust' for any input. This 564 | is useful for keeping track of the error state within 'ValidateT', since we want to statically 565 | prevent the possibility of a 'ValidateT' action being passed a nonempty set of errors but returning 566 | no errors. 567 | 568 | The benefit of this additional type tracking shows up most prominently in the implementation of 569 | '<*>'. Consider an expression @x '<*>' y@, where @x@ is an action that fails, but @y@ is an action 570 | that succeeds. We pass the errors returned by @x@ to @y@, then pattern-match on @y@’s result. If @y@ 571 | succeeds, we’ll end up with a tuple of type @('MonoMaybe' ''SJust' e, a)@. We can’t use the second 572 | element of that tuple at all because we need to return a value of type @b@, but the only way to get 573 | one is to apply a function of type @a -> b@ returned by @x@… which we don’t have, since @x@ failed. 574 | 575 | Since we can’t produce a value of type @'Right' b@, our only option is to return a value of type 576 | @'Left' e@. But if the first element of the tuple had type @'Maybe' e@, we’d now be in a sticky 577 | situation! Its value could be 'Nothing', but we need it to be @'Just' e@ since we only have a 578 | 'Semigroup' instance for @e@, not a 'Monoid' instance, so we can’t produce an @e@ out of thin air. 579 | However, by returning a 'MonoMaybe', we guarantee that the result will be @'MJust' e@, and we can 580 | proceed safely. 581 | -} 582 | data MonoMaybe s a where 583 | MNothing :: MonoMaybe 'SMaybe a 584 | MJust :: forall s a. !a -> MonoMaybe s a 585 | deriving instance (Show a) => Show (MonoMaybe s a) 586 | deriving instance (Eq a) => Eq (MonoMaybe s a) 587 | deriving instance (Ord a) => Ord (MonoMaybe s a) 588 | deriving instance Functor (MonoMaybe s) 589 | 590 | -- | The kind of types used to track the current state of a 'MonoMaybe' value. 591 | data MonoMaybeS = SMaybe | SJust 592 | 593 | -- | Like 'maybe' but for 'MonoMaybe'. 594 | monoMaybe :: (s ~ 'SMaybe => b) -> (a -> b) -> MonoMaybe s a -> b 595 | monoMaybe v f = \case 596 | MNothing -> v 597 | MJust x -> f x 598 | {-# INLINE monoMaybe #-} 599 | -------------------------------------------------------------------------------- /test/Control/Monad/ValidateSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -foptimal-applicative-do #-} 2 | {-# LANGUAGE AllowAmbiguousTypes #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Control.Monad.ValidateSpec (spec) where 7 | 8 | import qualified Data.Aeson.KeyMap as KM 9 | import qualified Data.Text as T 10 | import qualified Data.Vector as V 11 | 12 | import Control.Monad 13 | import Control.Monad.Reader 14 | import Control.Monad.Except 15 | import Data.Aeson (Key, Object, Value(..)) 16 | import Data.Aeson.QQ (aesonQQ) 17 | import Data.Foldable 18 | import Data.Functor 19 | import Data.Scientific (toBoundedInteger) 20 | import Data.Text (Text) 21 | import Data.Typeable 22 | import Test.Hspec 23 | 24 | import Control.Monad.Validate 25 | 26 | data AuthToken = AuthToken { atBearer :: Text, atIsAdmin :: Bool } 27 | deriving (Show, Eq) 28 | 29 | data TableName = TableName { tnSchema :: Text, tnName :: Text } 30 | deriving (Show, Eq) 31 | newtype ColumnName = ColumnName { cnName :: Text } 32 | deriving (Show, Eq) 33 | 34 | type TableInfo = [(ColumnName, ColumnInfo)] 35 | newtype ColumnInfo = ColumnInfo { ciAdminOnly :: Bool } 36 | deriving (Show, Eq) 37 | 38 | data Env = Env 39 | { envTables :: [(TableName, TableInfo)] 40 | , envPath :: [Key] } 41 | deriving (Show, Eq) 42 | 43 | data Query a where 44 | QLit :: Integer -> Query Integer 45 | QSelect :: ColumnName -> Query Integer 46 | QAdd :: Query Integer -> Query Integer -> Query Integer 47 | QEqual :: Query Integer -> Query Integer -> Query Bool 48 | QIf :: Query Bool -> Query a -> Query a -> Query a 49 | deriving instance Show (Query a) 50 | deriving instance Eq (Query a) 51 | 52 | data QueryRequest = QueryRequest 53 | { qrAuth :: AuthToken 54 | , qrTable :: TableName 55 | , qrQuery :: Query Integer } 56 | deriving (Show, Eq) 57 | 58 | data Error = Error { errPath :: [Key], errInfo :: ErrorInfo } 59 | deriving (Show, Eq) 60 | data ErrorInfo 61 | = JSONBadValue Text Value 62 | | JSONMissingKey Key 63 | | InvalidAuthToken Text 64 | | UnknownTableName TableName 65 | | UnknownQueryOperator Key 66 | | TypeError TypeRep TypeRep 67 | | UnknownColumnName TableName ColumnName 68 | | InsufficientPermissions TableName ColumnName 69 | deriving (Show, Eq) 70 | 71 | validateQueryRequest :: forall m. (MonadReader Env m, MonadValidate [Error] m) => Value -> m QueryRequest 72 | validateQueryRequest req = withObject "request" req $ \o -> do 73 | qrAuth <- withKey o "auth_token" parseAuthToken 74 | ~(qrTable, info) <- withKey o "table" parseTableName 75 | qrQuery <- withKey o "query" parseQuery 76 | for_ info $ \tableInfo -> pushPath "query" $ 77 | validateQuery qrTable tableInfo (atIsAdmin qrAuth) qrQuery 78 | pure QueryRequest { qrAuth, qrTable, qrQuery } 79 | where 80 | parseAuthToken v = do 81 | str <- asString v 82 | case T.splitOn ":" str of 83 | [bearer] -> pure $ AuthToken bearer False 84 | [bearer, "super_secret_admin_password"] -> pure $ AuthToken bearer True 85 | _ -> refuteErr $ InvalidAuthToken str 86 | 87 | parseTableName v = withObject "table name" v $ \o -> do 88 | name <- TableName <$> withKey o "schema" asString <*> withKey o "name" asString 89 | info <- tolerate $ validateTableName name 90 | pure (name, info) 91 | 92 | validateTableName name = do 93 | info <- lookup name <$> asks envTables 94 | maybe (refuteErr $ UnknownTableName name) pure info 95 | 96 | parseQuery :: forall a. (Typeable a) => Value -> m (Query a) 97 | parseQuery q = withSingleKeyObject "query expression" q $ \k v -> case k of 98 | "lit" -> withType $ QLit <$> asInteger v 99 | "select" -> withType $ QSelect <$> parseColumnName v 100 | "add" -> withType $ asPair v >>= \(a, b) -> QAdd <$> parseQuery a <*> parseQuery b 101 | "equal" -> withType $ asPair v >>= \(a, b) -> QEqual <$> parseQuery a <*> parseQuery b 102 | "if" -> withType @a $ asTriple v >>= \(a, b, c) -> 103 | QIf <$> parseQuery a <*> parseQuery b <*> parseQuery c 104 | _ -> refuteErr $ UnknownQueryOperator k 105 | 106 | validateQuery tableName tableInfo isAdmin = loop where 107 | loop :: Query a -> m () 108 | loop = \case 109 | QLit _ -> pure () 110 | QSelect colName -> pushPath "select" $ case lookup colName tableInfo of 111 | Just colInfo 112 | | ciAdminOnly colInfo && not isAdmin 113 | -> disputeErr $ InsufficientPermissions tableName colName 114 | | otherwise -> pure () 115 | Nothing -> disputeErr $ UnknownColumnName tableName colName 116 | QAdd a b -> pushPath "add" $ loop a *> loop b 117 | QEqual a b -> pushPath "equal" $ loop a *> loop b 118 | QIf a b c -> pushPath "if" $ loop a *> loop b *> loop c 119 | 120 | parseColumnName = fmap ColumnName . asString 121 | 122 | pushPath :: Key -> m a -> m a 123 | pushPath path = local (\env -> env { envPath = path : envPath env }) 124 | mkErr info = asks envPath <&> \path -> Error (reverse path) info 125 | refuteErr = mkErr >=> \err -> refute [err] 126 | disputeErr :: ErrorInfo -> m () 127 | disputeErr = mkErr >=> \err -> dispute [err] 128 | 129 | withType :: forall a b. (Typeable a, Typeable b) => m (Query a) -> m (Query b) 130 | withType m = case eqT @a @b of 131 | Just Refl -> m 132 | Nothing -> refuteErr $ TypeError (typeRep (Proxy @a)) (typeRep (Proxy @b)) 133 | 134 | asString = \case { String s -> pure s; v -> refuteErr $ JSONBadValue "string" v } 135 | asNumber = \case { Number n -> pure n; v -> refuteErr $ JSONBadValue "number" v } 136 | asInteger v = asNumber v >>= 137 | maybe (refuteErr $ JSONBadValue "integer" v) (pure . toInteger) . toBoundedInteger @Int 138 | asArray = \case { Array v -> pure $ V.toList v; v -> refuteErr $ JSONBadValue "array" v } 139 | asPair v = asArray v >>= \case { [a, b] -> pure (a, b); _ -> refuteErr $ JSONBadValue "pair" v } 140 | asTriple v = asArray v >>= \case { [a, b, c] -> pure (a, b, c); _ -> refuteErr $ JSONBadValue "triple" v } 141 | 142 | withObject :: Text -> Value -> (Object -> m a) -> m a 143 | withObject name v f = case v of { Object o -> f o; _ -> refuteErr $ JSONBadValue name v } 144 | 145 | withKey :: Object -> Key -> (Value -> m a) -> m a 146 | withKey o k f = maybe (refuteErr $ JSONMissingKey k) (pushPath k . f) $ KM.lookup k o 147 | 148 | withSingleKeyObject :: Text -> Value -> (Key -> Value -> m a) -> m a 149 | withSingleKeyObject name i f = withObject name i $ \o -> case KM.toList o of 150 | { [(k, v)] -> pushPath k $ f k v; _ -> refuteErr $ JSONBadValue name i } 151 | 152 | spec :: Spec 153 | spec = describe "ValidateT" $ do 154 | describe "tolerate" $ do 155 | it "has no effect on computations without fatal errors" $ do 156 | runValidate ((dispute ["boom"] $> ["bang"]) >>= dispute) 157 | `shouldBe` Left (["boom", "bang"] :: [Text]) 158 | runValidate (tolerate (dispute ["boom"] $> ["bang"]) >>= traverse_ dispute) 159 | `shouldBe` Left (["boom", "bang"] :: [Text]) 160 | 161 | it "converts fatal errors to non-fatal errors" $ do 162 | runValidate (refute ["boom"] >> dispute ["bang"]) 163 | `shouldBe` Left (["boom"] :: [Text]) 164 | runValidate (tolerate (refute ["boom"]) >> dispute ["bang"]) 165 | `shouldBe` Left (["boom", "bang"] :: [Text]) 166 | 167 | describe "mapErrors" $ do 168 | it "applies a function to all validation errors" $ 169 | runValidate (mapErrors (map show) (refute [True] *> dispute [False])) 170 | `shouldBe` Left ["True", "False"] 171 | 172 | it "can be used with embedValidateT to locally change the type of errors" $ do 173 | let foo :: (MonadValidate [Integer] m) => m () 174 | foo = dispute [42] 175 | bar :: (MonadValidate [Bool] m) => m () 176 | bar = dispute [False] 177 | baz :: (MonadValidate [Either Integer Bool] m) => m () 178 | baz = do 179 | embedValidateT $ mapErrors (map Left) foo 180 | embedValidateT $ mapErrors (map Right) bar 181 | runValidate baz `shouldBe` Left [Left 42, Right False] 182 | 183 | describe "exceptToValidate" $ 184 | it "converts an ExceptT computation to ValidateT" $ do 185 | runValidate (exceptToValidate (pure 42)) 186 | `shouldBe` (Right 42 :: Either [Text] Integer) 187 | runValidate (exceptToValidate (throwError ["boom"])) 188 | `shouldBe` (Left ["boom"] :: Either [Text] Integer) 189 | 190 | describe "exceptToValidateWith" $ 191 | it "converts an ExceptT computation to ValidateT by applying a function to any errors" $ do 192 | runValidate (exceptToValidateWith (:[]) (pure 42)) 193 | `shouldBe` (Right 42 :: Either [Text] Integer) 194 | runValidate (exceptToValidateWith (:[]) (throwError "boom")) 195 | `shouldBe` (Left ["boom"] :: Either [Text] Integer) 196 | 197 | describe "validateToError" $ 198 | it "converts an ValidateT computation to ExceptT" $ do 199 | runExcept (validateToError (pure 42)) 200 | `shouldBe` (Right 42 :: Either [Text] Integer) 201 | runExcept (validateToError (refute ["boom"] *> refute ["bang"])) 202 | `shouldBe` (Left ["boom", "bang"] :: Either [Text] Integer) 203 | 204 | describe "validateToErrorWith" $ 205 | it "converts an ValidateT computation to ExceptT by applying a function to any errors" $ do 206 | runExcept (validateToErrorWith mconcat (pure 42)) 207 | `shouldBe` (Right 42 :: Either Text Integer) 208 | runExcept (validateToErrorWith mconcat (refute ["boom"] *> refute ["bang"])) 209 | `shouldBe` (Left "boombang" :: Either Text Integer) 210 | 211 | it "collects validation information from all sub-branches of <*>" $ do 212 | let tables = 213 | [ (TableName "public" "users", 214 | [ (ColumnName "name", ColumnInfo False) 215 | , (ColumnName "password", ColumnInfo True) 216 | , (ColumnName "points", ColumnInfo False) ]) 217 | , (TableName "private" "tables", 218 | [ (ColumnName "id", ColumnInfo False) 219 | , (ColumnName "schema", ColumnInfo False) ]) ] 220 | env = Env tables [] 221 | testCase input = runReader (runValidateT (validateQueryRequest input)) env 222 | 223 | testCase [aesonQQ| {} |] `shouldBe` Left 224 | [ Error [] $ JSONMissingKey "auth_token" 225 | , Error [] $ JSONMissingKey "table" 226 | , Error [] $ JSONMissingKey "query" ] 227 | 228 | testCase [aesonQQ| { "auth_token": null, "table": null, "query": null } |] `shouldBe` Left 229 | [ Error ["auth_token"] $ JSONBadValue "string" Null 230 | , Error ["table"] $ JSONBadValue "table name" Null 231 | , Error ["query"] $ JSONBadValue "query expression" Null ] 232 | 233 | testCase [aesonQQ| 234 | { "auth_token": "abc123" 235 | , "table": { "schema": "public", "name": "people" } 236 | , "query": { "lit": "42" } 237 | } |] `shouldBe` Left 238 | [ Error ["table"] $ UnknownTableName (TableName "public" "people") 239 | , Error ["query", "lit"] $ JSONBadValue "number" (String "42") ] 240 | 241 | testCase [aesonQQ| 242 | { "auth_token": "abc123" 243 | , "table": { "schema": "public", "name": "users" } 244 | , "query": { "lit": 42 } 245 | } |] `shouldBe` Right QueryRequest 246 | { qrAuth = AuthToken "abc123" False 247 | , qrTable = TableName "public" "users" 248 | , qrQuery = QLit 42 } 249 | 250 | testCase [aesonQQ| 251 | { "auth_token": "abc123" 252 | , "table": { "schema": "public", "name": "users" } 253 | , "query": { "add": 254 | [ { "select": "password" } 255 | , { "select": "email" } ]} 256 | } |] `shouldBe` Left 257 | [ Error ["query", "add", "select"] $ InsufficientPermissions 258 | (TableName "public" "users") 259 | (ColumnName "password") 260 | , Error ["query", "add", "select"] $ UnknownColumnName 261 | (TableName "public" "users") 262 | (ColumnName "email") ] 263 | 264 | testCase [aesonQQ| 265 | { "auth_token": "abc123:super_secret_admin_password" 266 | , "table": { "schema": "public", "name": "users" } 267 | , "query": { "add": 268 | [ { "select": "name" } 269 | , { "select": "password" } ]} 270 | } |] `shouldBe` Right QueryRequest 271 | { qrAuth = AuthToken "abc123" True 272 | , qrTable = TableName "public" "users" 273 | , qrQuery = QAdd (QSelect (ColumnName "name")) (QSelect (ColumnName "password")) } 274 | 275 | testCase [aesonQQ| 276 | { "auth_token": 123 277 | , "table": { "name": "users" } 278 | , "query": { "add": 279 | [ { "lit": "42" } 280 | , { "select": "points" } ]} 281 | } |] `shouldBe` Left 282 | [ Error ["auth_token"] (JSONBadValue "string" (Number 123)) 283 | , Error ["table"] (JSONMissingKey "schema") 284 | , Error ["query", "add", "lit"] (JSONBadValue "number" (String "42")) ] 285 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} --------------------------------------------------------------------------------