monad-ste (empty) → 0.1.0.0

raw patch · 12 files changed

+497/−0 lines, 12 filesdep +HUnitdep +basedep +exceptionssetup-changed

Dependencies added: HUnit, base, exceptions, ghc-prim, hspec, monad-ste, primitive

Files

.gitignore +1/−0
.travis.yml +80/−0
ChangeLog.md +26/−0
Hlint.hs +10/−0
LICENSE +26/−0
Setup.hs +2/−0
cabal.project +1/−0
monad-ste.cabal +98/−0
readme.md +5/−0
src/Control/Monad/STE.hs +11/−0
src/Control/Monad/STE/Internal.hs +223/−0
tests/Hspec.hs +14/−0

+ .gitignore view

@@ -0,0 +1,1 @@+dist-newstyle

+ .travis.yml view

@@ -0,0 +1,80 @@+# This file has been generated by `make_travis_yml_2.hs`+# see https://github.com/hvr/multi-ghc-travis for more information+language: c+sudo: false++cache:+  directories:+    - $HOME/.cabal/packages+    - $HOME/.cabal/store++before_cache:+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar++matrix:+  include:+    - env: CABALVER=1.24 GHCVER=7.4.2+      compiler: ": #GHC 7.4.2"+      addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2], sources: [hvr-ghc]}}+    - env: CABALVER=1.24 GHCVER=7.6.3+      compiler: ": #GHC 7.6.3"+      addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3], sources: [hvr-ghc]}}+    - env: CABALVER=1.24 GHCVER=7.8.4+      compiler: ": #GHC 7.8.4"+      addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4], sources: [hvr-ghc]}}+    - env: CABALVER=1.24 GHCVER=7.10.3+      compiler: ": #GHC 7.10.3"+      addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}+    - env: CABALVER=1.24 GHCVER=8.0.1+      compiler: ": #GHC 8.0.1"+      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}+    - env: CABALVER=head GHCVER=head+      compiler: ": #GHC head"+      addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}}++  allow_failures:+    - env: CABALVER=head GHCVER=head++before_install:+ - unset CC+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH++install:+ - cabal --version+ - BENCH=${BENCH---enable-benchmarks}+ - TEST=${TEST---enable-tests}+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];+   then+     zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >+          $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;+   fi+ - travis_retry cabal update -v+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config+ - cabal new-build ${TEST} ${BENCH} --dep++# Here starts the actual work to be performed for the package under test;+# any command which exits with a non-zero exit code causes the build to fail.+script:+ - if [ -f configure.ac ]; then autoreconf -i; fi+ # this builds all libraries and executables (including tests/benchmarks)+ - cabal new-build ${TEST} ${BENCH} -v2  # -v2 provides useful information for debugging++ # there's no 'cabal new-test' yet, so let's emulate for now+ - TESTS=( $(awk 'tolower($0) ~ /^test-suite / { print $2 }' *.cabal) );+   RC=true; for T in ${TESTS[@]}; do echo "== $T ==";+   if dist-newstyle/build/*/build/$T/$T; then echo "= $T OK =";+   else echo "= $T FAILED ="; RC=false; fi; done; $RC+ - cabal sdist # test that a source-distribution can be generated++ # Check that the resulting source distribution can be built w/o and w tests+ - SRC_BASENAME=$(cabal info . | awk '{print $2;exit}')+ - tar -C dist/ -xf dist/$SRC_BASENAME.tar.gz+ - "echo 'packages: *.cabal' > dist/$SRC_BASENAME/cabal.project"+ - cd dist/$SRC_BASENAME/+ - cabal new-build --disable-tests --disable-benchmarks+ - rm -rf ./dist-newstyle+ - cabal new-build ${TEST} ${BENCH}++# EOF

+ ChangeLog.md view

