Skip to content

Commit

Permalink
Fixes for latest GHC. (#10)
Browse files Browse the repository at this point in the history
* Fixes for latest GHC.

Signed-off-by: Tao He <sighingnow@gmail.com>

* Add stack.yaml and fixes for CI.

Signed-off-by: Tao He <sighingnow@gmail.com>

* Fixes.

Signed-off-by: Tao He <sighingnow@gmail.com>
  • Loading branch information
sighingnow committed Jul 6, 2020
1 parent 5c927f6 commit 693938c
Show file tree
Hide file tree
Showing 4 changed files with 116 additions and 4 deletions.
2 changes: 2 additions & 0 deletions .gitignore
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
.stack-work/
dist/
39 changes: 36 additions & 3 deletions Control/Monad/Exception/Base.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,8 +9,12 @@ module Control.Monad.Exception.Base where

import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Base
import Control.Monad.Exception.Catch
#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,13,0)
import qualified Control.Monad.Fail as Fail
#endif
import Control.Monad.Loc
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
Expand Down Expand Up @@ -62,18 +66,33 @@ instance Monad m => Functor (EMT l m) where
instance Monad m => Monad (EMT l m) where
return = EMT . return . Right

fail s = EMT $ return $ Left ([], CheckedException $ toException $ FailException s)

emt >>= f = EMT $ do
v <- unEMT emt
case v of
Left e -> return (Left e)
Right x -> unEMT (f x)

#if !MIN_VERSION_base(4,13,0)
#if MIN_VERSION_base(4,9,0)
fail = Fail.fail
#else
fail s = EMT $ return $ Left ([], CheckedException $ toException $ FailException s)
#endif
#endif

instance Monad m => Applicative (EMT l m) where
pure = return
(<*>) = ap

#if MIN_VERSION_base(4,9,0)
#if MIN_VERSION_base(4,13,0)
instance Monad m => MonadFail (EMT l m) where
#else
instance Monad m => Fail.MonadFail (EMT l m) where
#endif
fail s = EMT $ return $ Left ([], CheckedException $ toException $ FailException s)
#endif

instance (Exception e, Throws e l, Monad m) => Failure e (EMT l m) where
failure = throw

Expand All @@ -96,14 +115,28 @@ instance MonadBase b m => MonadBase b (EMT l m) where
liftBase = liftBaseDefault

instance MonadBaseControl b m => MonadBaseControl b (EMT l m) where
#if MIN_VERSION_monad_control(1,0,0)
type StM (EMT l m) a = ComposeSt (EMT l) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
#else
newtype StM (EMT l m) a = StmEMT {unStmEMT :: ComposeSt (EMT l) m a}
liftBaseWith = defaultLiftBaseWith StmEMT
restoreM = defaultRestoreM unStmEMT
#endif

-- newtype EMT l m a = EMT {unEMT :: m (Either (CallTrace, CheckedException l) a)}

instance MonadTransControl (EMT l) where
#if MIN_VERSION_monad_control(1,0,0)
type StT (EMT l) a = Either (CallTrace, CheckedException l) a
liftWith f = EMT $ fmap return $ f $ unEMT
restoreT = EMT
#else
newtype StT (EMT l) a = StEMT {unStEMT :: Either (CallTrace, CheckedException l) a}
liftWith f = EMT $ liftM return $ f $ liftM StEMT . unEMT
restoreT = EMT . liftM unStEMT
restoreT = EMT . liftM unStEMT
#endif

instance Monad m => MonadLoc (EMT l m) where
withLoc loc (EMT emt) = EMT $ do
Expand Down
5 changes: 4 additions & 1 deletion Control/Monad/Exception/Pure.hs
Original file line number Diff line number Diff line change
Expand Up @@ -74,7 +74,10 @@ module Control.Monad.Exception.Pure (
FailException(..), MonadZeroException(..), mplusDefault,

-- * Reexports
Exception(..), SomeException(..), Typeable1,
Exception(..), SomeException(..),
#if !MIN_VERSION_base(4,7,0)
Typeable1,
#endif
Failure(..),
#if !MIN_VERSION_failure(0,2,0)
Try(..), NothingException(..),
Expand Down
74 changes: 74 additions & 0 deletions stack.yaml
Original file line number Diff line number Diff line change
@@ -0,0 +1,74 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/

# A warning or info to be displayed to the user on config load.
user-message: |
Warning (added by new or init): Some packages were found to be incompatible with the resolver and have been left commented out in the packages section.
You can omit this message by removing it from stack.yaml
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: nightly-2020-06-29

# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- .

# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
extra-deps:
- failure-0.2.0.3
- monadloc-0.7.1

# Override default flag values for local packages and extra-deps
# flags: {}

# Extra package databases containing global packages
# extra-package-dbs: []

# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.3"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

0 comments on commit 693938c

Please sign in to comment.