├── .ghci ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .travis.yml ├── LICENCE ├── README.md ├── cabal.project ├── changelog ├── ci ├── ci.nix ├── jobsets.json └── jobsets.nix ├── default.nix ├── examples ├── .gitignore ├── LICENCE ├── Setup.hs ├── src │ ├── Email.hs │ ├── Main.hs │ ├── Person.hs │ └── PolymorphicEmail.hs └── validation-examples.cabal ├── lower-bounds.project ├── shell.nix ├── src └── Data │ └── Validation.hs ├── test ├── .gitignore ├── hedgehog_tests.hs └── hunit_tests.hs ├── validation.cabal └── validation.nix /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -idist/build/autogen 2 | :set -optP-include -optPdist/build/autogen/cabal_macros.h 3 | :set prompt ">> " 4 | :set -Wall 5 | 6 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | on: 2 | # Build every pull request, to check for regressions. 3 | pull_request: 4 | 5 | # Build when a PR is merged, to update the README's CI badge. 6 | push: 7 | 8 | name: build 9 | 10 | env: 11 | CONFIG: --enable-benchmarks --enable-documentation --enable-tests --haddock-all --haddock-hyperlink-source --haddock-internal 12 | 13 | defaults: 14 | run: 15 | shell: bash 16 | 17 | jobs: 18 | 19 | # Run HLint to check for code improvements 20 | hlint: 21 | name: HLint Check 22 | runs-on: ubuntu-latest 23 | steps: 24 | - uses: actions/checkout@v2.3.4 25 | - uses: haskell/actions/setup@v2 26 | - run: | 27 | curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s examples/src src -j 28 | 29 | 30 | # Check that the project builds with the specified lower bounds. 31 | lower-bounds: 32 | env: 33 | CONSTRAINTS: --project-file=lower-bounds.project 34 | name: Lower Bounds Check 35 | runs-on: ubuntu-latest 36 | 37 | steps: 38 | - uses: actions/checkout@v2.3.4 39 | - uses: haskell/actions/setup@v2 40 | name: Setup Haskell 41 | with: 42 | cabal-version: latest 43 | ghc-version: 8.4.4 44 | 45 | - run: cabal update 46 | - run: cabal clean 47 | - run: cabal configure $CONFIG $CONSTRAINTS 48 | - run: cabal freeze $CONFIG $CONSTRAINTS 49 | - uses: actions/cache@v2 50 | name: caching lower bounds check 51 | with: 52 | path: | 53 | ~/.cabal/store 54 | dist-newstyle 55 | key: ${{ runner.os }}-lower-bounds-${{ hashFiles('cabal.project.freeze') }} 56 | 57 | - run: cabal build $CONFIG $CONSTRAINTS --only-dependencies 58 | - run: cabal build $CONFIG $CONSTRAINTS 59 | 60 | 61 | # Check that the project builds with the specified lower bounds. 62 | unit-tests: 63 | name: Unit Tests 64 | runs-on: ubuntu-latest 65 | 66 | steps: 67 | - uses: actions/checkout@v2.3.4 68 | - uses: haskell/actions/setup@v2 69 | name: Setup Haskell 70 | with: 71 | cabal-version: latest 72 | ghc-version: latest 73 | 74 | - run: cabal update 75 | - run: cabal clean 76 | - run: cabal configure --enable-tests --with-compiler=ghc 77 | - run: cabal freeze --enable-tests 78 | - uses: actions/cache@v2 79 | name: caching lower bounds check 80 | with: 81 | path: | 82 | ~/.cabal/store 83 | dist-newstyle 84 | key: ${{ runner.os }}-tests-${{ hashFiles('cabal.project.freeze') }} 85 | 86 | - run: cabal test 87 | 88 | 89 | # Cabal build matrix 90 | cabal-build-matrix: 91 | name: GHC-${{ matrix.ghc }}, cabal${{matrix.cabal}}, ${{matrix.os}} 92 | runs-on: ${{ matrix.os }} 93 | strategy: 94 | fail-fast: false 95 | matrix: 96 | ghc: [ '8.4.4', '8.6.5', '8.8.4', '8.10.4', '9.0.1' ] 97 | cabal: [ latest ] 98 | os: [ ubuntu-latest ] 99 | 100 | steps: 101 | - uses: actions/checkout@v2.3.4 102 | - uses: haskell/actions/setup@v2 103 | name: Setup Haskell 104 | with: 105 | ghc-version: ${{ matrix.ghc }} 106 | cabal-version: ${{ matrix.cabal }} 107 | - run: gcc --version 108 | - run: g++ --version 109 | - run: ghc --version 110 | - run: cabal update 111 | - run: cabal clean 112 | - run: cabal configure $CONFIG --with-compiler=ghc 113 | - run: cabal freeze $CONFIG 114 | - uses: actions/cache@v2 115 | name: windows caching 116 | with: 117 | path: | 118 | c:\sr 119 | dist-newstyle 120 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 121 | # restore keys is a fall back when the freeze plan is different 122 | restore-keys: | 123 | ${{ runner.os }}-${{ matrix.ghc }}- 124 | if: matrix.os == 'windows-latest' 125 | - uses: actions/cache@v2 126 | name: ubuntu-linux and osx caching 127 | with: 128 | path: | 129 | ~/.cabal/store 130 | dist-newstyle 131 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 132 | # restore keys is a fall back when the freeze plan is different 133 | restore-keys: | 134 | ${{ runner.os }}-${{ matrix.ghc }}- 135 | if: matrix.os != 'windows-latest' 136 | - run: cabal build --only-dependencies 137 | - run: cabal build $CONFIG 138 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | 4 | # CABAL 5 | /dist 6 | /dist-newstyle 7 | /.cabal-sandbox 8 | /cabal.sandbox.config 9 | /cabal.project.local 10 | 11 | # nix 12 | /result 13 | 14 | # Haskell Program Coverage 15 | /.hpc 16 | /*.tix 17 | 18 | # Leksah 19 | *.lkshs 20 | 21 | # Intellij IDEA 22 | /.idea 23 | *.iml 24 | 25 | # ctags 26 | TAGS 27 | 28 | .stack-work 29 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'validation.cabal' '-o' '.travis.yml' '--tests-jobs' '>=7.10' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | # version: 0.3 8 | # 9 | language: c 10 | dist: xenial 11 | 12 | git: 13 | submodules: false # whether to recursively clone submodules 14 | 15 | cache: 16 | directories: 17 | - $HOME/.cabal/packages 18 | - $HOME/.cabal/store 19 | 20 | before_cache: 21 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 22 | # remove files that are regenerated by 'cabal update' 23 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 24 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 25 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 27 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 28 | 29 | - rm -rfv $CABALHOME/packages/head.hackage 30 | 31 | matrix: 32 | include: 33 | - compiler: "ghc-8.6.4" 34 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.4], sources: [hvr-ghc]}} 35 | - compiler: "ghc-8.4.4" 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.2.2" 38 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}} 39 | - compiler: "ghc-8.0.2" 40 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}} 41 | - compiler: "ghc-7.10.3" 42 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}} 43 | - compiler: "ghc-7.8.4" 44 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.8.4], sources: [hvr-ghc]}} 45 | - compiler: "ghc-7.6.3" 46 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.6.3], sources: [hvr-ghc]}} 47 | - compiler: "ghc-7.4.2" 48 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.4.2], sources: [hvr-ghc]}} 49 | 50 | before_install: 51 | - HC=/opt/ghc/bin/${CC} 52 | - HCPKG=${HC/ghc/ghc-pkg} 53 | - unset CC 54 | - CABAL=/opt/ghc/bin/cabal 55 | - CABALHOME=$HOME/.cabal 56 | - export PATH="$CABALHOME/bin:$PATH" 57 | - ROOTDIR=$(pwd) 58 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 59 | - echo $HCNUMVER 60 | 61 | install: 62 | - ${CABAL} --version 63 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 64 | - TEST=--enable-tests 65 | - if [ $HCNUMVER -lt 71000 ] ; then TEST=--disable-tests ; fi 66 | - BENCH=--enable-benchmarks 67 | - GHCHEAD=${GHCHEAD-false} 68 | - travis_retry ${CABAL} update -v 69 | - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config 70 | - rm -fv cabal.project cabal.project.local 71 | - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$' 72 | - rm -f cabal.project 73 | - touch cabal.project 74 | - "printf 'packages: \".\"\\n' >> cabal.project" 75 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 76 | - touch cabal.project.local 77 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(validation)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 78 | - cat cabal.project || true 79 | - cat cabal.project.local || true 80 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 81 | - rm -f cabal.project.freeze 82 | - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry 83 | - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 84 | - rm "cabal.project.freeze" 85 | - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 86 | - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 87 | - rm -rf .ghc.environment.* "."/dist 88 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 89 | 90 | # Here starts the actual work to be performed for the package under test; 91 | # any command which exits with a non-zero exit code causes the build to fail. 92 | script: 93 | # test that source-distributions can be generated 94 | - ${CABAL} new-sdist all 95 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 96 | - cd ${DISTDIR} || false 97 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 98 | - rm -f cabal.project 99 | - touch cabal.project 100 | - "printf 'packages: \"validation-*/*.cabal\"\\n' >> cabal.project" 101 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 102 | - touch cabal.project.local 103 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(validation)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 104 | - cat cabal.project || true 105 | - cat cabal.project.local || true 106 | # this builds all libraries and executables (without tests/benchmarks) 107 | - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all 108 | 109 | # build & run tests, build benchmarks 110 | - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all 111 | - if [ $HCNUMVER -ge 71000 ] ; then ${CABAL} new-test -w ${HC} ${TEST} ${BENCH} all ; fi 112 | 113 | # cabal check 114 | - (cd validation-* && ${CABAL} check) 115 | 116 | # haddock 117 | - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all 118 | 119 | # Build without installed constraints for packages in global-db 120 | - rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all 121 | 122 | # REGENDATA ["validation.cabal","-o",".travis.yml","--tests-jobs",">=7.10"] 123 | # EOF 124 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright 2010-2013 Tony Morris, Nick Partridge 2 | Copyright 2014,2015 NICTA Limited 3 | Copyright 2016,2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. 4 | 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 3. Neither the name of the author nor the names of his contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 25 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 26 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 28 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 29 | SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Validation 2 | 3 | ![CSIRO's Data61 Logo](https://raw.githubusercontent.com/qfpl/assets/master/data61-transparent-bg.png) 4 | 5 | Several data-types like Either but with differing properties and type-class 6 | instances. 7 | 8 | Library support is provided for those different representations, include 9 | `lens`-related functions for converting between each and abstracting over their 10 | similarities. 11 | 12 | Download from [hackage](http://hackage.haskell.org/package/validation). 13 | 14 | * `Validation` 15 | 16 | The `Validation` data type is isomorphic to `Either`, but has an instance 17 | of `Applicative` that accumulates on the error side. That is to say, if two 18 | (or more) errors are encountered, they are appended using a `Semigroup` 19 | operation. 20 | 21 | As a consequence of this `Applicative` instance, there is no corresponding 22 | `Bind` or `Monad` instance. `Validation` is an example of, "An applicative 23 | functor that is not a monad." 24 | 25 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./ 3 | examples/ 4 | 5 | -------------------------------------------------------------------------------- /changelog: -------------------------------------------------------------------------------- 1 | 1.1.3 2 | 3 | * Fix CI for older GHC 4 | 5 | 1.1.2 6 | 7 | * Drop support for GHC-7.8.*, GHC-7.6.*, GHC-7.4.*, and GHC-7.2.* 8 | * Adjust lower bounds of most dependencies to be inline with the lowest supported GHC version of 7.10.3 9 | 10 | 1.1.1 11 | 12 | * Add `Data.Bifunctor.Swap.Swap` instance from `swap` 13 | * Support `lens ^>= 5` 14 | 15 | 1.1 16 | 17 | * Generalise types of `validate` and `ensure` functions to use `Maybe` instead of `Bool` 18 | 19 | 1 20 | 21 | * Rename `AccValidation` to `Validation` 22 | 23 | 0.6.3 24 | 25 | * Add `Generic` and `NFData` instances 26 | * Make AccValidation Apply and Applicative lazier 27 | 28 | 0.6.2 29 | 30 | * Add `bindValidation` and `validationed` 31 | 32 | 0.6.1 33 | 34 | * Add validate, validationnel, fromEither, liftError, validation, toEither, orElse, valueOr, ensure, codiagonal, revalidate 35 | 36 | 0.6.0 37 | 38 | * Delete `Validation`, `ValidationB`, `ValidationT`, `Validation'` 39 | * Remove `_Validation` member from `Validate` class 40 | 41 | 0.5.5 42 | 43 | * Raise upper bounds on base. 44 | * Include nix build. 45 | 46 | 0.5.4 47 | 48 | * remove redundant constraints. 49 | * add instance `Validate` for `ValidationB Identity`. 50 | 51 | 0.5.3 52 | 53 | * Update `transformers` dependency to work with GHC8. 54 | 55 | 0.5.2 56 | 57 | * Remove LANGUAGE Safe because won't build against lens-4.13 or higher otherwise. 58 | 59 | 0.5.1 60 | 61 | * Update documentation 62 | 63 | 0.5.0 64 | 65 | * Export the `ValidationB` (formerly `ValidationTB`) data type. 66 | * Renamed `ValidationTB` to `ValidationB`. 67 | * Add upper-bounds on some dependencies. 68 | * Move repository to https://github.com/NICTA/validation. 69 | * Add README. 70 | * Update copyright notice for 2015. 71 | 72 | 0.4.3 73 | 74 | * Rename `ValidationT` to `ValidationTB` 75 | * Introduce `ValidationT` with `MonadTrans` instance 76 | 77 | 0.4.2 78 | 79 | * Export constructors on `AccValidation` and `Validation`. 80 | 81 | 0.4.1 82 | 83 | * Remove `Alternative` instances. They are obscene. 84 | * INLINE pragmas 85 | 86 | 0.4.0 87 | 88 | * Change the premise of the `Validate` type-class to more strongly reflect the isomorphism to Either. 89 | * The `_Failure` and `_Success` prisms are now derived. 90 | * Lots more examples 91 | 92 | 0.3.0 93 | 94 | A restructuring of 0.2.x where: 95 | 96 | * Tests updated to use doctest 97 | * Update API to use Prism and Iso (Control.Lens) 98 | * Rename package Validation (deprecated) to validation 99 | 100 | 0.3.1 101 | 102 | Use Safe Haskell pragma 103 | 104 | 0.3.2 105 | 106 | Implement Validate on Either 107 | 108 | 0.3.3 109 | 110 | Provide Isos between (ValidationT Identity) and other data types. 111 | 112 | 0.3.4 113 | 114 | Loosen the type of the Isos for polymorphic update. 115 | -------------------------------------------------------------------------------- /ci/ci.nix: -------------------------------------------------------------------------------- 1 | { supportedSystems ? ["x86_64-linux"] 2 | , supportedCompilers ? [ "ghc802" "ghc822" "ghc843" ] 3 | }: 4 | 5 | with (import { inherit supportedSystems; }); 6 | 7 | let 8 | pkgs = import {}; 9 | 10 | configurations = 11 | pkgs.lib.listToAttrs ( 12 | pkgs.lib.concatMap (compiler: 13 | pkgs.lib.concatMap (system: 14 | [{name = "haskell-packages-" + compiler + "-validation-" + system ; value = {inherit compiler system;};}] 15 | ) supportedSystems 16 | ) supportedCompilers 17 | ); 18 | 19 | jobs = 20 | pkgs.lib.mapAttrs (name: configuration: 21 | let 22 | compiler = configuration.compiler; 23 | system = configuration.system; 24 | nixpkgs = { pkgs = pkgsFor system; }; 25 | validation = import ../default.nix { inherit nixpkgs compiler; }; 26 | in 27 | validation 28 | ) configurations; 29 | in 30 | jobs 31 | -------------------------------------------------------------------------------- /ci/jobsets.json: -------------------------------------------------------------------------------- 1 | { 2 | "enabled": 1, 3 | "hidden": false, 4 | "description": "jobsets", 5 | "nixexprinput": "validation", 6 | "nixexprpath": "ci/jobsets.nix", 7 | "checkinterval": 300, 8 | "schedulingshares": 1, 9 | "enableemail": false, 10 | "emailoverride": "", 11 | "keepnr": 5, 12 | "inputs": { 13 | "validation": { "type": "git", "value": "https://github.com/qfpl/validation", "emailresponsible": false }, 14 | "nixpkgs": { "type": "git", "value": "https://github.com/NixOS/nixpkgs.git release-18.09", "emailresponsible": false } 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /ci/jobsets.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs, declInput }: let pkgs = import nixpkgs {}; in { 2 | jobsets = pkgs.runCommand "spec.json" {} '' 3 | cat < $out < {}, compiler ? "default" }: 2 | 3 | let 4 | 5 | inherit (nixpkgs) pkgs; 6 | 7 | haskellPackages = if compiler == "default" 8 | then pkgs.haskellPackages 9 | else pkgs.haskell.packages.${compiler}; 10 | 11 | 12 | validation = haskellPackages.callPackage ./validation.nix {}; 13 | 14 | in 15 | 16 | validation 17 | -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | 4 | # CABAL 5 | /dist 6 | /.cabal-sandbox 7 | /cabal.sandbox.config 8 | 9 | # Haskell Program Coverage 10 | /.hpc 11 | /*.tix 12 | 13 | # Leksah 14 | *.lkshs 15 | 16 | # Intellij IDEA 17 | /.idea 18 | *.iml 19 | 20 | # ctags 21 | TAGS 22 | 23 | -------------------------------------------------------------------------------- /examples/LICENCE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Tony Morris, Nick Partridge 2 | Copyright 2014,2015 NICTA Limited 3 | Copyright 2016,2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. 4 | 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 3. Neither the name of the author nor the names of his contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 25 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 26 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 28 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 29 | SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /examples/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/src/Email.hs: -------------------------------------------------------------------------------- 1 | -- Example that shows how to validate a single value 2 | -- with multiple validation functions/smart constructors. 3 | 4 | -- Thanks to @purefn for the help on this! 5 | 6 | import Control.Lens 7 | import Data.List (isInfixOf) 8 | import Data.Validation 9 | 10 | -- ***** Types ***** 11 | newtype AtString = AtString String deriving (Show) 12 | newtype PeriodString = PeriodString String deriving (Show) 13 | newtype NonEmptyString = NonEmptyString String deriving (Show) 14 | 15 | newtype Email = Email String deriving (Show) 16 | 17 | data VError = MustNotBeEmpty 18 | | MustContainAt 19 | | MustContainPeriod 20 | deriving (Show) 21 | 22 | -- ***** Base smart constructors ***** 23 | -- String must contain an '@' character 24 | atString :: String -> Validation [VError] AtString 25 | atString x = if "@" `isInfixOf` x 26 | then _Success # AtString x 27 | else _Failure # [MustContainAt] 28 | 29 | -- String must contain an '.' character 30 | periodString :: String -> Validation [VError] PeriodString 31 | periodString x = if "." `isInfixOf` x 32 | then _Success # PeriodString x 33 | else _Failure # [MustContainPeriod] 34 | 35 | -- String must not be empty 36 | nonEmptyString :: String -> Validation [VError] NonEmptyString 37 | nonEmptyString x = if x /= [] 38 | then _Success # NonEmptyString x 39 | else _Failure # [MustNotBeEmpty] 40 | 41 | -- ***** Combining smart constructors ***** 42 | email :: String -> Validation [VError] Email 43 | email x = Email x <$ 44 | nonEmptyString x <* 45 | atString x <* 46 | periodString x 47 | 48 | -- ***** Example usage ***** 49 | success = email "bob@gmail.com" 50 | -- Success (Email "bob@gmail.com") 51 | 52 | failureAt = email "bobgmail.com" 53 | -- Failure [MustContainAt] 54 | 55 | failurePeriod = email "bob@gmailcom" 56 | -- Failure [MustContainPeriod] 57 | 58 | failureAll = email "" 59 | -- Failure [MustNotBeEmpty,MustContainAt,MustContainPeriod] 60 | 61 | main :: IO () 62 | main = do 63 | putStrLn $ "email \"bob@gmail.com\": " ++ show success 64 | putStrLn $ "email \"bobgmail.com\": " ++ show failureAt 65 | putStrLn $ "email \"bob@gmailcom\": " ++ show failurePeriod 66 | putStrLn $ "email \"\": " ++ show failureAll 67 | -------------------------------------------------------------------------------- /examples/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Lens.Getter((^.)) 4 | import Control.Lens.Iso(from) 5 | import Control.Lens.Review(( # )) 6 | import Data.Bifoldable(bitraverse_, bimapM_) 7 | import Data.Bifunctor(second, first) 8 | import Data.Validation(Validation, _Validation, _Either, _Success, _Failure) 9 | 10 | main :: 11 | IO () 12 | main = 13 | putStrLn "5" 14 | 15 | -- Creating Values 16 | -- 17 | -- Use the _Success and _Failure prisms 18 | 19 | successVal :: 20 | Validation e String 21 | successVal = 22 | _Success # "A" 23 | 24 | successEither :: 25 | Either e String 26 | successEither = 27 | _Success # "A" 28 | 29 | failureVal :: 30 | Validation Int a 31 | failureVal = 32 | _Failure # 5 33 | 34 | -- | Mapping 35 | -- 36 | -- The validation types are Functors over the success values, 37 | -- and are Bifunctors. 38 | exMapping :: 39 | () 40 | exMapping = 41 | let -- fmap/second are equivalent, and map successes 42 | _ = fmap (++ " B" ) successVal 43 | _ = second (++ " B") successVal 44 | _ = first (+1) failureVal 45 | _ = first (+(1 :: Integer)) successVal -- does nothing 46 | in () 47 | 48 | -- | Folding 49 | -- 50 | -- The Validation types are Bifoldable and Bitraversable 51 | -- http://hackage.haskell.org/package/bifunctors-4.1.1.1/docs/Data-Bifoldable.html 52 | -- These typeclasses have rich APIs, and would probably replace most usages of 53 | -- pattern matching. 54 | 55 | exFolding :: 56 | IO () 57 | exFolding = 58 | do 59 | bitraverse_ onFailure onSuccess successVal 60 | -- OR 61 | bimapM_ onFailure onSuccess successVal 62 | where onFailure _ = putStrLn "Some failure" 63 | onSuccess v = putStrLn $ "Good " ++ v 64 | 65 | -- | Converting 66 | -- There are isomorphisms between the validation types, and Either. 67 | -- 'from' will reverse the isomorphism. 68 | 69 | exConvert :: 70 | IO () 71 | exConvert = 72 | do 73 | print (successVal ^. from _Validation :: Either Int String) 74 | print (successEither ^. from _Either :: Validation Int String) 75 | -------------------------------------------------------------------------------- /examples/src/Person.hs: -------------------------------------------------------------------------------- 1 | module Person where 2 | 3 | import Control.Lens 4 | import Data.List (isInfixOf) 5 | import Data.Validation 6 | 7 | newtype Name = Name { unName :: String } deriving Show 8 | newtype Email = Email { unEmail :: String } deriving Show 9 | newtype Age = Age { unAge :: Int } deriving Show 10 | 11 | data Person = Person { name :: Name 12 | , email :: Email 13 | , age :: Age 14 | } deriving Show 15 | 16 | data Error = NameBetween1And50 17 | | EmailMustContainAtChar 18 | | AgeBetween0and120 19 | deriving Show 20 | 21 | -- Smart constructors 22 | mkName :: String -> Validation [Error] Name 23 | mkName s = let l = length s 24 | in if l >= 1 && l <= 50 25 | then _Success # Name s 26 | else _Failure # [ NameBetween1And50 ] 27 | 28 | 29 | mkEmail :: String -> Validation [Error] Email 30 | mkEmail s = if "@" `isInfixOf` s 31 | then _Success # Email s 32 | else _Failure # [ EmailMustContainAtChar ] 33 | 34 | mkAge :: Int -> Validation [Error] Age 35 | mkAge a = if a >= 0 && a <= 120 36 | then _Success # Age a 37 | else _Failure # [ AgeBetween0and120 ] 38 | 39 | mkPerson :: String -> String -> Int -> Validation [Error] Person 40 | mkPerson pName pEmail pAge = 41 | Person 42 | <$> mkName pName 43 | <*> mkEmail pEmail 44 | <*> mkAge pAge 45 | 46 | -- Examples 47 | -- Data constructors for `Name`, `Age`, `Email`, and `Person` should not be 48 | -- exported to the example code below: 49 | 50 | validPerson :: Validation [Error] Person 51 | validPerson = mkPerson "Bob" "bob@gmail.com" 25 52 | -- Success (Person {name = Name {unName = "Bob"}, email = Email {unEmail = "bob@gmail.com"}, age = Age {unAge = 25}}) 53 | 54 | badName :: Validation [Error] Person 55 | badName = mkPerson "" "bob@gmail.com" 25 56 | -- Failure [NameBetween1And50] 57 | 58 | badEmail :: Validation [Error] Person 59 | badEmail = mkPerson "Bob" "bademail" 25 60 | -- Failure [EmailMustContainAtChar] 61 | 62 | badAge :: Validation [Error] Person 63 | badAge = mkPerson "Bob" "bob@gmail.com" 150 64 | -- Failure [AgeBetween0and120] 65 | 66 | badEverything :: Validation [Error] Person 67 | badEverything = mkPerson "" "bademail" 150 68 | -- Failure [NameBetween1And50,EmailMustContainAtChar,AgeBetween0and120] 69 | 70 | asMaybeGood :: Maybe Person 71 | asMaybeGood = validPerson ^? _Success 72 | -- Just (Person {name = Name {unName = "Bob"}, email = Email {unEmail = "bob@gmail.com"}, age = Age {unAge = 25}}) 73 | 74 | asMaybeBad :: Maybe Person 75 | asMaybeBad = badEverything ^? _Success 76 | -- Nothing 77 | 78 | asEitherGood :: Either [Error] Person 79 | asEitherGood = validPerson ^. _Either 80 | -- Right (Person {name = Name {unName = "Bob"}, email = Email {unEmail = "bob@gmail.com"}, age = Age {unAge = 25}}) 81 | 82 | asEitherBad :: Either [Error] Person 83 | asEitherBad = badEverything ^. _Either 84 | -- Left [NameBetween1And50,EmailMustContainAtChar,AgeBetween0and120] 85 | 86 | main :: IO () 87 | main = do 88 | putStrLn $ "validPerson: " ++ show validPerson 89 | putStrLn $ "badName: " ++ show badName 90 | putStrLn $ "badEmail: " ++ show badEmail 91 | putStrLn $ "badAge: " ++ show badAge 92 | putStrLn $ "badEverything: " ++ show badEverything 93 | putStrLn $ "asMaybeGood: " ++ show asMaybeGood 94 | putStrLn $ "asMaybeBad: " ++ show asMaybeBad 95 | putStrLn $ "asEitherGood: " ++ show asEitherGood 96 | putStrLn $ "asEitherBad: " ++ show asEitherBad 97 | -------------------------------------------------------------------------------- /examples/src/PolymorphicEmail.hs: -------------------------------------------------------------------------------- 1 | -- Modification of the Email example, that leaves the validation 2 | -- functions polymorphic. 3 | 4 | -- This lets us choose whether to accumulate all errors, by specialising 5 | -- to Validation, or abort on the first error with Either. 6 | 7 | -- Aside from main, the code is unchanged but the type signatures have 8 | -- been relaxed to be as polymorphic as possible. 9 | 10 | import Prelude 11 | 12 | import Control.Lens 13 | import Data.List (isInfixOf) 14 | import Data.Validation 15 | 16 | newtype Email = Email String deriving (Show) 17 | 18 | data VError = MustNotBeEmpty 19 | | MustContainAt 20 | | MustContainPeriod 21 | deriving (Show) 22 | 23 | -- ***** Base smart constructors ***** 24 | -- String must contain an '@' character 25 | atString :: Validate f => String -> f [VError] () 26 | atString x = if "@" `isInfixOf` x 27 | then _Success # () 28 | else _Failure # [MustContainAt] 29 | 30 | -- String must contain an '.' character 31 | periodString :: Validate f => String -> f [VError] () 32 | periodString x = if "." `isInfixOf` x 33 | then _Success # () 34 | else _Failure # [MustContainPeriod] 35 | 36 | -- String must not be empty 37 | nonEmptyString :: Validate f => String -> f [VError] () 38 | nonEmptyString x = if x /= [] 39 | then _Success # () 40 | else _Failure # [MustNotBeEmpty] 41 | 42 | -- ***** Combining smart constructors ***** 43 | email :: (Validate f, Applicative (f [VError])) => String -> f [VError] Email 44 | email x = Email x <$ 45 | nonEmptyString x <* 46 | atString x <* 47 | periodString x 48 | 49 | -- ***** Example usage ***** 50 | success :: (Applicative (f [VError]), Validate f) => f [VError] Email 51 | success = email "bob@gmail.com" 52 | -- Success (Email "bob@gmail.com") 53 | 54 | failureAt :: (Applicative (f [VError]), Validate f) => f [VError] Email 55 | failureAt = email "bobgmail.com" 56 | -- Failure [MustContainAt] 57 | 58 | failurePeriod :: (Applicative (f [VError]), Validate f) => f [VError] Email 59 | failurePeriod = email "bob@gmailcom" 60 | -- Failure [MustContainPeriod] 61 | 62 | failureAll :: (Applicative (f [VError]), Validate f) => f [VError] Email 63 | failureAll = email "" 64 | -- Failure [MustNotBeEmpty,MustContainAt,MustContainPeriod] 65 | 66 | 67 | -- Helper to force a validation to Validation 68 | asVal :: Validation a b -> Validation a b 69 | asVal = id 70 | 71 | -- Helper to force a validation to Validation 72 | asEither :: Either a b -> Either a b 73 | asEither = id 74 | 75 | main :: IO () 76 | main = do 77 | putStrLn "Collect all errors" 78 | putStrLn $ "email \"bob@gmail.com\": " ++ show (asVal success) 79 | putStrLn $ "email \"bobgmail.com\": " ++ show (asVal failureAt) 80 | putStrLn $ "email \"bob@gmailcom\": " ++ show (asVal failurePeriod) 81 | putStrLn $ "email \"\": " ++ show (asVal failureAll) 82 | putStrLn "Stop at the first error" 83 | putStrLn $ "email \"bob@gmail.com\": " ++ show (asEither success) 84 | putStrLn $ "email \"\": " ++ show (asEither failureAll) 85 | -------------------------------------------------------------------------------- /examples/validation-examples.cabal: -------------------------------------------------------------------------------- 1 | name: validation-examples 2 | version: 1 3 | license: BSD3 4 | license-file: LICENCE 5 | author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge 6 | maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge 7 | copyright: Copyright (C) 2010-2013 Tony Morris, Nick Partridge 8 | Copyright (C) 2014,2015 NICTA Limited 9 | Copyright (c) 2016,2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. 10 | synopsis: Examples for the Validation package 11 | category: Data 12 | description: Examples for the validation package. 13 | homepage: https://github.com/qfpl/validation 14 | bug-reports: https://github.com/qfpl/validation/issues 15 | cabal-version: >= 1.10 16 | build-type: Simple 17 | tested-with: GHC==8.6.1, GHC==8.4.3, GHC==8.2.2 18 | 19 | source-repository head 20 | type: git 21 | location: git@github.com:qfpl/validation.git 22 | 23 | executable validation-examples 24 | main-is: 25 | Main.hs 26 | 27 | default-language: 28 | Haskell2010 29 | 30 | build-depends: 31 | base >= 4.11 && < 5 32 | , validation >= 1 && < 1.2 33 | , lens >= 4 && < 6 34 | , bifunctors >= 3 && < 6 35 | 36 | ghc-options: 37 | -Wall 38 | 39 | hs-source-dirs: 40 | src 41 | -------------------------------------------------------------------------------- /lower-bounds.project: -------------------------------------------------------------------------------- 1 | constraints: 2 | assoc ==1.0.*, 3 | base ==4.11.*, 4 | bifunctors ==5.5.*, 5 | deepseq ==1.4.*, 6 | ghc-prim ==0.5.*, 7 | hedgehog ==0.5.*, 8 | HUnit ==1.6.*, 9 | lens ==4.*, 10 | semigroupoids ==5.*, 11 | semigroups ==0.18.* 12 | 13 | packages: 14 | ./ 15 | examples/ 16 | 17 | with-compiler: ghc-8.4.4 18 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "default" }: 2 | let 3 | inherit (nixpkgs) pkgs; 4 | drv = import ./default.nix { inherit nixpkgs compiler; }; 5 | in 6 | if pkgs.lib.inNixShell then drv.env else drv 7 | -------------------------------------------------------------------------------- /src/Data/Validation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | -- | A data type similar to @Data.Either@ that accumulates failures. 9 | module Data.Validation 10 | ( 11 | -- * Data type 12 | Validation(..) 13 | -- * Constructing validations 14 | , validate 15 | , validationNel 16 | , fromEither 17 | , liftError 18 | -- * Functions on validations 19 | , validation 20 | , toEither 21 | , orElse 22 | , valueOr 23 | , ensure 24 | , codiagonal 25 | , validationed 26 | , bindValidation 27 | -- * Prisms 28 | -- | These prisms are useful for writing code which is polymorphic in its 29 | -- choice of Either or Validation. This choice can then be made later by a 30 | -- user, depending on their needs. 31 | -- 32 | -- An example of this style of usage can be found 33 | -- 34 | , _Failure 35 | , _Success 36 | -- * Isomorphisms 37 | , Validate(..) 38 | , revalidate 39 | ) where 40 | 41 | import Control.Applicative(Applicative((<*>), pure), (<$>)) 42 | import Control.DeepSeq (NFData (rnf)) 43 | import Control.Lens (over, under) 44 | import Control.Lens.Getter((^.)) 45 | import Control.Lens.Iso(Iso, iso, from 46 | #if !MIN_VERSION_lens(4,20,0) 47 | , Swapped(..)) 48 | #else 49 | ) 50 | #endif 51 | import Control.Lens.Prism(Prism, _Left, _Right) 52 | import Control.Lens.Review(( # )) 53 | import Data.Bifoldable(Bifoldable(bifoldr)) 54 | import Data.Bifunctor(Bifunctor(bimap)) 55 | import Data.Bifunctor.Swap(Swap(..)) 56 | import Data.Bitraversable(Bitraversable(bitraverse)) 57 | import Data.Data(Data) 58 | import Data.Either(Either(Left, Right), either) 59 | import Data.Eq(Eq) 60 | import Data.Foldable(Foldable(foldr)) 61 | import Data.Function((.), ($), id) 62 | import Data.Functor(Functor(fmap)) 63 | import Data.Functor.Alt(Alt(())) 64 | import Data.Functor.Apply(Apply((<.>))) 65 | import Data.List.NonEmpty (NonEmpty) 66 | import Data.Monoid(Monoid(mempty)) 67 | import Data.Ord(Ord) 68 | import Data.Semigroup(Semigroup((<>))) 69 | import Data.Traversable(Traversable(traverse)) 70 | import Data.Typeable(Typeable) 71 | import GHC.Generics (Generic) 72 | import Prelude(Show, Maybe(..)) 73 | 74 | 75 | -- | A @Validation@ is either a value of the type @err@ or @a@, similar to 'Either'. However, 76 | -- the 'Applicative' instance for @Validation@ /accumulates/ errors using a 'Semigroup' on @err@. 77 | -- In contrast, the @Applicative@ for @Either@ returns only the first error. 78 | -- 79 | -- A consequence of this is that @Validation@ has no 'Data.Functor.Bind.Bind' or 'Control.Monad.Monad' instance. This is because 80 | -- such an instance would violate the law that a Monad's 'Control.Monad.ap' must equal the 81 | -- @Applicative@'s 'Control.Applicative.<*>' 82 | -- 83 | -- An example of typical usage can be found . 84 | -- 85 | data Validation err a = 86 | Failure err 87 | | Success a 88 | deriving (Data, Eq, Generic, Ord, Show, Typeable) 89 | 90 | instance Functor (Validation err) where 91 | fmap _ (Failure e) = 92 | Failure e 93 | fmap f (Success a) = 94 | Success (f a) 95 | {-# INLINE fmap #-} 96 | 97 | instance Semigroup err => Apply (Validation err) where 98 | Failure e1 <.> b = Failure $ case b of 99 | Failure e2 -> e1 <> e2 100 | Success _ -> e1 101 | Success _ <.> Failure e2 = 102 | Failure e2 103 | Success f <.> Success a = 104 | Success (f a) 105 | {-# INLINE (<.>) #-} 106 | 107 | instance Semigroup err => Applicative (Validation err) where 108 | pure = 109 | Success 110 | (<*>) = 111 | (<.>) 112 | 113 | -- | For two errors, this instance reports only the last of them. 114 | instance Alt (Validation err) where 115 | Failure _ x = 116 | x 117 | Success a _ = 118 | Success a 119 | {-# INLINE () #-} 120 | 121 | instance Foldable (Validation err) where 122 | foldr f x (Success a) = 123 | f a x 124 | foldr _ x (Failure _) = 125 | x 126 | {-# INLINE foldr #-} 127 | 128 | instance Traversable (Validation err) where 129 | traverse f (Success a) = 130 | Success <$> f a 131 | traverse _ (Failure e) = 132 | pure (Failure e) 133 | {-# INLINE traverse #-} 134 | 135 | instance Bifunctor Validation where 136 | bimap f _ (Failure e) = 137 | Failure (f e) 138 | bimap _ g (Success a) = 139 | Success (g a) 140 | {-# INLINE bimap #-} 141 | 142 | 143 | instance Bifoldable Validation where 144 | bifoldr _ g x (Success a) = 145 | g a x 146 | bifoldr f _ x (Failure e) = 147 | f e x 148 | {-# INLINE bifoldr #-} 149 | 150 | instance Bitraversable Validation where 151 | bitraverse _ g (Success a) = 152 | Success <$> g a 153 | bitraverse f _ (Failure e) = 154 | Failure <$> f e 155 | {-# INLINE bitraverse #-} 156 | 157 | appValidation :: 158 | (err -> err -> err) 159 | -> Validation err a 160 | -> Validation err a 161 | -> Validation err a 162 | appValidation m (Failure e1) (Failure e2) = 163 | Failure (e1 `m` e2) 164 | appValidation _ (Failure _) (Success a2) = 165 | Success a2 166 | appValidation _ (Success a1) (Failure _) = 167 | Success a1 168 | appValidation _ (Success a1) (Success _) = 169 | Success a1 170 | {-# INLINE appValidation #-} 171 | 172 | instance Semigroup e => Semigroup (Validation e a) where 173 | (<>) = 174 | appValidation (<>) 175 | {-# INLINE (<>) #-} 176 | 177 | instance Monoid e => Monoid (Validation e a) where 178 | mempty = 179 | Failure mempty 180 | {-# INLINE mempty #-} 181 | 182 | #if !MIN_VERSION_lens(4,20,0) 183 | instance Swapped Validation where 184 | swapped = iso swap swap 185 | {-# INLINE swapped #-} 186 | #endif 187 | 188 | instance Swap Validation where 189 | swap v = 190 | case v of 191 | Failure e -> Success e 192 | Success a -> Failure a 193 | {-# INLINE swap #-} 194 | 195 | instance (NFData e, NFData a) => NFData (Validation e a) where 196 | rnf v = 197 | case v of 198 | Failure e -> rnf e 199 | Success a -> rnf a 200 | 201 | -- | 'validate's an @a@ producing an updated optional value, returning 202 | -- @e@ in the empty case. 203 | -- 204 | -- This can be thought of as having the less general type: 205 | -- 206 | -- @ 207 | -- validate :: e -> (a -> Maybe b) -> a -> Validation e b 208 | -- @ 209 | validate :: Validate v => e -> (a -> Maybe b) -> a -> v e b 210 | validate e p a = case p a of 211 | Nothing -> _Failure # e 212 | Just b -> _Success # b 213 | 214 | -- | 'validationNel' is 'liftError' specialised to 'NonEmpty' lists, since 215 | -- they are a common semigroup to use. 216 | validationNel :: Either e a -> Validation (NonEmpty e) a 217 | validationNel = liftError pure 218 | 219 | -- | Converts from 'Either' to 'Validation'. 220 | fromEither :: Either e a -> Validation e a 221 | fromEither = liftError id 222 | 223 | -- | 'liftError' is useful for converting an 'Either' to an 'Validation' 224 | -- when the @Left@ of the 'Either' needs to be lifted into a 'Semigroup'. 225 | liftError :: (b -> e) -> Either b a -> Validation e a 226 | liftError f = either (Failure . f) Success 227 | 228 | -- | 'validation' is the catamorphism for @Validation@. 229 | validation :: (e -> c) -> (a -> c) -> Validation e a -> c 230 | validation ec ac = \case 231 | Failure e -> ec e 232 | Success a -> ac a 233 | 234 | -- | Converts from 'Validation' to 'Either'. 235 | toEither :: Validation e a -> Either e a 236 | toEither = validation Left Right 237 | 238 | -- | @v 'orElse' a@ returns @a@ when @v@ is Failure, and the @a@ in @Success a@. 239 | -- 240 | -- This can be thought of as having the less general type: 241 | -- 242 | -- @ 243 | -- orElse :: Validation e a -> a -> a 244 | -- @ 245 | orElse :: Validate v => v e a -> a -> a 246 | orElse v a = case v ^. _Validation of 247 | Failure _ -> a 248 | Success x -> x 249 | 250 | -- | Return the @a@ or run the given function over the @e@. 251 | -- 252 | -- This can be thought of as having the less general type: 253 | -- 254 | -- @ 255 | -- valueOr :: (e -> a) -> Validation e a -> a 256 | -- @ 257 | valueOr :: Validate v => (e -> a) -> v e a -> a 258 | valueOr ea v = case v ^. _Validation of 259 | Failure e -> ea e 260 | Success a -> a 261 | 262 | -- | 'codiagonal' gets the value out of either side. 263 | codiagonal :: Validation a a -> a 264 | codiagonal = valueOr id 265 | 266 | -- | 'ensure' ensures that a validation remains unchanged upon failure, 267 | -- updating a successful validation with an optional value that could fail 268 | -- with @e@ otherwise. 269 | -- 270 | -- This can be thought of as having the less general type: 271 | -- 272 | -- @ 273 | -- ensure :: e -> (a -> Maybe b) -> Validation e a -> Validation e b 274 | -- @ 275 | ensure :: Validate v => e -> (a -> Maybe b) -> v e a -> v e b 276 | ensure e p = 277 | over _Validation $ \case 278 | Failure x -> Failure x 279 | Success a -> validate e p a 280 | 281 | -- | Run a function on anything with a Validate instance (usually Either) 282 | -- as if it were a function on Validation 283 | -- 284 | -- This can be thought of as having the type 285 | -- 286 | -- @(Either e a -> Either e' a') -> Validation e a -> Validation e' a'@ 287 | validationed :: Validate v => (v e a -> v e' a') -> Validation e a -> Validation e' a' 288 | validationed = under _Validation 289 | 290 | -- | @bindValidation@ binds through a Validation, which is useful for 291 | -- composing Validations sequentially. Note that despite having a bind 292 | -- function of the correct type, Validation is not a monad. 293 | -- The reason is, this bind does not accumulate errors, so it does not 294 | -- agree with the Applicative instance. 295 | -- 296 | -- There is nothing wrong with using this function, it just does not make a 297 | -- valid @Monad@ instance. 298 | bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b 299 | bindValidation v f = case v of 300 | Failure e -> Failure e 301 | Success a -> f a 302 | 303 | -- | The @Validate@ class carries around witnesses that the type @f@ is isomorphic 304 | -- to Validation, and hence isomorphic to Either. 305 | class Validate f where 306 | _Validation :: 307 | Iso (f e a) (f g b) (Validation e a) (Validation g b) 308 | 309 | _Either :: 310 | Iso (f e a) (f g b) (Either e a) (Either g b) 311 | _Either = _Validation . iso toEither fromEither 312 | {-# INLINE _Either #-} 313 | 314 | instance Validate Validation where 315 | _Validation = 316 | id 317 | {-# INLINE _Validation #-} 318 | 319 | instance Validate Either where 320 | _Validation = 321 | iso 322 | fromEither 323 | toEither 324 | {-# INLINE _Validation #-} 325 | _Either = 326 | id 327 | {-# INLINE _Either #-} 328 | 329 | -- | This prism generalises 'Control.Lens.Prism._Left'. It targets the failure case of either 'Either' or 'Validation'. 330 | _Failure :: 331 | Validate f => 332 | Prism (f e1 a) (f e2 a) e1 e2 333 | _Failure = _Either . _Left 334 | {-# INLINE _Failure #-} 335 | 336 | -- | This prism generalises 'Control.Lens.Prism._Right'. It targets the success case of either 'Either' or 'Validation'. 337 | _Success :: 338 | Validate f => 339 | Prism (f e a) (f e b) a b 340 | _Success = _Either . _Right 341 | {-# INLINE _Success #-} 342 | 343 | -- | 'revalidate' converts between any two instances of 'Validate'. 344 | revalidate :: (Validate f, Validate g) => Iso (f e1 s) (f e2 t) (g e1 s) (g e2 t) 345 | revalidate = _Validation . from _Validation 346 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | # cabal 2 | /dist 3 | 4 | # cabal-dev 5 | /cabal-dev 6 | 7 | # Haskell Program Coverage 8 | /.hpc 9 | -------------------------------------------------------------------------------- /test/hedgehog_tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Applicative (liftA3) 4 | import Control.Monad (join, unless) 5 | import Hedgehog 6 | import qualified Hedgehog.Gen as Gen 7 | import qualified Hedgehog.Range as Range 8 | import System.IO (BufferMode(..), hSetBuffering, stdout, stderr) 9 | import System.Exit (exitFailure) 10 | 11 | import Data.Validation (Validation (Success, Failure)) 12 | 13 | main :: IO () 14 | main = do 15 | hSetBuffering stdout LineBuffering 16 | hSetBuffering stderr LineBuffering 17 | 18 | result <- checkParallel $ Group "Validation" 19 | [ ("prop_semigroup", prop_semigroup) 20 | , ("prop_monoid_assoc", prop_monoid_assoc) 21 | , ("prop_monoid_left_id", prop_monoid_left_id) 22 | , ("prop_monoid_right_id", prop_monoid_right_id) 23 | ] 24 | 25 | unless result $ 26 | exitFailure 27 | 28 | genValidation :: Gen e -> Gen a -> Gen (Validation e a) 29 | genValidation e a = Gen.choice [fmap Failure e, fmap Success a] 30 | 31 | testGen :: Gen (Validation [String] Int) 32 | testGen = 33 | let range = Range.linear 1 50 34 | string = Gen.string range Gen.unicode 35 | strings = Gen.list range string 36 | in genValidation strings Gen.enumBounded 37 | 38 | mkAssoc :: (Validation [String] Int -> Validation [String] Int -> Validation [String] Int) -> Property 39 | mkAssoc f = 40 | let g = forAll testGen 41 | assoc = \x y z -> ((x `f` y) `f` z) === (x `f` (y `f` z)) 42 | in property $ join (liftA3 assoc g g g) 43 | 44 | prop_semigroup :: Property 45 | prop_semigroup = mkAssoc (<>) 46 | 47 | prop_monoid_assoc :: Property 48 | prop_monoid_assoc = mkAssoc mappend 49 | 50 | prop_monoid_left_id :: Property 51 | prop_monoid_left_id = 52 | property $ do 53 | x <- forAll testGen 54 | (mempty `mappend` x) === x 55 | 56 | prop_monoid_right_id :: Property 57 | prop_monoid_right_id = 58 | property $ do 59 | x <- forAll testGen 60 | (x `mappend` mempty) === x 61 | 62 | -------------------------------------------------------------------------------- /test/hunit_tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main (main) where 4 | 5 | import Test.HUnit 6 | 7 | import Prelude hiding (length) 8 | import Control.Lens ((#)) 9 | import Control.Monad (when) 10 | import Data.Foldable (length) 11 | import Data.Proxy (Proxy (Proxy)) 12 | import Data.Validation (Validation (Success, Failure), Validate, _Failure, _Success, ensure, 13 | orElse, validate, validation, validationNel) 14 | import System.Exit (exitFailure) 15 | 16 | seven :: Int 17 | seven = 7 18 | 19 | three :: Int 20 | three = 3 21 | 22 | four :: Int 23 | four = 4 24 | 25 | testYY :: Test 26 | testYY = 27 | let subject = _Success # (+1) <*> _Success # seven :: Validation String Int 28 | expected = Success 8 29 | in TestCase (assertEqual "Success <*> Success" subject expected) 30 | 31 | testNY :: Test 32 | testNY = 33 | let subject = _Failure # ["f1"] <*> _Success # seven :: Validation [String] Int 34 | expected = Failure ["f1"] 35 | in TestCase (assertEqual "Failure <*> Success" subject expected) 36 | 37 | testYN :: Test 38 | testYN = 39 | let subject = _Success # (+1) <*> _Failure # ["f2"] :: Validation [String] Int 40 | expected = Failure ["f2"] 41 | in TestCase (assertEqual "Success <*> Failure" subject expected) 42 | 43 | testNN :: Test 44 | testNN = 45 | let subject = _Failure # ["f1"] <*> _Failure # ["f2"] :: Validation [String] Int 46 | expected = Failure ["f1","f2"] 47 | in TestCase (assertEqual "Failure <*> Failure" subject expected) 48 | 49 | testValidationNel :: Test 50 | testValidationNel = 51 | let subject = validation length (const 0) $ validationNel (Left ()) 52 | in TestCase (assertEqual "validationNel makes lists of length 1" subject 1) 53 | 54 | testEnsureLeftNothing, testEnsureLeftJust, testEnsureRightNothing, 55 | testEnsureRightJust, testEnsureRightJust', testOrElseRight, testOrElseLeft 56 | :: forall v. (Validate v, Eq (v Int Int), Show (v Int Int)) => Proxy v -> Test 57 | 58 | testEnsureLeftNothing _ = 59 | let subject :: v Int Int 60 | subject = ensure three (const Nothing) (_Failure # seven) 61 | in TestCase (assertEqual "ensure Left False" subject (_Failure # seven)) 62 | 63 | testEnsureLeftJust _ = 64 | let subject :: v Int Int 65 | subject = ensure three (Just . id) (_Failure # seven) 66 | in TestCase (assertEqual "ensure Left True" subject (_Failure # seven)) 67 | 68 | testEnsureRightNothing _ = 69 | let subject :: v Int Int 70 | subject = ensure three (const Nothing) (_Success # seven) 71 | in TestCase (assertEqual "ensure Right False" subject (_Failure # three)) 72 | 73 | testEnsureRightJust _ = 74 | let subject :: v Int Int 75 | subject = ensure three (Just . id) (_Success # seven) 76 | in TestCase (assertEqual "ensure Right True" subject (_Success # seven)) 77 | 78 | testEnsureRightJust' _ = 79 | let subject :: v Int Int 80 | subject = ensure three (const $ Just four) (_Success # seven) 81 | in TestCase (assertEqual "ensure Right True" subject (_Success # four)) 82 | 83 | testOrElseRight _ = 84 | let v :: v Int Int 85 | v = _Success # seven 86 | subject = v `orElse` three 87 | in TestCase (assertEqual "orElseRight" subject seven) 88 | 89 | testOrElseLeft _ = 90 | let v :: v Int Int 91 | v = _Failure # seven 92 | subject = v `orElse` three 93 | in TestCase (assertEqual "orElseLeft" subject three) 94 | 95 | testValidateJust :: Test 96 | testValidateJust = 97 | let subject = validate three (Just . id) seven 98 | expected = Success seven 99 | in TestCase (assertEqual "testValidateTrue" subject expected) 100 | 101 | testValidateJust' :: Test 102 | testValidateJust' = 103 | let subject = validate three (const $ Just four) seven 104 | expected = Success four 105 | in TestCase (assertEqual "testValidateTrue" subject expected) 106 | 107 | testValidateNothing :: Test 108 | testValidateNothing = 109 | let subject = validate three (const option) seven 110 | expected = Failure three 111 | option = Nothing :: Maybe Int 112 | in TestCase (assertEqual "testValidateFalse" subject expected) 113 | 114 | tests :: Test 115 | tests = 116 | let eitherP :: Proxy Either 117 | eitherP = Proxy 118 | validationP :: Proxy Validation 119 | validationP = Proxy 120 | generals :: forall v. (Validate v, Eq (v Int Int), Show (v Int Int)) => [Proxy v -> Test] 121 | generals = 122 | [ testEnsureLeftNothing 123 | , testEnsureLeftJust 124 | , testEnsureRightNothing 125 | , testEnsureRightJust 126 | , testEnsureRightJust' 127 | , testOrElseLeft 128 | , testOrElseRight 129 | ] 130 | eithers = fmap ($ eitherP) generals 131 | validations = fmap ($ validationP) generals 132 | in TestList $ [ 133 | testYY 134 | , testYN 135 | , testNY 136 | , testNN 137 | , testValidationNel 138 | , testValidateNothing 139 | , testValidateJust 140 | , testValidateJust' 141 | ] ++ eithers ++ validations 142 | where 143 | 144 | main :: IO () 145 | main = do 146 | c <- runTestTT tests 147 | when (errors c > 0 || failures c > 0) exitFailure 148 | -------------------------------------------------------------------------------- /validation.cabal: -------------------------------------------------------------------------------- 1 | name: validation 2 | version: 1.1.3 3 | license: BSD3 4 | license-file: LICENCE 5 | author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge 6 | maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge , Queensland Functional Programming Lab 7 | copyright: Copyright (C) 2010-2013 Tony Morris, Nick Partridge 8 | Copyright (C) 2014,2015 NICTA Limited 9 | Copyright (c) 2016-2019, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. 10 | synopsis: A data-type like Either but with an accumulating Applicative 11 | category: Data 12 | description: 13 | <> 14 | . 15 | A data-type like Either but with differing properties and type-class 16 | instances. 17 | . 18 | Library support is provided for this different representation, include 19 | `lens`-related functions for converting between each and abstracting over their 20 | similarities. 21 | . 22 | * `Validation` 23 | . 24 | The `Validation` data type is isomorphic to `Either`, but has an instance 25 | of `Applicative` that accumulates on the error side. That is to say, if two 26 | (or more) errors are encountered, they are appended using a `Semigroup` 27 | operation. 28 | . 29 | As a consequence of this `Applicative` instance, there is no corresponding 30 | `Bind` or `Monad` instance. `Validation` is an example of, "An applicative 31 | functor that is not a monad." 32 | 33 | homepage: https://github.com/qfpl/validation 34 | bug-reports: https://github.com/qfpl/validation/issues 35 | cabal-version: >= 1.10 36 | build-type: Simple 37 | extra-source-files: changelog 38 | tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4 39 | 40 | source-repository head 41 | type: git 42 | location: git@github.com:qfpl/validation.git 43 | 44 | library 45 | default-language: 46 | Haskell2010 47 | 48 | build-depends: 49 | base >= 4.11 && < 5 50 | , assoc >= 1 && < 2 51 | , deepseq >= 1.4.3 && < 1.5 52 | , semigroups >= 0.18.2 && < 1 53 | , semigroupoids >= 5.2.2 && < 7 54 | , bifunctors >= 5.5 && < 6 55 | , lens >= 4.0.5 && < 6 56 | 57 | ghc-options: 58 | -Wall 59 | 60 | hs-source-dirs: 61 | src 62 | 63 | exposed-modules: 64 | Data.Validation 65 | 66 | test-suite hedgehog 67 | type: 68 | exitcode-stdio-1.0 69 | 70 | main-is: 71 | hedgehog_tests.hs 72 | 73 | default-language: 74 | Haskell2010 75 | 76 | build-depends: 77 | base >= 4.11 && < 5 78 | , hedgehog >= 0.5 && < 2 79 | , semigroups >= 0.18.2 && < 1 80 | , validation 81 | 82 | ghc-options: 83 | -Wall 84 | -threaded 85 | 86 | hs-source-dirs: 87 | test 88 | 89 | test-suite hunit 90 | type: 91 | exitcode-stdio-1.0 92 | 93 | main-is: 94 | hunit_tests.hs 95 | 96 | default-language: 97 | Haskell2010 98 | 99 | build-depends: 100 | base >= 4.11 && < 5 101 | , HUnit >= 1.6 && < 1.7 102 | , lens >= 4.0.5 && < 6 103 | , semigroups >= 0.18.2 && < 1 104 | , validation 105 | 106 | ghc-options: 107 | -Wall 108 | -threaded 109 | 110 | hs-source-dirs: 111 | test 112 | -------------------------------------------------------------------------------- /validation.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bifunctors, deepseq, hedgehog, HUnit, lens 2 | , semigroupoids, semigroups, stdenv 3 | }: 4 | mkDerivation { 5 | pname = "validation"; 6 | version = "1"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | base bifunctors deepseq lens semigroupoids semigroups 10 | ]; 11 | testHaskellDepends = [ base hedgehog HUnit lens semigroups ]; 12 | homepage = "https://github.com/qfpl/validation"; 13 | description = "A data-type like Either but with an accumulating Applicative"; 14 | license = stdenv.lib.licenses.bsd3; 15 | } 16 | --------------------------------------------------------------------------------