@@ -0,0 +1,26 @@+# Revision history for monad-ste++## 0.1.0.0  -- 2016-05-03++* First hackage release++* Added support for GHC 7.4 through 7.8 along with preexisting support for+7.10 and 8.0++* Added MonadFix instance++* Moved the definitions and unsafe code to .STE.Internal and marked the+  .STE module which only provides safe exports as Trustworthy++* Added a number of unsafe helper functions such as `unsafeInterleaveSTE`+to the Internal module, as well as exposing++## pre 0.1.0.0++* Thanks to Duncan Coutts for design feedback that using the+raw `raiseIO#` and `catch#` primitives would simplify the core code++* Thanks to Brian Schroeder and Joel Burget for helping debug and improve+the code.++* Originally a module in the Hopper project.

+ Hlint.hs view

@@ -0,0 +1,10 @@+import "hint" HLint.HLint++ignore "Reduce duplication"+ignore "Redundant lambda"+ignore "Use >=>"+ignore "Use const"+ignore "Avoid lambda"+ignore "Redundant flip"+ignore "Use let"+ignore "Redundant $"

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright (c) 2016, Carter Tazio Schonwald+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ cabal.project view

@@ -0,0 +1,1 @@+packages: monad-ste.cabal

+ monad-ste.cabal view

@@ -0,0 +1,98 @@+-- Initial monad-ste.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                monad-ste++-- The package version.  See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- https://wiki.haskell.org/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.0++-- A short (one-line) description of the package.+synopsis:            ST monad with efficient explicit errors++-- A longer description of the package.+description: STE is a sibling to the ST monad that provides more efficient+  abortive errors than a standard EitherT or ExceptT monad stack.++-- URL for the project homepage or repository.+homepage:            http://github.com/cartazio/monad-ste++-- The license under which the package is released.+license:             BSD2++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Carter Tazio Schonwald++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer:          carter at wellposed dot com++-- A copyright notice.+-- copyright:++category:            Control++tested-with:  GHC==8.0.1,  GHC==8.1.* , GHC==7.10.3, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a+-- README.+extra-source-files:  ChangeLog.md+                    .travis.yml+                    .gitignore+                    Hlint.hs+                    readme.md+                    cabal.project++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/cartazio/monad-ste++library+  -- Modules exported by the library.+  exposed-modules:      Control.Monad.STE+                        Control.Monad.STE.Internal++  ghc-options: -O2+  -- Modules included in this library but not exported.+  -- other-modules:++  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:++  -- Other library packages from which modules are imported.+  build-depends:      base >=4.3 && < 5+                      ,primitive >= 0.6 && < 0.7+                      ,exceptions >= 0.8 && < 0.9+                      ,ghc-prim+++  -- Directories containing source files.+  hs-source-dirs:      src++  -- Base language which the package is written in.+  default-language:    Haskell2010++test-suite hspec+  type: exitcode-stdio-1.0+  main-is: Hspec.hs+  ghc-options: -Wall  -O2+  hs-source-dirs: tests+  default-language: Haskell2010+  build-depends:+      base+      ,hspec >= 2.1 && < 2.3+      ,HUnit+      ,monad-ste

+ readme.md view

