├── .gitignore ├── .hlint.yaml ├── .travis.yml ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── Setup.lhs ├── Warning.hs ├── cabal.project ├── perhaps.cabal ├── src ├── Control │ └── Monad │ │ └── Perhaps.hs └── Data │ └── Perhaps.hs └── tests └── doctests.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | docs 4 | wiki 5 | TAGS 6 | tags 7 | wip 8 | .DS_Store 9 | .*.swp 10 | .*.swo 11 | *.o 12 | *.hi 13 | *~ 14 | *# 15 | *.imports 16 | .stack-work/ 17 | cabal-dev 18 | *.chi 19 | *.chs.h 20 | *.dyn_o 21 | *.dyn_hi 22 | .hpc 23 | .hsenv 24 | .cabal-sandbox/ 25 | cabal.sandbox.config 26 | *.prof 27 | *.aux 28 | *.hp 29 | *.eventlog 30 | cabal.project.local 31 | cabal.project.local~ 32 | .HTF/ 33 | .ghc.environment.* 34 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: 2 | name: Use camelCase 3 | 4 | - ignore: 5 | name: Use lambda-case 6 | 7 | - ignore: 8 | name: Use fmap 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | notifications: 14 | irc: 15 | channels: 16 | - "irc.freenode.org#haskell-lens" 17 | skip_join: true 18 | template: 19 | - "\x0313perhaps\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" 20 | 21 | cache: 22 | directories: 23 | - $HOME/.cabal/packages 24 | - $HOME/.cabal/store 25 | 26 | before_cache: 27 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 28 | # remove files that are regenerated by 'cabal update' 29 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 30 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 31 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 32 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 33 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 34 | 35 | - rm -rfv $HOME/.cabal/packages/head.hackage 36 | 37 | addons: 38 | apt: 39 | packages: &apt_packages 40 | - ghc-ppa-tools 41 | 42 | matrix: 43 | include: 44 | - compiler: "ghc-7.0.4" 45 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 46 | addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}} 47 | - compiler: "ghc-7.2.2" 48 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 49 | addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}} 50 | - compiler: "ghc-7.4.2" 51 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 52 | addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}} 53 | - compiler: "ghc-7.6.3" 54 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 55 | addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}} 56 | - compiler: "ghc-7.8.4" 57 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 58 | addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}} 59 | - compiler: "ghc-7.10.3" 60 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 61 | addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}} 62 | - compiler: "ghc-8.0.2" 63 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 64 | addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}} 65 | - compiler: "ghc-8.2.2" 66 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 67 | addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} 68 | - compiler: "ghc-8.4.2" 69 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 70 | addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.4.2], sources: [hvr-ghc]}} 71 | - compiler: "ghc-head" 72 | env: GHCHEAD=true 73 | addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}} 74 | 75 | allow_failures: 76 | - compiler: "ghc-7.0.4" 77 | - compiler: "ghc-head" 78 | 79 | before_install: 80 | - HC=${CC} 81 | - HCPKG=${HC/ghc/ghc-pkg} 82 | - unset CC 83 | - export HLINTVER=2.1.3 84 | - mkdir ~/.hlint 85 | - curl -L https://github.com/ndmitchell/hlint/releases/download/v$HLINTVER/hlint-$HLINTVER-x86_64-linux.tar.gz | tar -xz --strip-components=1 -C ~/.hlint 86 | - ROOTDIR=$(pwd) 87 | - mkdir -p $HOME/.local/bin 88 | - "PATH=~/.hlint:/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 89 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 90 | - echo $HCNUMVER 91 | 92 | install: 93 | - cabal --version 94 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 95 | - BENCH=${BENCH---enable-benchmarks} 96 | - TEST=${TEST---enable-tests} 97 | - HADDOCK=${HADDOCK-true} 98 | - INSTALLED=${INSTALLED-true} 99 | - GHCHEAD=${GHCHEAD-false} 100 | - travis_retry cabal update -v 101 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 102 | - rm -fv cabal.project cabal.project.local 103 | # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage 104 | - | 105 | if $GHCHEAD; then 106 | sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config 107 | 108 | echo 'repository head.hackage' >> ${HOME}/.cabal/config 109 | echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config 110 | echo ' secure: True' >> ${HOME}/.cabal/config 111 | echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config 112 | echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config 113 | echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config 114 | echo ' key-threshold: 3' >> ${HOME}/.cabal.config 115 | 116 | cabal new-update head.hackage -v 117 | fi 118 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 119 | - "printf 'packages: \".\"\\n' > cabal.project" 120 | - cat cabal.project 121 | - if [ -f "./configure.ac" ]; then 122 | (cd "." && autoreconf -i); 123 | fi 124 | - rm -f cabal.project.freeze 125 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 126 | - rm -rf "."/.ghc.environment.* "."/dist 127 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 128 | 129 | # Here starts the actual work to be performed for the package under test; 130 | # any command which exits with a non-zero exit code causes the build to fail. 131 | script: 132 | # test that source-distributions can be generated 133 | - (cd "." && cabal sdist) 134 | - mv "."/dist/perhaps-*.tar.gz ${DISTDIR}/ 135 | - cd ${DISTDIR} || false 136 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 137 | - "printf 'packages: perhaps-*/*.cabal\\n' > cabal.project" 138 | - cat cabal.project 139 | 140 | 141 | # build & run tests, build benchmarks 142 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 143 | 144 | # cabal check 145 | - (cd perhaps-* && cabal check) 146 | 147 | # haddock 148 | - rm -rf ./dist-newstyle 149 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 150 | 151 | # hlint 152 | - hlint --version 153 | - (cd perhaps-* && hlint src) 154 | 155 | # REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"] 156 | # EOF 157 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0 2 | 3 | * Repository initialized 4 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # License 2 | 3 | - Copyright 2018 Edward Kmett 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 | 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | 2. Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 19 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 22 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 26 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 27 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 28 | POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # perhaps 2 | 3 | [![Build Status](https://secure.travis-ci.org/ekmett/perhaps.png?branch=master)](http://travis-ci.org/ekmett/perhaps) 4 | 5 | License 6 | ======= 7 | 8 | [BSD-2-Clause](https://opensource.org/licenses/BSD-2-Clause). 9 | 10 | See [LICENSE.md](LICENSE.md) 11 | 12 | Contact Information 13 | =================== 14 | 15 | Contributions and bug reports are welcome! 16 | 17 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 18 | 19 | -Edward Kmett 20 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | {-# LANGUAGE CPP #-} 3 | {-# OPTIONS_GHC -Wall #-} 4 | module Main (main) where 5 | 6 | #ifndef MIN_VERSION_cabal_doctest 7 | #define MIN_VERSION_cabal_doctest(x,y,z) 0 8 | #endif 9 | 10 | #if MIN_VERSION_cabal_doctest(1,0,0) 11 | 12 | import Distribution.Extra.Doctest ( defaultMainWithDoctests ) 13 | main :: IO () 14 | main = defaultMainWithDoctests "doctests" 15 | 16 | #else 17 | 18 | #ifdef MIN_VERSION_Cabal 19 | -- If the macro is defined, we have new cabal-install, 20 | -- but for some reason we don't have cabal-doctest in package-db 21 | -- 22 | -- Probably we are running cabal sdist, when otherwise using new-build 23 | -- workflow 24 | import Warning () 25 | #endif 26 | 27 | import Distribution.Simple 28 | 29 | main :: IO () 30 | main = defaultMain 31 | 32 | #endif 33 | 34 | \end{code} 35 | -------------------------------------------------------------------------------- /Warning.hs: -------------------------------------------------------------------------------- 1 | module Warning 2 | {-# WARNING ["You are configuring this package without cabal-doctest installed.", 3 | "The doctests test-suite will not work as a result.", 4 | "To fix this, install cabal-doctest before configuring."] #-} 5 | () where 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /perhaps.cabal: -------------------------------------------------------------------------------- 1 | name: perhaps 2 | category: Data 3 | version: 0.1 4 | license: BSD2 5 | cabal-version: 1.12 6 | license-file: LICENSE.md 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/perhaps/ 11 | bug-reports: http://github.com/ekmett/perhaps/issues 12 | copyright: Copyright (C) 2018 Edward A. Kmett 13 | build-type: Custom 14 | synopsis: Perhaps, a monad 15 | description: Perhaps, a monad. 16 | tested-with: GHC == 7.0.4 17 | , GHC == 7.2.2 18 | , GHC == 7.4.2 19 | , GHC == 7.6.3 20 | , GHC == 7.8.4 21 | , GHC == 7.10.3 22 | , GHC == 8.0.2 23 | , GHC == 8.2.2 24 | , GHC == 8.4.2 25 | 26 | extra-source-files: 27 | .hlint.yaml 28 | CHANGELOG.md 29 | README.md 30 | 31 | custom-setup 32 | setup-depends: 33 | base >= 4 && <5, 34 | Cabal >= 1.10 && < 2.5, 35 | cabal-doctest >= 1 && <1.17 36 | 37 | source-repository head 38 | type: git 39 | location: git://github.com/ekmett/perhaps.git 40 | 41 | library 42 | default-language: Haskell2010 43 | ghc-options: -Wall 44 | hs-source-dirs: src 45 | 46 | build-depends: 47 | base >= 4.3 && < 5, 48 | mtl >= 2.1 && < 2.3, 49 | transformers >= 0.3 && < 0.6, 50 | transformers-compat >= 0.3 && < 1 51 | 52 | if impl(ghc >= 7.2) && impl(ghc < 7.6) 53 | build-depends: generic-deriving >= 0.3.1 && < 1.13 54 | 55 | if impl(ghc < 7.10) 56 | build-depends: void >= 0.5.0 && < 1 57 | 58 | if impl(ghc < 8.0) 59 | build-depends: semigroups >= 0.10 && < 1 60 | 61 | exposed-modules: 62 | Control.Monad.Perhaps 63 | Data.Perhaps 64 | 65 | -- Verify the results of the examples 66 | test-suite doctests 67 | type: exitcode-stdio-1.0 68 | main-is: doctests.hs 69 | default-language: Haskell2010 70 | build-depends: 71 | base, 72 | perhaps, 73 | doctest >= 0.11.1 && <0.17 74 | ghc-options: -Wall -threaded 75 | hs-source-dirs: tests 76 | -------------------------------------------------------------------------------- /src/Control/Monad/Perhaps.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 702 3 | {-# language DefaultSignatures #-} 4 | #endif 5 | {-# language DeriveFoldable #-} 6 | {-# language DeriveFunctor #-} 7 | {-# language DeriveTraversable #-} 8 | {-# language DeriveDataTypeable #-} 9 | #if __GLASGOW_HASKELL__ >= 702 10 | {-# language DeriveGeneric #-} 11 | #endif 12 | {-# language FlexibleInstances #-} 13 | {-# language MultiParamTypeClasses #-} 14 | #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 15 | {-# language Trustworthy #-} 16 | #elif __GLASGOW_HASKELL__ >= 708 17 | {-# language Safe #-} 18 | #endif 19 | {-# language StandaloneDeriving #-} 20 | {-# language TypeFamilies #-} 21 | {-# language UndecidableInstances #-} 22 | 23 | ----------------------------------------------------------------------------- 24 | -- | 25 | -- Copyright : (c) Edward Kmett 2018 26 | -- License : BSD3 27 | -- Maintainer : ekmett@gmail.com 28 | -- Stability : stable 29 | -- Portability : portable 30 | -- 31 | ----------------------------------------------------------------------------- 32 | 33 | module Control.Monad.Perhaps 34 | ( 35 | -- * Maybe with an undisclosed error 36 | Perhaps(..) 37 | , believe 38 | , mayhap 39 | -- * Transformer 40 | , PerhapsT(..) 41 | -- * Class 42 | , MonadPerhaps(..) 43 | -- * Combinators 44 | , mapPerhapsT 45 | , liftCallCC 46 | , liftCatch 47 | , liftListen 48 | , liftPass 49 | ) where 50 | 51 | import Control.Applicative 52 | import Control.Exception (Exception(..), throw) 53 | import Control.Monad as Monad 54 | import Control.Monad.Trans 55 | import Control.Monad.Cont.Class 56 | #if MIN_VERSION_base(4,9,0) 57 | import Control.Monad.Fail as MonadFail 58 | import Data.Functor.Classes 59 | #endif 60 | import Control.Monad.RWS.Class 61 | import qualified Control.Monad.RWS.Lazy as Lazy 62 | import qualified Control.Monad.RWS.Strict as Strict 63 | import Control.Monad.Reader 64 | import Control.Monad.Signatures 65 | import qualified Control.Monad.State.Lazy as Lazy 66 | import qualified Control.Monad.State.Strict as Strict 67 | import Control.Monad.Trans.Identity (IdentityT(..)) 68 | import qualified Control.Monad.Writer.Lazy as Lazy 69 | import qualified Control.Monad.Writer.Strict as Strict 70 | #if __GLASGOW_HASKELL__ >= 702 71 | import Control.Monad.Zip (MonadZip(munzip, mzipWith)) 72 | #endif 73 | import Data.Data 74 | #if __GLASGOW_HASKELL__ < 710 75 | import Data.Foldable 76 | import Data.Traversable 77 | #endif 78 | #if __GLASGOW_HASKELL__ < 804 79 | import Data.Semigroup 80 | #endif 81 | import Data.Void 82 | #ifdef MIN_VERSION_generic_deriving 83 | import Generics.Deriving 84 | #endif 85 | #if __GLASGOW_HASKELL__ >= 706 86 | import GHC.Generics 87 | #endif 88 | 89 | -------------------------------------------------------------------------------- 90 | -- * Perhaps 91 | -------------------------------------------------------------------------------- 92 | 93 | -- | This monad occupies the middle ground between 'Maybe' and 'Either' 94 | -- in that you can get out an informative error but aren't able to care 95 | -- about its contents, except via bottoms. 96 | -- 97 | -- Since bottoms are indistinguishable in pure code, one can view this 98 | -- as morally the same as 'Maybe', except when things go wrong, you can 99 | -- pass along a complaint, rather than take what you'd get from 100 | -- 'Data.Maybe.fromJust'. 101 | -- 102 | -- >>> import Control.Exception 103 | -- >>> let x = excuse Overflow :: Perhaps () 104 | -- 105 | -- Attempting to 'Show' a 'Perhaps' value is hazardous, as it will contain an embedded exception. 106 | -- 107 | -- >>> x 108 | -- Can't *** Exception: arithmetic overflow 109 | -- 110 | -- Recovery is possible as 'Can't' isn't strict in its argument. 111 | -- 112 | -- >>> x <|> Can () 113 | -- Can () 114 | -- 115 | -- >>> x `seq` () 116 | -- () 117 | 118 | data Perhaps a 119 | = Can a 120 | | Can't Void 121 | deriving ( 122 | #if __GLASGOW_HASKELL__ >= 702 123 | Generic, 124 | #endif 125 | #if __GLASGOW_HASKELL__ >= 706 126 | Generic1, 127 | #endif 128 | Typeable, Data, Eq, Ord, Read, Show, Functor, Foldable, Traversable 129 | ) 130 | 131 | #if MIN_VERSION_base(4,9,0) 132 | 133 | instance Eq1 Perhaps where 134 | liftEq _ (Can't _) _ = False 135 | liftEq _ _ (Can't _) = False 136 | liftEq eq (Can a) (Can b) = eq a b 137 | 138 | instance Ord1 Perhaps where 139 | liftCompare _ (Can't _) (Can't _) = EQ 140 | liftCompare _ (Can't _) _ = LT 141 | liftCompare _ _ (Can't _) = GT 142 | liftCompare comp (Can a) (Can b) = comp a b 143 | 144 | instance Show1 Perhaps where 145 | liftShowsPrec _ _ _ (Can't _) = error "Can't" 146 | liftShowsPrec sp _ d (Can a) = showsUnaryWith sp "Can" d a 147 | 148 | instance Read1 Perhaps where 149 | liftReadsPrec rp _ = readsData (readsUnaryWith rp "Can" Can) 150 | 151 | #endif 152 | 153 | instance Semigroup a => Semigroup (Perhaps a) where 154 | Can a <> Can b = Can (a <> b) 155 | Can't _ <> Can b = Can b 156 | Can a <> Can't _ = Can a 157 | Can't e <> Can't _ = Can't e 158 | {-# inlinable (<>) #-} 159 | 160 | instance Semigroup a => Monoid (Perhaps a) where 161 | mempty = empty 162 | {-# inlinable mempty #-} 163 | mappend = (<>) 164 | {-# inlinable mappend #-} 165 | 166 | instance Applicative Perhaps where 167 | pure = Can 168 | {-# inlinable pure #-} 169 | Can f <*> Can a = Can (f a) 170 | Can't e <*> _ = Can't e 171 | _ <*> Can't e = Can't e 172 | {-# inlinable (<*>) #-} 173 | 174 | instance Alternative Perhaps where 175 | empty = Can't (error "empty") 176 | {-# inlinable empty #-} 177 | a@Can{} <|> _ = a 178 | _ <|> a@Can{} = a 179 | e <|> _ = e 180 | {-# inlinable (<|>) #-} 181 | 182 | instance Monad Perhaps where 183 | return = pure 184 | {-# inlinable return #-} 185 | 186 | Can a >>= f = f a 187 | Can't e >>= _ = Can't e 188 | {-# inlinable (>>=) #-} 189 | 190 | #if MIN_VERSION_base(4,9,0) 191 | fail = MonadFail.fail 192 | {-# inlinable fail #-} 193 | 194 | instance MonadFail Perhaps where 195 | #endif 196 | fail e = Can't (error e) 197 | {-# inlinable fail #-} 198 | 199 | instance MonadPlus Perhaps where 200 | mplus = (<|>) 201 | {-# inlinable mplus #-} 202 | mzero = empty 203 | {-# inlinable mzero #-} 204 | 205 | instance MonadFix Perhaps where 206 | mfix f = a where a = f (believe a) 207 | {-# inlinable mfix #-} 208 | 209 | #if __GLASGOW_HASKELL__ >= 702 210 | instance MonadZip Perhaps where 211 | munzip (Can (a,b)) = (Can a, Can b) 212 | munzip (Can't e) = (Can't e, Can't e) 213 | {-# inlinable munzip #-} 214 | mzipWith f (Can a) (Can b) = Can (f a b) 215 | mzipWith _ (Can't e) _ = Can't e 216 | mzipWith _ _ (Can't e) = Can't e 217 | {-# inlinable mzipWith #-} 218 | #endif 219 | 220 | -- | This partial function can be used like 'fromJust', but throws the user 221 | -- error. 222 | believe :: Perhaps a -> a 223 | believe (Can a) = a 224 | believe (Can't e) = absurd e 225 | {-# inlinable believe #-} 226 | 227 | mayhap :: Perhaps a -> Maybe a 228 | mayhap (Can a) = Just a 229 | mayhap (Can't _) = Nothing 230 | {-# inlinable mayhap #-} 231 | 232 | -------------------------------------------------------------------------------- 233 | -- * PerhapsT 234 | -------------------------------------------------------------------------------- 235 | 236 | newtype PerhapsT m a = PerhapsT { runPerhapsT :: m (Perhaps a) } 237 | deriving ( 238 | #if __GLASGOW_HASKELL__ >= 702 239 | Generic, 240 | #endif 241 | #if __GLASGOW_HASKELL__ >= 706 242 | Generic1, 243 | #endif 244 | #if __GLASGOW_HASKELL__ >= 708 245 | Typeable, 246 | #endif 247 | #if __GLASGOW_HASKELL__ >= 710 248 | Functor, 249 | #endif 250 | Foldable, Traversable 251 | ) 252 | 253 | deriving instance Eq (m (Perhaps a)) => Eq (PerhapsT m a) 254 | deriving instance Ord (m (Perhaps a)) => Ord (PerhapsT m a) 255 | deriving instance Show (m (Perhaps a)) => Show (PerhapsT m a) 256 | deriving instance Read (m (Perhaps a)) => Read (PerhapsT m a) 257 | 258 | #if __GLASGOW_HASKELL__ < 708 259 | instance Typeable1 m => Typeable1 (PerhapsT m) where 260 | typeOf1 dma = mkTyConApp perhapsTTyCon [typeOf1 (m dma)] 261 | where 262 | m :: PerhapsT m a -> m a 263 | m = undefined 264 | 265 | instance (Typeable1 m, Typeable a) => Typeable (PerhapsT m a) where 266 | typeOf = typeOfDefault 267 | 268 | perhapsTTyCon :: TyCon 269 | #if MIN_VERSION_base(4,4,0) 270 | perhapsTTyCon = mkTyCon3 "perhaps" "Control.Monad.Perhaps" "PerhapsT" 271 | #else 272 | perhapsTTyCon = mkTyCon "Control.Monad.Perhaps.PerhapsT" 273 | #endif 274 | {-# NOINLINE perhapsTTyCon #-} 275 | #else 276 | #define Typeable1 Typeable 277 | #endif 278 | 279 | deriving instance (Data (m (Perhaps a)), Typeable1 m, Typeable a) => Data (PerhapsT m a) 280 | 281 | #if __GLASGOW_HASKELL__ < 710 282 | instance Monad m => Functor (PerhapsT m) where 283 | fmap f (PerhapsT ma) = PerhapsT $ liftM (fmap f) ma 284 | #endif 285 | 286 | instance Monad m => Applicative (PerhapsT m) where 287 | pure = PerhapsT . return . pure 288 | {-# inlinable pure #-} 289 | PerhapsT mf <*> PerhapsT ma = PerhapsT $ mf >>= \f0 -> case f0 of 290 | Can't e -> return $ Can't e 291 | #if __GLASGOW_HASKELL__ < 710 292 | Can f -> fmap f `liftM` ma 293 | #else 294 | Can f -> fmap f <$> ma 295 | #endif 296 | {-# inlinable (<*>) #-} 297 | 298 | instance Monad m => Alternative (PerhapsT m) where 299 | empty = PerhapsT (return empty) 300 | {-# inlinable empty #-} 301 | PerhapsT ma <|> PerhapsT mb = PerhapsT $ ma >>= \a0 -> case a0 of 302 | a@Can{} -> return a 303 | e@Can't{} -> mb >>= \b0 -> case b0 of 304 | b@Can{} -> return b 305 | Can't{} -> return e 306 | {-# inlinable (<|>) #-} 307 | 308 | instance Monad m => Monad (PerhapsT m) where 309 | return = pure 310 | {-# inlinable return #-} 311 | 312 | PerhapsT ma >>= f = PerhapsT $ ma >>= \a0 -> case a0 of 313 | Can a -> runPerhapsT (f a) 314 | Can't e -> return (Can't e) 315 | {-# inlinable (>>=) #-} 316 | 317 | #if MIN_VERSION_base(4,9,0) 318 | fail = MonadFail.fail 319 | {-# inlinable fail #-} 320 | 321 | instance Monad m => MonadFail (PerhapsT m) where 322 | fail = PerhapsT . return . MonadFail.fail 323 | #else 324 | fail = PerhapsT . return . Monad.fail 325 | #endif 326 | {-# inlinable fail #-} 327 | 328 | instance Monad m => MonadPlus (PerhapsT m) where 329 | mzero = empty 330 | {-# inlinable mzero #-} 331 | mplus = (<|>) 332 | {-# inlinable mplus #-} 333 | 334 | #if __GLASGOW_HASKELL__ >= 702 335 | instance MonadZip m => MonadZip (PerhapsT m) where 336 | mzipWith f (PerhapsT a) (PerhapsT b) = PerhapsT $ mzipWith (liftA2 f) a b 337 | {-# inlinable mzipWith #-} 338 | munzip m = (fmap fst m, fmap snd m) 339 | {-# inlinable munzip #-} 340 | #endif 341 | 342 | instance MonadFix m => MonadFix (PerhapsT m) where 343 | mfix f = PerhapsT $ mfix (runPerhapsT . f . believe) 344 | {-# inlinable mfix #-} 345 | 346 | instance MonadTrans PerhapsT where 347 | #if __GLASGOW_HASKELL__ < 710 348 | lift = PerhapsT . liftM Can 349 | #else 350 | lift = PerhapsT . fmap Can 351 | #endif 352 | {-# inlinable lift #-} 353 | 354 | instance MonadIO m => MonadIO (PerhapsT m) where 355 | liftIO = lift . liftIO 356 | {-# inlinable liftIO #-} 357 | 358 | instance MonadState s m => MonadState s (PerhapsT m) where 359 | get = lift get 360 | {-# inlinable get #-} 361 | put = lift . put 362 | {-# inlinable put #-} 363 | state = lift . state 364 | {-# inlinable state #-} 365 | 366 | instance MonadWriter w m => MonadWriter w (PerhapsT m) where 367 | tell = lift . tell 368 | {-# inlinable tell #-} 369 | writer = lift . writer 370 | {-# inlinable writer #-} 371 | listen = liftListen listen 372 | {-# inlinable listen #-} 373 | pass = liftPass pass 374 | {-# inlinable pass #-} 375 | 376 | instance MonadCont m => MonadCont (PerhapsT m) where 377 | callCC = liftCallCC callCC 378 | {-# inlinable callCC #-} 379 | 380 | instance MonadReader r m => MonadReader r (PerhapsT m) where 381 | ask = lift ask 382 | {-# inlinable ask #-} 383 | reader = lift . reader 384 | {-# inlinable reader #-} 385 | local = mapPerhapsT . local 386 | {-# inlinable local #-} 387 | 388 | -- | Lift a @callCC@ operation to the new monad. 389 | liftCallCC :: CallCC m (Perhaps a) (Perhaps b) -> CallCC (PerhapsT m) a b 390 | liftCallCC k f = 391 | PerhapsT $ k $ \ c -> runPerhapsT (f (PerhapsT . c . Can)) 392 | {-# inlinable liftCallCC #-} 393 | 394 | -- | Lift a @catchE@ operation to the new monad. 395 | liftCatch :: Catch e m (Perhaps a) -> Catch e (PerhapsT m) a 396 | liftCatch f m h = PerhapsT $ f (runPerhapsT m) (runPerhapsT . h) 397 | {-# inlinable liftCatch #-} 398 | 399 | -- | Lift a @listen@ operation to the new monad. 400 | liftListen :: Monad m => Listen w m (Perhaps a) -> Listen w (PerhapsT m) a 401 | liftListen l = mapPerhapsT $ \ m -> do 402 | (a, w) <- l m 403 | return $! fmap (\ r -> (r, w)) a 404 | {-# inlinable liftListen #-} 405 | 406 | -- | Lift a @pass@ operation to the new monad. 407 | liftPass :: Monad m => Pass w m (Perhaps a) -> Pass w (PerhapsT m) a 408 | liftPass p = mapPerhapsT $ \ m -> p $ do 409 | a <- m 410 | return $! case a of 411 | Can't e -> (Can't e, id) 412 | Can (v, f) -> (Can v, f) 413 | {-# inlinable liftPass #-} 414 | 415 | -- | Transform the computation inside a @PerhapsT@. 416 | -- 417 | -- * @'runPerhapsT' ('mapPerhapsT' f m) = f ('runPerhapsT' m)@ 418 | mapPerhapsT :: (m (Perhaps a) -> n (Perhaps b)) -> PerhapsT m a -> PerhapsT n b 419 | mapPerhapsT f = PerhapsT . f . runPerhapsT 420 | {-# INLINE mapPerhapsT #-} 421 | 422 | -------------------------------------------------------------------------------- 423 | -- * MonadPerhaps 424 | -------------------------------------------------------------------------------- 425 | 426 | class MonadPlus m => MonadPerhaps m where 427 | -- | This is a monad homomorphism 428 | perhaps :: Perhaps a -> m a 429 | #if __GLASGOW_HASKELL__ >= 702 430 | default perhaps :: (m ~ t n, MonadTrans t, MonadPerhaps n) => Perhaps a -> m a 431 | perhaps = lift . perhaps 432 | #endif 433 | 434 | -- | Fail with an exception as an excuse instead of just a string. 435 | excuse :: Exception e => e -> m a 436 | excuse = perhaps . Can't . throw 437 | 438 | instance MonadPerhaps Perhaps where 439 | perhaps = id 440 | {-# inlinable perhaps #-} 441 | 442 | excuse = Can't . throw 443 | {-# inline conlike excuse #-} 444 | 445 | instance Monad m => MonadPerhaps (PerhapsT m) where 446 | perhaps = PerhapsT . return 447 | {-# inlinable perhaps #-} 448 | 449 | instance MonadPerhaps m => MonadPerhaps (Lazy.StateT s m) where 450 | perhaps = lift . perhaps 451 | {-# inlinable perhaps #-} 452 | 453 | instance MonadPerhaps m => MonadPerhaps (Strict.StateT s m) where 454 | perhaps = lift . perhaps 455 | {-# inlinable perhaps #-} 456 | 457 | instance (MonadPerhaps m, Monoid w) => MonadPerhaps (Lazy.WriterT w m) where 458 | perhaps = lift . perhaps 459 | {-# inlinable perhaps #-} 460 | 461 | instance (MonadPerhaps m, Monoid w) => MonadPerhaps (Strict.WriterT w m) where 462 | perhaps = lift . perhaps 463 | {-# inlinable perhaps #-} 464 | 465 | instance (MonadPerhaps m, Monoid w) => MonadPerhaps (Lazy.RWST r w s m) where 466 | perhaps = lift . perhaps 467 | {-# inlinable perhaps #-} 468 | 469 | instance (MonadPerhaps m, Monoid w) => MonadPerhaps (Strict.RWST r w s m) where 470 | perhaps = lift . perhaps 471 | {-# inlinable perhaps #-} 472 | 473 | instance MonadPerhaps m => MonadPerhaps (ReaderT r m) where 474 | perhaps = lift . perhaps 475 | {-# inlinable perhaps #-} 476 | 477 | instance MonadPerhaps m => MonadPerhaps (IdentityT m) where 478 | perhaps = lift . perhaps 479 | {-# inlinable perhaps #-} 480 | -------------------------------------------------------------------------------- /src/Data/Perhaps.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (c) Edward Kmett 2018 4 | -- License : BSD3 5 | -- Maintainer : ekmett@gmail.com 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | ----------------------------------------------------------------------------- 10 | 11 | module Data.Perhaps 12 | ( 13 | -- * Maybe with an undisclosed error 14 | Perhaps(..) 15 | , believe 16 | , mayhap 17 | , excuse 18 | ) where 19 | 20 | import Control.Monad.Perhaps 21 | -------------------------------------------------------------------------------- /tests/doctests.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main (doctests) 4 | -- Copyright : (C) 2012-14 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- This module provides doctests for a project based on the actual versions 11 | -- of the packages it was built with. It requires a corresponding Setup.lhs 12 | -- to be added to the project 13 | ----------------------------------------------------------------------------- 14 | module Main where 15 | 16 | import Build_doctests (flags, pkgs, module_sources) 17 | import Data.Foldable (traverse_) 18 | import Test.DocTest 19 | 20 | main :: IO () 21 | main = do 22 | traverse_ putStrLn args 23 | doctest args 24 | where 25 | args = flags ++ pkgs ++ module_sources 26 | --------------------------------------------------------------------------------