@@ -0,0 +1,5 @@+[![Build Status](https://travis-ci.org/cartazio/monad-ste.svg?branch=master)](https://travis-ci.org/cartazio/monad-ste)++# STE Monad+an ST monad sibling with efficient typed aborting exceptions that can only be+handled at the `runSTE`/`handleSTE` toplevel runner.

+ src/Control/Monad/STE.hs view

@@ -0,0 +1,11 @@+{-#  LANGUAGE Trustworthy #-}+module Control.Monad.STE+(+  STE+  ,runSTE+  ,throwSTE+  ,handleSTE+  )++  where+import Control.Monad.STE.Internal

+ src/Control/Monad/STE/Internal.hs view

@@ -0,0 +1,223 @@+{-# LANGUAGE MagicHash, UnboxedTuples, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Unsafe #-}+module Control.Monad.STE.Internal+(+  STE(..)+  ,unSTE+  ,STERep+  ,STEret(..)+  ,runSTE+  ,throwSTE+  ,handleSTE+  ----+  ,unsafeInterleaveSTE+  ,liftSTE+  ,fixSTE+  ,runBasicSTE+  ,RealWorld+  ,unsafeIOToSTE+  ,unsafeSTEToIO+  )++  where++#if MIN_VERSION_ghc_prim(0,5,0)+import GHC.Prim (State#, raiseIO#, catch#)+#else+import GHC.Prim (State#, raiseIO#, catch#, realWorld#)+#endif++import qualified Control.Monad.Catch as CMC+import Control.Exception as Except+import Control.Monad (ap)+import qualified Control.Monad.Fix as MF+import Control.Monad.Primitive+import Data.Typeable+import Unsafe.Coerce (unsafeCoerce)+import GHC.IO(IO(..))++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++#if MIN_VERSION_ghc_prim(0,5,0)+import GHC.Magic(runRW#)+#endif+++newtype STE e s a = STE  (STERep s a)++unSTE :: STE e s a -> STERep s a+unSTE = \(STE a) ->  a++type STERep s a = State# s -> (# State# s, a #)++data STEret s a = STEret (State# s) a++-- liftSTE and STEret is useful when we want a lifted result from an STE computation.  See+-- fixSTE below.+liftSTE :: STE e s a -> State# s -> STEret s a+liftSTE (STE m) = \s -> case m s of (# s', r #) -> STEret s' r++{-# NOINLINE unsafeInterleaveSTE #-}+unsafeInterleaveSTE :: STE e s a -> STE e s a+unsafeInterleaveSTE (STE m) = STE ( \ s ->+    let+        r = case m s of (# _, res #) -> res+    in+    (# s, r #)+  )++-- | Allow the result of a state transformer computation to be used (lazily)+-- inside the computation.+-- Note that if @f@ is strict, @'fixSTE' f = _|_@.+fixSTE :: (a -> STE e s a) -> STE e s a+fixSTE k = STE $ \ s ->+    let ans       = liftSTE (k r) s+        STEret _ r = ans+    in+    case ans of STEret s' x -> (# s', x #)+++instance Functor (STE e s) where+    fmap f (STE m) = STE $ \ s ->+      case (m s) of { (# new_s, r #) ->+      (# new_s, f r #) }++instance Applicative (STE e s) where+    {-# INLINE pure  #-}+    {-# INLINE (<*>) #-}+    {-# INLINE (*> ) #-}+    pure = return+    (*>) = \ m k ->  m >>= \ _ -> k+    (<*>) = ap++instance Monad (STE e s) where+    {-# INLINE return #-}+    {-# INLINE (>>)   #-}+    {-# INLINE (>>=)  #-}+    return x = STE (\ s -> (# s, x #))+    m >> k   = m >>= \ _ -> k+    (STE m) >>= k+      = STE (\ s ->+        case (m s) of { (# new_s, r #) ->+        case (k r) of { STE k2 ->+        (k2 new_s) }})++instance MF.MonadFix (STE e s) where+  mfix = fixSTE++instance PrimMonad (STE e s) where+  type PrimState (STE e s) = s+  primitive = \ m ->  STE m+  {-# INLINE primitive #-}+instance PrimBase (STE e s) where+  internal (STE p) = \ s# -> case p s# of+                          (# a , b #) -> (# a , b #)+  {-# INLINE internal #-}++-- this isn't terribly useful, but it is the only valid instance STE can have for+-- MonadThrow and be well behaved, though this may be replaced with+-- an+instance (Except.SomeException ~ err) =>  CMC.MonadThrow (STE err s) where+  throwM x = throwSTE  $ toException x+++{-# INLINE runSTE #-} -- this may not be needed and may make code closer when its a small STE computation (though we're using it for small stuff )+-- | 'runSTE' is the workhorse of the STE monad. Runs an STE computation, and+-- also does the toplevel handling of the abortive throwSTE operator.+-- The naive way to handle errors is to simply write @'handleSTE' 'id' md@.+-- 'runSTE' does not and cannot (by design) handle pure or async exceptions.+runSTE ::  (forall s. STE e s a) -> (Either e a  -> b) -> b+runSTE = \ st  f -> f  $+            runBasicSTE (privateCatchSTE st)++{-# INLINE handleSTE #-}+-- | 'handleSTE' is a flipped convenience function version of 'runSTE'+handleSTE :: (Either e a -> b) -> (forall s. STE e s a)  -> b+handleSTE f st = runSTE st f++-- |  'throwSTE' is the 'STE' sibling of 'throwIO', and its argument+-- must match the @e@ parameter in @'STE' e s a@. There is also no Exception e+-- constraint.+-- `throwSTE` should be thought of as an "abort" operation which is guaranteed to be+-- caught/handled by runSTE.+throwSTE :: forall e s a .  e -> STE e s a+throwSTE err = unsafeIOToSTE  $+    IO (raiseIO# (toException $ STException $ ( Box $ unsafeCoerce err)))++-- | privateCatchSTE is NOT exported+-- we copy the machinery from+-- catchException so that pure errors aren't mishandled by+-- the catchSTE machinery when handling STE errors+privateCatchSTE:: forall e s b . STE e s b  -> STE e s (Either e b)+privateCatchSTE = \ steAct  ->+      unsafeIOToSTE $+        IO  (catch# (unsafeCoerce $ unSTE $ fmap Right steAct) handler')+  where+    --- need to handle pure exceptions too!+    handler' :: SomeException -> STERep RealWorld (Either e b)+    handler' e = case (fromException e) of+        Just (STException (Box val)) -> \ s -> (# s , Left $ unsafeCoerce val #)+        Nothing -> raiseIO# e++{-+catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a+catchAny (IO io) handler = IO $ catch# io handler'+    where handler' (SomeException e) = unIO (handler e)++catchException :: Exception e => IO a -> (e -> IO a) -> IO a+catchException (IO io) handler = IO $ catch# io handler'+    where handler' e = case fromException e of+                       Just e' -> unIO (handler e')+                       Nothing -> raiseIO# e+++see https://phabricator.haskell.org/D1973 and+https://ghc.haskell.org/trac/ghc/ticket/11555+for information on tradeoffs in strictness++-}+++unsafeIOToSTE        :: IO a -> STE e s a+unsafeIOToSTE (IO io) = STE $ \ s -> (unsafeCoerce io) s++unsafeSTEToIO :: STE e s a -> IO a+unsafeSTEToIO (STE m) = IO (unsafeCoerce m)+++--- this results in WAY better perf when available+#if MIN_VERSION_ghc_prim(0,5,0)+runBasicSTE :: (forall s. STE e s a) -> a+runBasicSTE (STE st_rep) = case runRW# st_rep of (# _, a #) -> a+{-# INLINE runBasicSTE #-}+#else+runBasicSTE :: (forall s. STE e s a) -> a+runBasicSTE st = runSTERep (case st of { STE st_rep -> st_rep })+{-# INLINE runBasicSTE #-}++runSTERep :: (forall s. STERep  s a) -> a+runSTERep st_rep = case st_rep realWorld# of+                        (# _, r #) -> r+{-# NOINLINE runSTERep #-}+#endif+++#if MIN_VERSION_base(4,8,0)+data Box a = Box {-# NOUNPACK #-} a+#else+data Box a = Box  a+#endif++-- | STException+data STException = STException  (Box ())+  deriving Typeable+instance Show (STException ) where+  show (STException _) = "STException(..)! did you use the Unsafe/internal STE interface?"+instance Exception (STException)

+ tests/Hspec.hs view

@@ -0,0 +1,14 @@+module Main where+import Test.Hspec+--import Control.Exception+import Control.Monad.STE++main ::  IO ()+main = hspec  spec++spec :: Spec+spec = describe "STE Spec " $ do+  it "catches errors" $+    Left "some error" == handleSTE id (do  _ <- throwSTE "some error"; return (1 :: Int ))+  it "returns stuff" $+    (1 :: Int) == (either (error "fail") id $ handleSTE id (return (1 :: Int )))