diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -# Extensible effects (![Hackage](https://img.shields.io/hackage/v/extensible-effects.svg), ![GHC](https://img.shields.io/badge/GHC-8.02%20%7C%208.2.2%20%7C%208.4.4%20%7C%208.6.2-blue.svg)) +# Extensible effects (![Hackage](https://img.shields.io/hackage/v/extensible-effects.svg), ![GHC](https://img.shields.io/badge/GHC-8.2.2%20%7C%208.4.4%20%7C%208.6.3-blue.svg)) [![Build Status](https://travis-ci.org/suhailshergill/extensible-effects.svg?branch=master)](https://travis-ci.org/suhailshergill/extensible-effects) [![Join the chat at https://gitter.im/suhailshergill/extensible-effects](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/suhailshergill/extensible-effects?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) diff --git a/benchmark/Benchmarks.hs b/benchmark/Benchmarks.hs --- a/benchmark/Benchmarks.hs +++ b/benchmark/Benchmarks.hs @@ -7,7 +7,7 @@ import Criterion.Main import Control.Eff as E import Control.Eff.Exception as E.Er -import Control.Eff.NdetEff as E.ND +import Control.Eff.Logic.NDet as E.ND import Control.Eff.State.Strict as E.S import Control.Monad @@ -160,7 +160,7 @@ case_pythr_ndet :: HU.Assertion case_pythr_ndet = HU.assertEqual "pythr_MTL" pyth20 ((runCont (pyth1 20) (\x -> [x])) :: [(Int,Int,Int)]) - >> HU.assertEqual "pythr_EFF" pyth20 ((run . E.ND.makeChoiceA $ pyth1 20) :: [(Int,Int,Int)]) + >> HU.assertEqual "pythr_EFF" pyth20 ((run . E.ND.makeChoice $ pyth1 20) :: [(Int,Int,Int)]) -- There is no instance of MonadPlus for ContT @@ -177,7 +177,7 @@ mainN_MTL n = ((runCont (pyth1 n) (\x -> [x])) :: [(Int,Int,Int)]) -mainN_Eff n = ((run . E.ND.makeChoiceA $ pyth1 n) :: [(Int,Int,Int)]) +mainN_Eff n = ((run . E.ND.makeChoice $ pyth1 n) :: [(Int,Int,Int)]) -- Adding state: counting the number of choices @@ -190,7 +190,7 @@ S.put $! (cnt + 1) if x*x + y*y == z*z then return (x,y,z) else mzero -pyth2E :: (Member (E.S.State Int) r, Member NdetEff r) => +pyth2E :: (Member (E.S.State Int) r, Member NDet r) => Int -> Eff r (Int, Int, Int) pyth2E upbound = do x <- iota 1 upbound @@ -213,4 +213,4 @@ in ((l::[(Int,Int,Int)]), (cnt::Int)) where pyth2Er :: Int -> ([(Int,Int,Int)],Int) - pyth2Er n = run . E.S.runState 0 . E.ND.makeChoiceA $ pyth2E n + pyth2Er n = run . E.S.runState 0 . E.ND.makeChoice $ pyth2E n diff --git a/extensible-effects.cabal b/extensible-effects.cabal --- a/extensible-effects.cabal +++ b/extensible-effects.cabal @@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 4.0.0.0 +version: 5.0.0.0 -- A short (one-line) description of the package. synopsis: An Alternative to Monad Transformers @@ -41,7 +41,7 @@ category: Control, Effect -tested-with: GHC==8.6.2, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 +tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2 build-type: Simple @@ -56,18 +56,20 @@ default: False manual: True +flag dump-core + description: Dump HTML for the core generated by GHC during compilation + default: False + library - ghc-options: -Wall + ghc-options: -Wall -O2 -- Modules exported by the library. exposed-modules: Control.Eff - Control.Eff.Choose Control.Eff.Coroutine - Control.Eff.Cut Control.Eff.Example Control.Eff.Exception Control.Eff.Fresh - Control.Eff.Logic - Control.Eff.NdetEff + Control.Eff.Logic.Core + Control.Eff.Logic.NDet Control.Eff.Operational Control.Eff.Operational.Example Control.Eff.Reader.Lazy @@ -85,6 +87,7 @@ -- Modules included in this library but not exported. other-modules: Control.Eff.Internal Data.FTCQueue + Control.Eff.Logic.Experimental default-extensions: NoMonomorphismRestriction , MonoLocalBinds @@ -121,15 +124,13 @@ , Trustworthy , TypeOperators , UndecidableInstances - if impl(ghc >= 8.2) - ghc-options: -Wno-simplifiable-class-constraints -- Other library packages from which modules are imported. build-depends: base >= 4.7 && < 5 -- For MonadBase - , transformers-base == 0.4.* + , transformers-base == 0.4.* -- For MonadBaseControl - , monad-control >= 1.0 && < 1.1 + , monad-control >= 1.0 && < 1.1 -- Directories containing source files. hs-source-dirs: src @@ -140,20 +141,23 @@ if flag(lib-Werror) ghc-options: -Werror + if flag(dump-core) + build-depends: dump-core + ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html + test-suite extensible-effects-tests type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: test/ other-modules: Utils , Control.Eff.Test - , Control.Eff.Choose.Test , Control.Eff.Coroutine.Test - , Control.Eff.Cut.Test , Control.Eff.Example.Test , Control.Eff.Exception.Test , Control.Eff.Fresh.Test - , Control.Eff.NdetEff.Bench - , Control.Eff.NdetEff.Test + , Control.Eff.Logic.NDet.Bench + , Control.Eff.Logic.NDet.Test + , Control.Eff.Logic.Test , Control.Eff.Operational.Test , Control.Eff.Reader.Lazy.Test , Control.Eff.Reader.Strict.Test @@ -203,7 +207,7 @@ type: exitcode-stdio-1.0 main-is: Benchmarks.hs hs-source-dirs: benchmark/ - ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields + ghc-options: -Wall -O2 -threaded -rtsopts if impl(ghc >= 8.0) ghc-options: -Wno-type-defaults -Wno-missing-signatures -Wno-name-shadowing -Wno-unused-matches diff --git a/src/Control/Eff.hs b/src/Control/Eff.hs --- a/src/Control/Eff.hs +++ b/src/Control/Eff.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {-# LANGUAGE ExplicitNamespaces #-} -- | A monadic library for implementing effectful computation in a modular way. diff --git a/src/Control/Eff/Choose.hs b/src/Control/Eff/Choose.hs deleted file mode 100644 --- a/src/Control/Eff/Choose.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE Safe #-} --- The following is needed to define MonadPlus instance. It is decidable --- (there is no recursion!), but GHC cannot see that. -{-# LANGUAGE UndecidableInstances #-} - --- | Nondeterministic choice effect -module Control.Eff.Choose ( Choose (..) - , withChoose - , choose - , makeChoice - , mzero' - , mplus' - , module Control.Eff.Logic - ) where - -import Control.Eff -import Control.Eff.Extend -import Control.Eff.Logic - -import Control.Applicative -import Control.Monad -import Control.Monad.Base -import Control.Monad.Trans.Control - --- ------------------------------------------------------------------------ --- | Non-determinism (choice) --- --- choose lst non-deterministically chooses one value from the lst --- choose [] thus corresponds to failure --- Unlike Reader, Choose is not a GADT because the type of values --- returned in response to a (Choose a) request is just a, without --- any constraints. -newtype Choose a = Choose [a] - --- | Embed a pure value -withChoose :: Monad m => a -> m [a] -withChoose = return . (:[]) --- | Given a continuation and a Choose request, respond to it. -instance Monad m => Handle Choose (m [a]) where - handle _ (Choose []) = return [] - handle k (Choose [x]) = k x - handle k (Choose lst) = fmap concat $ mapM k lst - -instance ( MonadBase m m - , LiftedBase m r - ) => MonadBaseControl m (Eff (Choose ': r)) where - type StM (Eff (Choose ': r)) a = StM (Eff r) [a] - liftBaseWith f = raise $ liftBaseWith $ \runInBase -> - f (runInBase . makeChoice) - restoreM x = do lst <- raise (restoreM x) - choose lst - --- | choose lst non-deterministically chooses one value from the lst --- choose [] thus corresponds to failure -choose :: Member Choose r => [a] -> Eff r a -choose lst = send $ Choose lst - --- | MonadPlus-like operators are expressible via choose -mzero' :: Member Choose r => Eff r a -mzero' = choose [] - --- | MonadPlus-like operators are expressible via choose -mplus' :: Member Choose r => Eff r a -> Eff r a -> Eff r a -mplus' m1 m2 = join $ choose [m1,m2] - --- | MonadPlus-like operators are expressible via choose -instance Member Choose r => Alternative (Eff r) where - empty = mzero' - (<|>) = mplus' - -instance Member Choose r => MonadPlus (Eff r) where - mzero = empty - mplus = (<|>) - --- | Run a nondeterministic effect, returning all values. -makeChoice :: forall a r. Eff (Choose ': r) a -> Eff r [a] -makeChoice = handle_relay withChoose - -instance Member Choose r => MSplit (Eff r) where - msplit = respond_relay (flip withMSplit empty) - (\k (Choose lst) -> hdl k lst) - where - hdl :: Arr r v (Maybe (a, Eff r a)) - -> [v] -> Eff r (Maybe (a, Eff r a)) - hdl _ [] = return Nothing -- definite failure - hdl k (h:t) = k h >>= \r -> case r of -- possibility - Nothing -> hdl k t -- failure, continue exploring - Just (a, m) -> withMSplit a (m <|> (hdl k t >>= reflect)) -- definite success diff --git a/src/Control/Eff/Coroutine.hs b/src/Control/Eff/Coroutine.hs --- a/src/Control/Eff/Coroutine.hs +++ b/src/Control/Eff/Coroutine.hs @@ -14,6 +14,8 @@ import Control.Eff import Control.Eff.Extend +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | Co-routines -- The interface is intentionally chosen to be the same as in transf.hs @@ -43,9 +45,9 @@ withCoroutine :: Monad m => b -> m (Y r w a) withCoroutine = const $ return Done -- | Given a continuation and a request, respond to it -instance Handle (Yield a b) (Eff r (Y r b a)) where - handle k (Yield a) = return $ Y k a +instance Handle (Yield a b) (Yield a b : r) w (Eff r (Y r b a)) where + handle step q (Yield a) = return $ Y (step . (q ^$)) a -- | Launch a thread and report its status runC :: Eff (Yield a b ': r) w -> Eff r (Y r b a) -runC = handle_relay withCoroutine +runC = fix (handle_relay withCoroutine) diff --git a/src/Control/Eff/Cut.hs b/src/Control/Eff/Cut.hs deleted file mode 100644 --- a/src/Control/Eff/Cut.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeOperators, DataKinds #-} -{-# LANGUAGE Safe #-} --- | An example of non-trivial interaction of effects, handling of two --- effects together --- Non-determinism with control (cut) --- For the explanation of cut, see Section 5 of Hinze ICFP 2000 paper. --- Hinze suggests expressing cut in terms of cutfalse: --- --- > = return () `mplus` cutfalse --- > where --- > cutfalse :: m a --- --- satisfies the following laws: --- --- > cutfalse >>= k = cutfalse (F1) --- > cutfalse | m = cutfalse (F2) --- --- (note: @m \``mplus`\` cutfalse@ is different from @cutfalse \``mplus`\` m@). --- In other words, cutfalse is the left zero of both bind and mplus. --- --- Hinze also introduces the operation @`call` :: m a -> m a@ that --- delimits the effect of cut: @`call` m@ executes m. If the cut is --- invoked in m, it discards only the choices made since m was called. --- Hinze postulates the axioms of `call`: --- --- > call false = false (C1) --- > call (return a | m) = return a | call m (C2) --- > call (m | cutfalse) = call m (C3) --- > call (lift m >>= k) = lift m >>= (call . k) (C4) --- --- @`call` m@ behaves like @m@ except any cut inside @m@ has only a local effect, --- he says. --- --- Hinze noted a problem with the \"mechanical\" derivation of backtracing --- monad transformer with cut: no axiom specifying the interaction of --- call with bind; no way to simplify nested invocations of call. --- --- We use exceptions for cutfalse --- Therefore, the law @cutfalse >>= k = cutfalse@ --- is satisfied automatically since all exceptions have the above property. -module Control.Eff.Cut where - -import Control.Eff -import Control.Eff.Extend -import Control.Eff.Exception -import Control.Eff.Choose -import Control.Monad - -data CutFalse = CutFalse - -cutfalse :: Member (Exc CutFalse) r => Eff r a -cutfalse = throwError CutFalse - --- | Prolog 'cut', taken from Hinze 2000 (Deriving backtracking monad --- transformers). -(!) :: (Member (Exc CutFalse) r, MonadPlus (Eff r)) => Eff r () -(!) = return () `mplus` cutfalse - --- | The interpreter -- it is like reify . reflect with a twist. Compare this --- implementation with the huge implementation of call in Hinze 2000 (Figure 9). --- Each clause corresponds to the axiom of call or cutfalse. All axioms are --- covered. --- --- The code clearly expresses the intuition that call watches the choice points --- of its argument computation. When it encounteres a cutfalse request, it --- discards the remaining choicepoints. It completely handles CutFalse effects --- but not non-determinism -call :: forall a r. Member Choose r => Eff (Exc CutFalse ': r) a -> Eff r a -call m = loop [] m where - loop :: Member Choose r - => [Eff (Exc CutFalse ': r) a] - -> Eff (Exc CutFalse ': r) a - -> Eff r a - loop jq (Val x) = return x `mplus'` next jq -- (C2) - loop jq (E q u) = case decomp u of - Right (Exc CutFalse) -> mzero' -- drop jq (F2) - Left u0 -> check jq u0 q - - check :: forall b. [Eff (Exc CutFalse ': r) a] - -> Union r b -> Arrs (Exc CutFalse ': r) b a -> Eff r a - check jq u _ | Just (Choose []) <- prj u = next jq -- (C1) - check jq u q | Just (Choose [x]) <- prj u = loop jq (q ^$ x) -- (C3), optim - check jq u q | Just (Choose lst) <- prj u = next $ map (q ^$) lst ++ jq -- (C3) - check jq u q = loop jq (E q (weaken u)) -- (C4) - - next :: Member Choose r - => [Eff (Exc CutFalse ': r) a] - -> Eff r a - next [] = mzero' - next (h:t) = loop t h diff --git a/src/Control/Eff/Exception.hs b/src/Control/Eff/Exception.hs --- a/src/Control/Eff/Exception.hs +++ b/src/Control/Eff/Exception.hs @@ -33,6 +33,8 @@ import Control.Monad.Base import Control.Monad.Trans.Control +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | Exceptions -- @@ -46,12 +48,8 @@ exc :: Monad m => e -> m (Either e a) exc = return . Left -- | Given a callback, and an 'Exc' request, respond to it. -instance Monad m => Handle (Exc e) (m (Either e a)) where - handle _ (Exc e) = exc e - --- runError :: (a -> m (Either e a)), (e -> m (Either e a)) --- catchError :: (a -> Eff r a), (e -> Eff r a) --- exc :: e -> m (Either e a) +instance Monad m => Handle (Exc e) r a (m (Either e a)) where + handle _ _ (Exc e) = exc e instance ( MonadBase m m , LiftedBase m r @@ -83,7 +81,7 @@ -- | Run a computation that might produce an exception. runError :: Eff (Exc e ': r) a -> Eff r (Either e a) -runError = handle_relay withException +runError = fix (handle_relay withException) -- | Runs a failable effect, such that failed computation return 'Nothing', and -- 'Just' the return value on success. @@ -96,7 +94,7 @@ -- exception catchError :: Member (Exc e) r => Eff r a -> (e -> Eff r a) -> Eff r a -catchError m h = respond_relay return (\_ (Exc e) -> h e) m +catchError m h = fix (respond_relay' (\_ _ (Exc e) -> h e) return) m -- | Add a default value (i.e. failure handler) to a fallible computation. -- This hides the fact that a failure happened. diff --git a/src/Control/Eff/Extend.hs b/src/Control/Eff/Extend.hs --- a/src/Control/Eff/Extend.hs +++ b/src/Control/Eff/Extend.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE PatternSynonyms #-} + -- | This module exports functions, types, and typeclasses necessary for -- implementing a custom effect and/or effect handler. -- @@ -6,7 +9,7 @@ ( -- * The effect monad Eff(..) , run - , eff, impurePrj, impureDecomp + , eff -- * Lifting operations , Lift(..), Lifted, LiftedBase , lift, runLift @@ -16,17 +19,14 @@ , OpenUnion.Union , OpenUnion.Member , inj - , prj - , decomp + , prj, pattern OpenUnion.U0' + , decomp, pattern OpenUnion.U0, pattern OpenUnion.U1 , SetMember , weaken -- * Helper functions that are used for implementing effect-handlers - , Handle, handle - , Relay, relay - , handle_relay - , handle_relay' - , respond_relay - , respond_relay' + , Handle(..) + , Relay(..) + , handle_relay', respond_relay' , raise , send -- * Arrow types and compositions @@ -41,8 +41,7 @@ , comp , (^|>) , qComp - , qComps, (^|$^) - , (~^), qThen, andThen + , qComps ) where diff --git a/src/Control/Eff/Fresh.hs b/src/Control/Eff/Fresh.hs --- a/src/Control/Eff/Fresh.hs +++ b/src/Control/Eff/Fresh.hs @@ -20,6 +20,7 @@ import Control.Monad.Base import Control.Monad.Trans.Control +import Data.Function (fix) -- There are three possible implementations -- The first one uses State Fresh where @@ -41,9 +42,10 @@ withFresh x s = return (x, s) -- | Given a continuation and requests, respond to them -instance Handle Fresh (Int -> r) where - handle k Fresh s = k s (s + 1) - handle k (Replace i) _ = k () i +instance Handle Fresh r a (Int -> k) where + handle step q req s = case req of + Fresh -> step (q ^$ s) (s+1) + Replace i -> step (q ^$ ()) i instance ( MonadBase m m , LiftedBase m r @@ -69,7 +71,7 @@ runFresh' s m = fst `fmap` runFreshReturn s m runFreshReturn :: Int -> Eff (Fresh ': r) w -> Eff r (w,Int) -runFreshReturn s m = handle_relay withFresh m s +runFreshReturn s m = fix (handle_relay withFresh) m s {- -- Finally, the worst implementation but the one that answers diff --git a/src/Control/Eff/Internal.hs b/src/Control/Eff/Internal.hs --- a/src/Control/Eff/Internal.hs +++ b/src/Control/Eff/Internal.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} -- ------------------------------------------------------------------------ -- | A monadic library for communication between a handler and @@ -40,11 +41,11 @@ -- denoted by r type Arr r a b = a -> Eff r b --- | An effectful function from 'a' to 'b' that is a composition of one or more +-- | An effectful function from @a@ to @b@ that is a composition of one or more -- effectful functions. The paremeter r describes the overall effect. -- --- The composition members are accumulated in a type-aligned queue. --- Using a newtype here enables us to define `Category' and `Arrow' instances. +-- The composition members are accumulated in a type-aligned queue. Using a +-- newtype here enables us to define `C.Category' and `A.Arrow' instances. newtype Arrs r a b = Arrs (FTCQueue (Eff r) a b) -- | 'Arrs' can be composed and have a natural identity. @@ -52,7 +53,7 @@ id = ident f . g = comp g f --- | As the name suggests, 'Arrs' also has an 'Arrow' instance. +-- | As the name suggests, 'Arrs' also has an 'A.Arrow' instance. instance A.Arrow (Arrs r) where arr = arr first = singleK . first . (^$) @@ -62,16 +63,16 @@ -- | convert single effectful arrow into composable type. i.e., convert 'Arr' to -- 'Arrs' -{-# INLINE singleK #-} +{-# INLINE [2] singleK #-} singleK :: Arr r a b -> Arrs r a b -singleK = Arrs . tsingleton -{-# INLINE (~^) #-} -(~^) :: Arr r a b -> Arrs r a b -(~^) = singleK +singleK k = Arrs (tsingleton k) +{-# RULES +"singleK/qApp" [~2] forall q. singleK (qApp q) = q + #-} --- | Application to the `generalized effectful function' Arrs r b w, i.e., +-- | Application to the `generalized effectful function' @Arrs r b w@, i.e., -- convert 'Arrs' to 'Arr' -{-# INLINABLE qApp #-} +{-# INLINABLE [2] qApp #-} qApp :: forall r b w. Arrs r b w -> Arr r b w qApp (Arrs q) x = viewlMap (inline tviewl q) ($ x) cons where @@ -92,8 +93,8 @@ -} -- | Syntactic sugar for 'qApp' -{-# INLINABLE (^$) #-} -(^$) :: forall r b w. Arrs r b w -> Arr r b w +{-# INLINE [2] (^$) #-} +(^$) :: forall r b w. Arrs r b w -> b -> Eff r w q ^$ x = q `qApp` x -- | Lift a function to an arrow @@ -105,6 +106,7 @@ ident = arr id -- | Arrow composition +{-# INLINE comp #-} comp :: Arrs r a b -> Arrs r b c -> Arrs r a c comp (Arrs f) (Arrs g) = Arrs (f >< g) @@ -115,9 +117,9 @@ -- | The monad that all effects in this library are based on. -- -- An effectful computation is a value of type `Eff r a`. --- In this signature, `r` is a type-level list of effects that are being +-- In this signature, @r@ is a type-level list of effects that are being -- requested and need to be handled inside an effectful computation. ---`a` is the computation's result similar to other monads. +-- @a@ is the computation's result similar to other monads. -- -- A computation's result can be retrieved via the 'run' function. -- However, all effects used in the computation need to be handled by the use @@ -139,51 +141,22 @@ -- common pattern for Eff. {-# INLINE bind #-} bind :: Arr r a b -> Eff r a -> Eff r b -bind k = eff k (E . (^|> k)) -- just accumulates continuations - --- | Case analysis for impure computations for 'Eff' datatype. This --- uses 'decomp'. -{-# INLINE impureDecomp #-} -impureDecomp :: (Arrs (t ': r) v a -> t v -> b) - -> (Arrs (t ': r) v a -> Union r v -> b) - -> Arrs (t ': r) v a -> Union (t ': r) v -> b -impureDecomp h rest q u = either (rest q) (h q) (decomp u) --- | Case analysis for impure computations for 'Eff' datatype. This --- uses 'prj'. -{-# INLINE impurePrj #-} -impurePrj :: Member t r - => (Arrs r v a -> t v -> b) - -> (Arrs r v a -> Union r v -> b) - -> Arrs r v a -> Union r v -> b -impurePrj h def q u = maybe (def q u) (h q) (prj u) +bind k e = eff k (E . (^|> k)) e -- just accumulates continuations -- | Compose effectful arrows (and possibly change the effect!) {-# INLINE qComp #-} qComp :: Arrs r a b -> (Eff r b -> k) -> (a -> k) -- qComp g h = (h . (g `qApp`)) -qComp g h = \a -> h $ (g ^$ a) -{-# INLINABLE qThen #-} -qThen :: (Eff r b -> k) -> Arrs r a b -> (a -> k) -qThen = flip qComp - --- | Compose and then apply to function. This is a common pattern when --- processing requests. Different options of 'f' allow us to handle or --- relay the request and continue on. -andThen :: ((b -> c) -> t) -> (Eff r w -> c) - -> Arrs r b w -> t -andThen f next = f . (qThen next) +qComp g h = \a -> h (g ^$ a) -- | Compose effectful arrows (and possibly change the effect!) {-# INLINE qComps #-} qComps :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c qComps g h = singleK $ qComp g h -{-# INLINABLE (^|$^) #-} -(^|$^) :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c -(^|$^) = qComps instance Functor (Eff r) where {-# INLINE fmap #-} - fmap f = bind (Val . f) + fmap f x = bind (Val . f) x instance Applicative (Eff r) where {-# INLINE pure #-} @@ -194,7 +167,7 @@ {-# INLINE return #-} {-# INLINE [2] (>>=) #-} return = pure - (>>=) = flip bind + m >>= f = bind f m {- Val _ >> m = m E q u >> m = E (q ^|> const m) u @@ -227,84 +200,115 @@ run (E _ union) = union `seq` error "extensible-effects: the impossible happened!" --- | Abstract the recursive 'relay' pattern, i.e., "somebody else's --- problem". +-- | Abstract the recursive 'relay' pattern, i.e., "somebody else's problem". class Relay k r where relay :: (v -> k) -> Union r v -> k instance Relay (Eff r w) r where + {-# INLINABLE relay #-} relay q u = E (singleK q) u instance Relay k r => Relay (s -> k) r where + {-# INLINABLE relay #-} relay q u s = relay (\x -> q x s) u --- | Respond to requests of type 't'. -class Handle t k where - handle :: (v -> k) -> t v -> k +-- | Respond to requests of type @t@. The handlers themselves are expressed in +-- open-recursion style. +class Handle t r a k where + handle :: (Eff r a -> k) -- ^ untied recursive knot + -> Arrs r v a -- ^ coroutine awaiting response + -> t v -- ^ request + -> k --- | A convenient pattern: given a request (in an open union), either --- handle it (using default Handler) or relay it. --- --- "Handle" implies that all requests of type @t@ are dealt with, --- i.e., @k@ (the response type) doesn't have @t@ as part of its --- effect list. The @Relay k r@ constraint ensures that @k@ is an --- effectful computation (with effectlist @r@). --- --- Note that we can only handle the leftmost effect type (a --- consequence of the 'OpenUnion' implementation. -handle_relay :: forall t k r a. Handle t k => Relay k r - => (a -> k) -- ^ return - -> Eff (t ': r) a -> k -handle_relay ret = handle_relay' ret handle + -- | A convenient pattern: given a request (in an open union), either handle + -- it (using default Handler) or relay it. + -- + -- "Handle" implies that all requests of type @t@ are dealt with, i.e., @k@ + -- (the response type) doesn't have @t@ as part of its effect list. The @Relay + -- k r@ constraint ensures that @k@ is an effectful computation (with + -- effectlist @r@). + -- + -- Note that we can only handle the leftmost effect type (a consequence of the + -- 'Data.OpenUnion' implementation. + handle_relay :: r ~ (t ': r') => Relay k r' + => (a -> k) -- ^ return + -> (Eff r a -> k) -- ^ untied recursive knot + -> Eff r a -> k + handle_relay ret step m = eff ret + (\q u -> case u of + U0 x -> handle step q x + U1 u' -> relay (qComp q step) u') + m + -- | Intercept the request and possibly respond to it, but leave it + -- unhandled. The @Relay k r@ constraint ensures that @k@ is an effectful + -- computation (with effectlist @r@). As such, the effect type @t@ will show + -- up in the response type @k@. There are two natural / commmon options for + -- @k@: the implicit effect domain (i.e., Eff r (f a)), or the explicit effect + -- domain (i.e., s1 -> s2 -> ... -> sn -> Eff r (f a s1 s2 ... sn)). + -- + -- There are three different ways in which we may want to alter behaviour: + -- + -- 1. __Before__: This work should be done before 'respond_relay' is called. + -- + -- 2. __During__: This work should be done by altering the handler being + -- passed to 'respond_relay'. This allows us to modify the requests "in + -- flight". + -- + -- 3. __After__: This work should be done be altering the @ret@ being passed + -- to 'respond_relay'. This allows us to overwrite changes or discard them + -- altogether. If this seems magical, note that we have the flexibility of + -- altering the target domain @k@. Specifically, the explicit domain + -- representation gives us access to the "effect" realm allowing us to + -- manipulate it directly. + respond_relay :: Member t r => Relay k r + => (a -> k) -- ^ return + -> (Eff r a -> k) -- ^ untied recursive knot + -> Eff r a -> k + respond_relay ret step m = eff ret + (\q u -> case u of + U0' x -> handle @t step q x + _ -> relay (qComp q step) u) + m -- | A less commonly needed variant with an explicit handler (instead --- of @Handle t k@ constraint). -handle_relay' :: forall t k r a. Relay k r - => (a -> k) -- ^ return - -> (forall v. (v -> k) -> t v -> k) -- ^ handler - -> Eff (t ': r) a -> k -handle_relay' ret h = fix step - where - step next = eff ret - (impureDecomp - (h `andThen` next) - (relay `andThen` next)) - --- | Intercept the request and possibly respond to it, but leave it --- unhandled. The @Relay k r@ constraint ensures that @k@ is an --- effectful computation (with effectlist @r@). As such, the effect --- type @t@ will show up in the response type @k@. -respond_relay :: Member t r => Relay k r - => (a -> k) - -> (forall v. (v -> k) -> t v -> k) +-- of @Handle t r a k@ constraint). +{-# INLINE handle_relay' #-} +handle_relay' :: r ~ (t ': r') => Relay k r' + => (forall v. (Eff r a -> k) -> Arrs r v a -> t v -> k) -- ^ handler + -> (a -> k) -- ^ return + -> (Eff r a -> k) -- ^ untied recursive knot -> Eff r a -> k -respond_relay ret h = fix step - where - step next = eff ret - (impurePrj - (h `andThen` next) - (relay `andThen` next)) +handle_relay' hdl ret step m = eff ret + (\q u -> case u of + U0 x -> hdl step q x + U1 u' -> relay (qComp q step) u') + m --- | A less common variant which uses the default 'handle' from the --- @Handle t k@ instance (in general, we may need to define new --- datatypes to call respond_relay with the default handler). -respond_relay' :: forall t k r a. (Member t r, Handle t k, Relay k r) - => (a -> k) +-- | Variant with an explicit handler (instead of @Handle t r a k@ +-- constraint). +{-# INLINE respond_relay' #-} +respond_relay' :: Member t r => Relay k r + => (forall v. (Eff r a -> k) -> Arrs r v a -> t v -> k) -- ^ handler + -> (a -> k) -- ^ return + -> (Eff r a -> k) -- ^ recursive knot -> Eff r a -> k -respond_relay' ret = respond_relay ret (handle @t) +respond_relay' hdl ret step m = eff ret + (\q u -> case u of + U0' x -> hdl step q x + _ -> relay (qComp q step) u) + m -- | Embeds a less-constrained 'Eff' into a more-constrained one. Analogous to -- MTL's 'lift'. raise :: Eff r a -> Eff (e ': r) a -raise = fix step - where - step next = eff pure - (\q -> ((E . (~^) . (qThen next)) q) . weaken) +raise (Val x) = pure x +raise (E q u) = E k (U1 u) + where k = qComps q raise {-# INLINE raise #-} -- ------------------------------------------------------------------------ -- | Lifting: emulating monad transformers newtype Lift m a = Lift { unLift :: m a } --- |A convenient alias to 'SetMember Lift (Lift m) r', which allows us +-- |A convenient alias to @SetMember Lift (Lift m) r@, which allows us -- to assert that the lifted type occurs ony once in the effect list. type Lifted m r = SetMember Lift (Lift m) r @@ -319,21 +323,21 @@ lift = send . Lift -- | Handle lifted requests by running them sequentially -instance Monad m => Handle (Lift m) (m k) where - handle k (Lift x) = x >>= k +instance Monad m => Handle (Lift m) r a (m k) where + handle step q (Lift x) = x >>= (step . (q ^$)) -- | The handler of Lift requests. It is meant to be terminal: we only -- allow a single Lifted Monad. Note, too, how this is different from -- other handlers. runLift :: Monad m => Eff '[Lift m] w -> m w -runLift = fix step +runLift m = fix step m where step :: Monad m => (Eff '[Lift m] w -> m w) -> Eff '[Lift m] w -> m w - step next = eff return - (impurePrj - (handle `andThen` next) - (\_ _ -> error "Impossible: Nothing to relay!") - ) + step next m' = eff return + (\q u -> case u of + U0' x -> handle next q x + _ -> error "Impossible: Nothing to relay!") + m' -- | Catching of dynamic exceptions -- See the problem in @@ -341,13 +345,14 @@ catchDynE :: forall e a r. (Lifted IO r, Exc.Exception e) => Eff r a -> (e -> Eff r a) -> Eff r a -catchDynE m eh = respond_relay return h m +catchDynE m eh = fix (respond_relay' h return) m where -- Polymorphic local binding: signature is needed - h :: Arr r v a -> Lift IO v -> Eff r a - h k (Lift em) = lift (Exc.try em) >>= either eh k + h :: (Eff r a -> Eff r a) -> Arrs r v a -> Lift IO v -> Eff r a + h step q (Lift em) = lift (Exc.try em) >>= either eh k + where k = step . (q ^$) --- | You need this when using 'catches'. +-- | You need this when using 'catchesDynE'. data HandlerDynE r a = forall e. (Exc.Exception e, Lifted IO r) => HandlerDynE (e -> Eff r a) diff --git a/src/Control/Eff/Logic.hs b/src/Control/Eff/Logic.hs deleted file mode 100644 --- a/src/Control/Eff/Logic.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE Safe #-} - --- | Logic primitives. See LogicT paper for details. -module Control.Eff.Logic where - -import Control.Monad -import Data.Function (fix) - --- | The MSplit primitive from LogicT paper. -class MSplit m where - -- | The laws for 'msplit' are: - -- - -- 1] msplit mzero == return Nothing - -- 2] msplit (return a `mplus` m) == return (Just(a, m)) - msplit :: m a -> m (Maybe (a, m a)) - --- | Embed a pure value into MSplit -withMSplit :: MonadPlus m => a -> m a -> m (Maybe (a, m a)) -withMSplit a rest = return (Just (a, rest)) --- The handlers are defined in terms of the specific non-determinism --- effects (instead of by way of a distinct MSplit handler - -reflect :: MonadPlus m => Maybe (a, m a) -> m a -reflect Nothing = mzero -reflect (Just (a,m)) = return a `mplus` m - --- Other committed choice primitives can be implemented in terms of msplit --- The following implementations are directly from the LogicT paper - --- | Soft-cut: non-deterministic if-then-else, aka Prolog's *-> --- Declaratively, --- ifte t th el = (t >>= th) `mplus` ((not t) >> el) --- However, t is evaluated only once. In other words, ifte t th el --- is equivalent to t >>= th if t has at least one solution. --- If t fails, ifte t th el is the same as el. --- --- Laws: --- 1] ifte (return a) th el == th a --- 2] ifte mzero th el == el --- 3] ifte (return a `mplus` m) th el == th a `mplus` (m >>= th) -ifte :: (MonadPlus m, MSplit m) - => m t -> (t -> m b) -> m b -> m b -ifte t th el = msplit t >>= check - where check Nothing = el - check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th) - --- | Another pruning operation (ifte is the other). This selects one --- solution out of possibly many. -once :: (MSplit m, MonadPlus m) => m b -> m b -once m = msplit m >>= check - where check Nothing = mzero - check (Just (sg1,_)) = return sg1 - --- | Negation as failure -gnot :: (MonadPlus m, MSplit m) => m b -> m () -gnot m = ifte (once m) (const mzero) (return ()) - --- | Fair (i.e., avoids starvation) disjunction. It obeys the --- following laws: --- --- 1] interleave mzero m == m --- 2] interleave (return a `mplus` m1) m2 == return a `mplus` (interleave m2 m1) --- --- corollary: --- interleave m mzero == m -interleave :: (MSplit m, MonadPlus m) => m b -> m b -> m b -interleave sg1 sg2 = - do r <- msplit sg1 - case r of - Nothing -> sg2 - Just (sg11,sg12) -> - (return sg11) `mplus` (interleave sg2 sg12) - --- | Fair (i.e., avoids starvation) conjunction. It obeys the --- following laws: --- --- 1] mzero >>- k == mzero --- 2] (return a `mplus` m) >>- k == interleave (k a) (m >>- k) -(>>-) :: (MonadPlus m, MSplit m) => m a -> (a -> m b) -> m b -sg >>- g = - do r <- msplit sg - case r of - Nothing -> mzero - Just (sg1 ,sg2) -> interleave (g sg1) (sg2 >>- g) - --- | Collect all solutions. This is from Hinze's 'Backtr' monad --- class. Unsurprisingly, this can be implemented in terms of msplit. --- --- TODO: use a more efficient data structure. -sols :: (MonadPlus m, MSplit m) => m a -> m [a] -sols m = (msplit m) >>= (fix step) [] where - step _ jq Nothing = return jq - step next jq (Just(a, ma)) = (msplit ma) >>= next (a:jq) diff --git a/src/Control/Eff/Logic/Core.hs b/src/Control/Eff/Logic/Core.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Logic/Core.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + +-- | Logic primitives. See @LogicT@ paper for details. +-- +-- * [@LogicT@] [LogicT - backtracking monad transformer with fair operations and pruning](http://okmij.org/ftp/Computation/monads.html#LogicT) +module Control.Eff.Logic.Core where + +import Control.Monad + +import Control.Eff +import Control.Eff.Exception + +import Data.Function (fix) + +-- | The MSplit primitive from LogicT paper. +class MSplit m where + -- | The laws for 'msplit' are: + -- + -- > msplit mzero = return Nothing + -- > msplit (return a `mplus` m) = return (Just(a, m)) + msplit :: m a -> m (Maybe (a, m a)) + +-- | Embed a pure value into MSplit +{-# INLINE withMSplit #-} +withMSplit :: MonadPlus m => a -> m a -> m (Maybe (a, m a)) +withMSplit a rest = return (Just (a, rest)) +-- The handlers are defined in terms of the specific non-determinism +-- effects (instead of by way of a distinct MSplit handler + +-- | Laws for 'reflect': +-- +-- > msplit (lift m >> mzero) >>= reflect = lift m >> mzero +-- > msplit (lift m `mplus` ma) >>= reflect = lift m `mplus` (msplit ma >>= reflect) +{-# INLINE reflect #-} +reflect :: MonadPlus m => Maybe (a, m a) -> m a +reflect Nothing = mzero +reflect (Just (a,m)) = return a `mplus` m + +-- Other committed choice primitives can be implemented in terms of msplit +-- The following implementations are directly from the LogicT paper + +-- | Soft-cut: non-deterministic if-then-else, aka Prolog's @*->@ +-- Declaratively, +-- +-- > ifte t th el = (t >>= th) `mplus` ((not t) >> el) +-- +-- However, @t@ is evaluated only once. In other words, @ifte t th el@ +-- is equivalent to @t >>= th@ if @t@ has at least one solution. +-- If @t@ fails, @ifte t th el@ is the same as @el@. Laws: +-- +-- > ifte (return a) th el = th a +-- > ifte mzero th el = el +-- > ifte (return a `mplus` m) th el = th a `mplus` (m >>= th) +ifte :: (MonadPlus m, MSplit m) + => m t -> (t -> m b) -> m b -> m b +ifte t th el = msplit t >>= check + where check Nothing = el + check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th) + +-- | Another pruning operation (ifte is the other). This selects one +-- solution out of possibly many. +once :: (MSplit m, MonadPlus m) => m b -> m b +once m = msplit m >>= check + where check Nothing = mzero + check (Just (sg1,_)) = return sg1 + +-- | Negation as failure +gnot :: (MonadPlus m, MSplit m) => m b -> m () +gnot m = ifte (once m) (const mzero) (return ()) + +-- | Fair (i.e., avoids starvation) disjunction. It obeys the +-- following laws: +-- +-- > interleave mzero m = m +-- > interleave (return a `mplus` m1) m2 = return a `mplus` (interleave m2 m1) +-- +-- corollary: +-- +-- > interleave m mzero = m +interleave :: (MSplit m, MonadPlus m) => m b -> m b -> m b +interleave sg1 sg2 = + do r <- msplit sg1 + case r of + Nothing -> sg2 + Just (sg11,sg12) -> + (return sg11) `mplus` (interleave sg2 sg12) + +-- | Fair (i.e., avoids starvation) conjunction. It obeys the +-- following laws: +-- +-- > mzero >>- k = mzero +-- > (return a `mplus` m) >>- k = interleave (k a) (m >>- k) +(>>-) :: (MonadPlus m, MSplit m) => m a -> (a -> m b) -> m b +sg >>- g = + do r <- msplit sg + case r of + Nothing -> mzero + Just (sg1 ,sg2) -> interleave (g sg1) (sg2 >>- g) + +-- | Collect all solutions. This is from Hinze's @Backtr@ monad +-- class. Unsurprisingly, this can be implemented in terms of msplit. +sols :: (Monad m, MSplit m) => m a -> m [a] +sols m = (msplit m) >>= (fix step) [] where + step _ jq Nothing = return jq + step next jq (Just(a, ma)) = (msplit ma) >>= next (a:jq) + +-- | Non-determinism with control (@cut@). +-- +-- For the explanation of cut, see Section 5 of Hinze ICFP 2000 paper: +-- +-- * [@Backtr@] [Deriving Backtracking Monad Transformers](https://dl.acm.org/citation.cfm?id=351240.351258) +-- +-- Hinze suggests expressing @cut@ in terms of @cutfalse@: +-- +-- > = return () `mplus` cutfalse +-- > where +-- > cutfalse :: m a +-- +-- satisfies the following laws: +-- +-- > cutfalse >>= k = cutfalse (F1) +-- > cutfalse | m = cutfalse (F2) +-- +-- (note: @m \``mplus`\` cutfalse@ is different from @cutfalse \``mplus`\` m@). +-- In other words, cutfalse is the left zero of both bind and mplus. +-- +-- Hinze also introduces the operation @`call` :: m a -> m a@ that +-- delimits the effect of cut: @`call` m@ executes m. If the cut is +-- invoked in m, it discards only the choices made since m was called. +-- Hinze postulates the axioms of `call`: +-- +-- > call false = false (C1) +-- > call (return a | m) = return a | call m (C2) +-- > call (m | cutfalse) = call m (C3) +-- > call (lift m >>= k) = lift m >>= (call . k) (C4) +-- +-- @`call` m@ behaves like @m@ except any cut inside @m@ has only a local effect, +-- he says. +-- +-- Hinze noted a problem with the \"mechanical\" derivation of backtracing +-- monad transformer with cut: no axiom specifying the interaction of +-- call with bind; no way to simplify nested invocations of call. +class Call r where + -- | Mapping @Backtr@ interface to 'MonadPlus' and using exceptions for + -- @cutfalse@, every instance should ensure that the following laws hold: + -- + -- > cutfalse `mplus` m = cutfalse --(F2) + -- > call mzero = mzero --(C1) + -- > call (return a `mplus` m) = return a `mplus` call m --(C2) + -- > call (m `mplus` cutfalse) = call m --(C3) + -- > call (lift m >>= k) = lift m >>= (call . k) --(C4) + call :: MonadPlus (Eff r) => Eff (Exc CutFalse : r) a -> Eff r a + +data CutFalse = CutFalse + +-- | We use exceptions for cutfalse +-- Therefore, the law @cutfalse >>= k = cutfalse@ +-- is satisfied automatically since all exceptions have the above property. +cutfalse :: Member (Exc CutFalse) r => Eff r a +cutfalse = throwError CutFalse + +-- | Prolog @cut@, taken from Hinze 2000 (Deriving backtracking monad +-- transformers). +(!) :: (Member (Exc CutFalse) r, MonadPlus (Eff r)) => Eff r () +(!) = return () `mplus` cutfalse + +-- | Case analysis for lists +{-# INLINE list #-} +list :: b -> (a -> [a] -> b) + -> [a] -> b +list z _ [] = z +list _ k (h:t) = k h t diff --git a/src/Control/Eff/Logic/Experimental.hs b/src/Control/Eff/Logic/Experimental.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Logic/Experimental.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module is for some experimental implementations and tinkering. Not +-- intended to be exposed or depended on. +module Control.Eff.Logic.Experimental where + +import Control.Eff +import Control.Eff.Extend +import Control.Eff.Exception +import Control.Eff.Logic.Core +import Control.Monad + +instance (MonadPlus (Eff (Exc CutFalse : r)), MSplit (Eff (Exc CutFalse : r))) + => Call r where + call m = loop m [] where + loop m' jq = case msplit m' of + Val Nothing -> next jq -- (C1) + Val (Just (x, q)) -> return x `mplus` next (q : jq) -- (C2) + E q u -> case u of + U0 (Exc CutFalse) -> next [] -- drop jq (F2) + U1 _ -> loop (E q u >>= reflect) jq -- (C4?) + --_ -> loop m' jq + next jq = list mzero loop jq -- (C3?) + {- + call m = loop (msplit m) [] where + loop (Val Nothing) jq = next jq -- (C1) + loop (Val (Just (x, q))) jq = return x `mplus` next (q : jq) -- (C2) + loop (E q u) jq = case u of + U0 (Exc CutFalse) -> next [] -- drop jq (F2) + _ -> loop (E q u) jq -- (C4?) + + next [] = mzero + next (h:t) = loop (msplit h) t -- (C3?) + -} diff --git a/src/Control/Eff/Logic/NDet.hs b/src/Control/Eff/Logic/NDet.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/Logic/NDet.hs @@ -0,0 +1,229 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE Safe #-} +-- The following is needed to define MonadPlus instance. It is decidable +-- (there is no recursion!), but GHC cannot see that. +{-# LANGUAGE UndecidableInstances #-} +-- The following is needed for pattern-synonym bug in ghc 8.2 +{-# LANGUAGE CPP #-} + +-- | Nondeterministic choice effect via MPlus interface directly. In order to +-- get an understanding of what nondeterministic choice entails the following +-- papers are recommended: +-- +-- * [@LogicT@] [LogicT - backtracking monad transformer with fair operations and pruning](http://okmij.org/ftp/Computation/monads.html#LogicT) +-- * [@Backtr@] [Deriving Backtracking Monad Transformers](https://dl.acm.org/citation.cfm?id=351240.351258) +-- +-- __TODO__: investigate Fusion regd msplit and associated functions. +module Control.Eff.Logic.NDet ( + -- * Main interface + NDet + , withNDet + , left, right + , choose + , makeChoice + , makeChoiceA + , module Control.Eff.Logic.Core + -- * Additional functions for comparison + , msplit' + , msplit'_manual + , makeChoiceA_manual + , makeChoiceA0 + ) where + +import Control.Eff +import Control.Eff.Extend +import Control.Eff.Logic.Core +import Control.Eff.Exception + +import Control.Applicative +import Control.Monad +import Control.Monad.Base +import Control.Monad.Trans.Control +import Data.Function (fix) + +-- | An implementation of non-deterministic choice aka backtracking. The two +-- requests we need to support are: @false@, @(|)@. We map this to the +-- 'MonadPlus' (or 'Alternative') interface: @MZero@ stands for @false@, and +-- @MPlus@ stands for @(|)@. +-- +-- This creates a branching structure with a fanout of @2@, resulting in @mplus@ +-- node being visited approximately @2x@ (in general, for a fanout of @f@ we'll +-- have the type of internal node being invoked @f/(f-1)@ times). +data NDet a where + MZero :: NDet a + MPlus :: NDet Bool + +-- | How to embed a pure value in non-deterministic context +{-# INLINE withNDet #-} +withNDet :: Alternative f => Monad m => a -> m (f a) +withNDet x = return (pure x) +-- | The left branch +{-# INLINE left #-} +left :: Arrs r Bool a -> Eff r a +left q = q ^$ True +-- | The right branch +{-# INLINE right #-} +right :: Arrs r Bool a -> Eff r a +right q = q ^$ False +-- | Given a callback and 'NDet' requests respond to them. Note that this makes +-- explicit that we rely on @f@ to have enough room to store all possibilities. +instance Alternative f => Handle NDet r a (Eff r' (f w)) where + handle _ _ MZero = return empty + handle step q MPlus = liftM2 (<|>) (step $ left q) (step $ right q) + +instance Member NDet r => Alternative (Eff r) where + empty = mzero + (<|>) = mplus + +-- | Mapping of 'NDet' requests to 'MonadPlus'. We obey the following laws +-- (taken from the @Backtr@ and @LogicT papers): +-- +-- > mzero >>= f = mzero -- (L1) +-- > mzero `mplus` m = m -- (L2) +-- > m `mplus` mzero = m -- (L3) +-- > m `mplus` (n `mplus` o) = (m `mplus` n) `mplus` o -- (L4) +-- > (m `mplus` n) >>= k = (m >>= k) `mplus` (n >>= k) -- (L5) +-- +-- - @L1@ is the left-zero law for 'mzero' +-- - @L2, L3, L4@ are the @Monoid@ laws +-- +-- __NOTE__ that we do __not__ obey the right-zero law for +-- 'mzero'. Specifically, we do __not__ obey: +-- +-- > m >> mzero = mzero +instance Member NDet r => MonadPlus (Eff r) where + mzero = send MZero + -- | Applying L2 and L3 +#if __GLASGOW_HASKELL__ < 804 + mplus (E _ u) m2 | Just MZero <- prj u = m2 + mplus m1 (E _ u) | Just MZero <- prj u = m1 +#else + mplus (E _ (U0' MZero)) m2 = m2 + mplus m1 (E _ (U0' MZero)) = m1 +#endif + mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2 + +instance ( MonadBase m m + , LiftedBase m r + ) => MonadBaseControl m (Eff (NDet ': r)) where + type StM (Eff (NDet ': r)) a = StM (Eff r) [a] + liftBaseWith f = raise $ liftBaseWith $ \runInBase -> + f (runInBase . makeChoice) + restoreM x = do lst :: [a] <- raise (restoreM x) + choose lst + +-- | @'choose' lst@ non-deterministically chooses one value from the +-- @lst@. @'choose' []@ thus corresponds to failure. +choose :: Member NDet r => [a] -> Eff r a +choose lst = msum $ map return lst + +-- | An interpreter: The following is very simple, but leaks a lot of memory The +-- cause probably is mapping every failure to empty It takes then a lot of timne +-- and space to store those empty. When there aren't a lot of failures, this is +-- comparable to 'makeChoiceA'. +makeChoiceA0 :: Alternative f => Eff (NDet ': r) a -> Eff r (f a) +makeChoiceA0 = fix (handle_relay withNDet) + +-- | More performant handler; uses reified job queue +instance Alternative f => Handle NDet r a ([Eff r a] -> Eff r' (f w)) where + handle step _ MZero jq = next step jq + handle step q MPlus jq = next step (left q : right q : jq) +-- instance Handle NDet r a (k -> [Eff r a] -> k) where +-- handle step _ MZero z jq = list z (flip step z) jq +-- handle step q MPlus z jq = list z (flip step z) (left q : right q : jq) + +{-# INLINE next #-} +-- | Progressing the cursor in a reified job queue. +next :: Alternative f => Monad m + => (t -> [t] -> m (f a)) + -> [t] -> m (f a) +next k jq = list (return empty) k jq + +-- | Optimized implementation, faster and taking less memory. The benefit of the +-- effect framework is that we can have many interpreters. +makeChoiceA :: Alternative f => Eff (NDet ': r) a -> Eff r (f a) +makeChoiceA m' = loop m' [] where + loop m = fix (handle_relay @NDet ret) m + -- single result; optimization: drop spurious empty + ret x [] = withNDet x + -- definite result and perhaps some others + ret x (h:t) = liftM2 (<|>) (withNDet x) (loop h t) + +-- | A different implementation, more involved, but similar complexity to +-- 'makeChoiceA'. +makeChoiceA_manual :: Alternative f => Eff (NDet ': r) a -> Eff r (f a) +makeChoiceA_manual m = loop m [] where + -- single result; optimization: drop spurious empty + loop (Val x) [] = withNDet x + -- definite result and perhaps some others + loop (Val x) (h:t) = liftM2 (<|>) (withNDet x) (loop h t) + loop (E q u) jq = case decomp u of + Right MZero -> next loop jq + Right MPlus -> loop (k True) (k False : jq) + Left u0 -> relay (loop . k) u0 jq + where + k = (q ^$) + +-- | Same as 'makeChoiceA', except it has the type hardcoded. +-- Required for 'MonadBaseControl' instance. +makeChoice :: Eff (NDet ': r) a -> Eff r [a] +makeChoice = makeChoiceA + +-- | We implement LogicT, the non-determinism reflection, of which soft-cut is +-- one instance. See the LogicT paper for an explanation. +instance Member NDet r => MSplit (Eff r) where + msplit = msplit' + +-- | The implementation of 'MSplit'. Exported as a standalone to make +-- testing/comparison easier. +{-# INLINE msplit' #-} +msplit' :: Member NDet r => Eff r a -> Eff r (Maybe (a, Eff r a)) +msplit' m = fix (respond_relay @NDet (\x jq -> withMSplit x (msum jq))) m [] + +-- | A different implementation, more involved, but similar complexity to +-- 'msplit''. +{-# INLINE msplit'_manual #-} +msplit'_manual :: Member NDet r => Eff r a -> Eff r (Maybe (a, Eff r a)) +msplit'_manual m' = loop m' [] where + -- definite result and perhaps some others + loop (Val x) jq = withMSplit x (msum jq) + -- not yet definite answer + loop (E q u) jq = case u of + -- try other choices, if any + U0' MZero -> next loop jq + -- try left options; add right to job queue + U0' MPlus -> loop (k True) (k False : jq) + _ -> relay (loop . k) u jq + where + k x = q ^$ x + +-- | The call interpreter -- it is like reify . reflect with a twist. Compare +-- this implementation with the huge implementation of call in Hinze 2000 +-- (Figure 9). Each clause corresponds to the axiom of call or cutfalse. All +-- axioms are covered. +-- +-- The code clearly expresses the intuition that call watches the choice points +-- of its argument computation. When it encounteres a cutfalse request, it +-- discards the remaining choicepoints. It completely handles CutFalse effects +-- but not non-determinism +instance Member NDet r => Call r where + call m = loop m [] where + loop (Val x) jq = return x `mplus` nxt jq -- (C2) + loop (E _ (U0 (Exc CutFalse))) _ = nxt [] -- drop jq (F2) + loop (E q (U1 u)) jq = case u of + U0' MZero -> nxt jq -- (C1) + U0' MPlus -> nxt (left q : right q : jq) -- (C3) + _ -> relay (loop . (q ^$)) u jq -- (C4) + + nxt jq = list mzero loop jq diff --git a/src/Control/Eff/NdetEff.hs b/src/Control/Eff/NdetEff.hs deleted file mode 100644 --- a/src/Control/Eff/NdetEff.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE Safe #-} --- The following is needed to define MonadPlus instance. It is decidable --- (there is no recursion!), but GHC cannot see that. -{-# LANGUAGE UndecidableInstances #-} - --- | Another implementation of nondeterministic choice effect -module Control.Eff.NdetEff ( - NdetEff - , withNdetEff - , left, right - , makeChoiceA - , makeChoiceA0 - , makeChoiceLst - , msplit1 - , module Control.Eff.Logic - ) where - -import Control.Eff -import Control.Eff.Extend -import Control.Eff.Logic - -import Control.Applicative -import Control.Monad -import Control.Monad.Base -import Control.Monad.Trans.Control -import Data.Foldable (foldl') - --- | A different implementation, more directly mapping to MonadPlus --- interface -data NdetEff a where - MZero :: NdetEff a - MPlus :: NdetEff Bool - --- | How to embed a pure value in non-deterministic context -withNdetEff :: Alternative f => Monad m => a -> m (f a) -withNdetEff = return . pure --- | The left branch -left :: (Bool -> k) -> k -left k = k True --- | The right branch -right :: (Bool -> k) -> k -right k = k False --- | Given a callback and NdetEff requests respond to them -instance (Alternative f, Monad m) => Handle NdetEff (m (f a)) where - handle _ MZero = return empty - handle k MPlus = liftM2 (<|>) (left k) (right k) - -instance Member NdetEff r => Alternative (Eff r) where - empty = mzero - (<|>) = mplus - -instance Member NdetEff r => MonadPlus (Eff r) where - mzero = send MZero - mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2 - -instance ( MonadBase m m - , LiftedBase m r - ) => MonadBaseControl m (Eff (NdetEff ': r)) where - type StM (Eff (NdetEff ': r)) a = StM (Eff r) [a] - liftBaseWith f = raise $ liftBaseWith $ \runInBase -> - f (runInBase . makeChoiceLst) - restoreM x = do lst :: [a] <- raise (restoreM x) - foldl' (\r a -> r <|> pure a) mzero lst - --- | An interpreter --- The following is very simple, but leaks a lot of memory --- The cause probably is mapping every failure to empty --- It takes then a lot of timne and space to store those empty -makeChoiceA0 :: Alternative f => Eff (NdetEff ': r) a -> Eff r (f a) -makeChoiceA0 = handle_relay withNdetEff - --- | A different implementation, more involved but faster and taking --- much less (100 times) less memory. --- The benefit of the effect framework is that we can have many --- interpreters. -makeChoiceA :: Alternative f => Eff (NdetEff ': r) a -> Eff r (f a) -makeChoiceA m = loop [] m where - loop [] (Val x) = withNdetEff x - loop (h:t) (Val x) = liftM2 (<|>) (withNdetEff x) (loop t h) - loop jq (E q u) = case decomp u of - Right MZero -> case jq of - [] -> return empty - (h:t) -> loop t h - Right MPlus -> loop (q ^$ False : jq) (q ^$ True) - Left u0 -> E (q ^|$^ (loop jq)) u0 - --- | Same as makeChoiceA, except it has the type hardcoded. --- Required for MonadBaseControl instance. -makeChoiceLst :: Eff (NdetEff ': r) a -> Eff r [a] -makeChoiceLst = makeChoiceA - --- | We actually implement LogicT, the non-determinism reflection, of --- which soft-cut is one instance. Straightforward implementation --- using 'respond_relay'. See the LogicT paper for an explanation. -instance Member NdetEff r => MSplit (Eff r) where - msplit = respond_relay (flip withMSplit empty) $ \k x -> case x of - MZero -> return Nothing -- definite failure - MPlus -> left k >>= \r -> case r of -- check left first - Nothing -> right k -- failure, continue exploring - Just(a, m) -> withMSplit a (m <|> (right k >>= reflect)) -- definite success - --- | A different implementation, more involved. Unclear whether this --- is faster or not. -msplit1 :: Member NdetEff r => Eff r a -> Eff r (Maybe (a, Eff r a)) -msplit1 = loop [] - where - -- single result - loop [] (Val x) = withMSplit x mzero - -- definite result and perhaps some others - loop jq (Val x) = withMSplit x (msum jq) - -- not yet definite answer - loop jq (E q u) = case prj u of - Just MZero -> case jq of - -- no futher choices - [] -> return Nothing - -- other choices remain, try them - (j:jqT) -> loop jqT j - Just MPlus -> loop ((q ^$ False):jq) (q ^$ True) - _ -> E (q ^|$^ (loop jq)) u diff --git a/src/Control/Eff/Operational.hs b/src/Control/Eff/Operational.hs --- a/src/Control/Eff/Operational.hs +++ b/src/Control/Eff/Operational.hs @@ -18,9 +18,11 @@ -- $usage ) where -import Control.Eff +import Control.Eff as E import Control.Eff.Extend +import Data.Function (fix) + -- | Lift values to an effect. -- You can think this is a generalization of @Lift@. data Program instr v where @@ -33,8 +35,10 @@ withOperational :: a -> Intrprtr f r -> Eff r a withOperational x _ = return x -- | Given a continuation and a program, interpret it -instance Handle (Program f) (Intrprtr f r -> Eff r a) where - handle k (Singleton instr) i = (runIntrprtr i) instr >>= (flip k i) +-- Usually, we have @r ~ [Program f : r']@ +instance Handle (Program f) r a (Intrprtr f r' -> Eff r' a) where + handle step q (Singleton instr) i = (runIntrprtr i) instr >>= + \x -> step (q ^$ x) i -- | Lift a value to a monad. singleton :: (Member (Program instr) r) => instr a -> Eff r a @@ -42,7 +46,7 @@ -- | Convert values using given interpreter to effects. runProgram :: forall f r a. (forall x. f x -> Eff r x) -> Eff (Program f ': r) a -> Eff r a -runProgram advent m = handle_relay withOperational m (Intrprtr advent) +runProgram advent m = fix (handle_relay withOperational) m (Intrprtr advent) -- $usage -- @@ -55,6 +59,6 @@ --main :: IO () --main = do -- let comp = 'runProgram' adventPure prog --- putStrLn . fst . 'run' . 'runMonoidWriter' $ 'evalState' comp [\"foo\",\"bar\"] +-- putStrLn . fst . 'run' . 'E.Writer.Strict.runMonoidWriter' $ 'E.State.Strict.evalState' comp [\"foo\",\"bar\"] -- 'runLift' $ 'runProgram' adventIO prog -- @ diff --git a/src/Control/Eff/Reader/Lazy.hs b/src/Control/Eff/Reader/Lazy.hs --- a/src/Control/Eff/Reader/Lazy.hs +++ b/src/Control/Eff/Reader/Lazy.hs @@ -23,13 +23,15 @@ import Control.Monad.Base import Control.Monad.Trans.Control +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | The Reader monad -- -- The request for a value of type e from the current environment -- This can be expressed as a GADT because the type of values -- returned in response to a (Reader e a) request is not any a; --- we expect in reply the value of type 'e', the value from the +-- we expect in reply the value of type @e@, the value from the -- environment. So, the return type is restricted: 'a ~ e' data Reader e v where Ask :: Reader e e @@ -52,8 +54,8 @@ withReader x _ = return x -- | Given a value to read, and a callback, how to respond to -- requests. -instance Handle (Reader e) (e -> r) where - handle k Ask e = k e e +instance Handle (Reader e) r a (e -> k) where + handle step q Ask e = step (q ^$ e) e -- | Get the current value from a Reader. -- The signature is inferred (when using NoMonomorphismRestriction). @@ -63,7 +65,7 @@ -- | The handler of Reader requests. The return type shows that all Reader -- requests are fully handled. runReader :: forall e r w. e -> Eff (Reader e ': r) w -> Eff r w -runReader e m = handle_relay withReader m e +runReader e m = fix (handle_relay withReader) m e -- | Locally rebind the value in the dynamic environment This function is like a -- relay; it is both an admin for Reader requests, and a requestor of them. @@ -71,8 +73,8 @@ (e -> e) -> Eff r a -> Eff r a local f m = do e <- reader f - respond_relay' @(Reader e) withReader m e - -- or we could redefine handle and pass it to respond_relay + (fix (respond_relay @(Reader e) withReader)) m e + -- note similarity between 'local' and 'State.Lazy.transactionState' -- | Request the environment value using a transformation function. reader :: (Member (Reader e) r) => (e -> a) -> Eff r a diff --git a/src/Control/Eff/Reader/Strict.hs b/src/Control/Eff/Reader/Strict.hs --- a/src/Control/Eff/Reader/Strict.hs +++ b/src/Control/Eff/Reader/Strict.hs @@ -24,13 +24,15 @@ import Control.Monad.Base import Control.Monad.Trans.Control +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | The Reader monad -- -- The request for a value of type e from the current environment -- This can be expressed as a GADT because the type of values -- returned in response to a (Reader e a) request is not any a; --- we expect in reply the value of type 'e', the value from the +-- we expect in reply the value of type @e@, the value from the -- environment. So, the return type is restricted: 'a ~ e' data Reader e v where Ask :: Reader e e @@ -53,8 +55,8 @@ withReader x _ = return x -- | Given a value to read, and a callback, how to respond to -- requests. -instance Handle (Reader e) (e -> r) where - handle k Ask e = k e e +instance Handle (Reader e) r a (e -> k) where + handle step q Ask e = step (q ^$ e) e -- | Get the current value from a Reader. -- The signature is inferred (when using NoMonomorphismRestriction). @@ -64,7 +66,7 @@ -- | The handler of Reader requests. The return type shows that all Reader -- requests are fully handled. runReader :: e -> Eff (Reader e ': r) w -> Eff r w -runReader !e m = handle_relay withReader m e +runReader !e m = fix (handle_relay withReader) m e -- | Locally rebind the value in the dynamic environment This function is like a -- relay; it is both an admin for Reader requests, and a requestor of them. @@ -72,8 +74,8 @@ (e -> e) -> Eff r a -> Eff r a local f m = do e <- reader f - respond_relay' @(Reader e) withReader m e - -- or we could redefine handle and pass it to respond_relay + (fix (respond_relay @(Reader e) withReader)) m e + -- note similarity between 'local' and 'State.Strict.transactionState' -- | Request the environment value using a transformation function. reader :: (Member (Reader e) r) => (e -> a) -> Eff r a diff --git a/src/Control/Eff/State/Lazy.hs b/src/Control/Eff/State/Lazy.hs --- a/src/Control/Eff/State/Lazy.hs +++ b/src/Control/Eff/State/Lazy.hs @@ -21,6 +21,8 @@ import Control.Monad.Base import Control.Monad.Trans.Control +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | State, lazy -- @@ -49,10 +51,10 @@ withState x s = return (x, s) -- | Handle 'State s' requests -instance Handle (State s) (s -> r) where - handle k sreq s = case sreq of - Get -> k s s - Put s' -> k () s' +instance Handle (State s) r a (s -> k) where + handle step q sreq s = case sreq of + Get -> step (q ^$ s) s + Put s' -> step (q ^$ ()) s' instance ( MonadBase m m , LiftedBase m r @@ -89,21 +91,11 @@ -- inline get/put, even if I put the INLINE directives and play with phases. -- (Inlining works if I use 'inline' explicitly). --- | Run a state effect. compared to the @runState@ function, this is --- implemented naively and is expected to perform slower. -runState' :: s -> Eff (State s ': r) a -> Eff r (a, s) -runState' s m = handle_relay withState m s - --- | Run a State effect. This variant is a bit optimized compared to --- @runState'@. +-- | Run a State effect runState :: s -- ^ Initial state -> Eff (State s ': r) a -- ^ Effect incorporating State -> Eff r (a, s) -- ^ Effect containing final state and a return value -runState s (Val x) = return (x,s) -runState s (E q u) = case decomp u of - Right Get -> runState s (q ^$ s) - Right (Put s1) -> runState s1 (q ^$ ()) - Left u1 -> E (singleK (\x -> runState s (q ^$ x))) u1 +runState s m = fix (handle_relay withState) m s -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r () @@ -133,20 +125,17 @@ => TxStateT s -> Eff r a -> Eff r a transactionState _ m = do s <- get - (respond_relay' @(State s) (withTxState @s)) m s + (fix $ respond_relay @(State s) (withTxState @s)) m s -- | A different representation of State: decomposing State into mutation -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones. Thus we define a handler for two effects together. runStateR :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) -runStateR = loop +runStateR = flip loop where - loop :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) - loop s (Val x) = x `withState` s - loop s (E q u) = case decomp u of - Right (Tell w) -> handle k (Put w) s - Left u1 -> case decomp u1 of - Right Ask -> handle k Get s - Left u2 -> relay k u2 s - where k = connect loop q - connect nxt q = \s x -> qComp q (nxt x) s + loop :: Eff (Writer s ': Reader s ': r) a -> s -> Eff r (a, s) + loop (Val x) = withState x + loop (E q u) = case u of + U0 (Tell w) -> handle loop q (Put w) + U1 (U0 Ask) -> handle loop q Get + U1 (U1 u') -> relay (qComp q loop) u' diff --git a/src/Control/Eff/State/OnDemand.hs b/src/Control/Eff/State/OnDemand.hs --- a/src/Control/Eff/State/OnDemand.hs +++ b/src/Control/Eff/State/OnDemand.hs @@ -21,6 +21,8 @@ import Control.Monad.Base import Control.Monad.Trans.Control +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | State, lazy (i.e., on-demand) -- @@ -34,11 +36,12 @@ Delay :: Eff '[OnDemandState s] a -> OnDemandState s a -- Eff as a transformer -- | Given a continuation, respond to requests -instance Handle (OnDemandState s) (s -> r) where - handle k Get s = k s s - handle k (Put s) _ = k () s - handle k (Delay m) s = let ~(x, s') = run $ handle_relay S.withState m s - in k x s' +instance Handle (OnDemandState s) r a (s -> k) where + handle step q sreq s = case sreq of + Get -> step (q ^$ s) s + Put s' -> step (q ^$ ()) s' + Delay m -> let ~(x, s') = run $ (fix (handle_relay S.withState)) m s + in step (q ^$ x) s' instance ( MonadBase m m , LiftedBase m r @@ -79,21 +82,11 @@ onDemand :: Member (OnDemandState s) r => Eff '[OnDemandState s] v -> Eff r v onDemand = send . Delay -runState' :: s -> Eff (OnDemandState s ': r) w -> Eff r (w,s) -runState' s m = handle_relay S.withState m s - --- Since State is so frequently used, we optimize it a bit -- | Run a State effect runState :: s -- ^ Initial state -> Eff (OnDemandState s ': r) w -- ^ Effect incorporating State -> Eff r (w,s) -- ^ Effect containing final state and a return value -runState s (Val x) = S.withState x s -runState s0 (E q u0) = case decomp u0 of - Right Get -> runState s0 (q ^$ s0) - Right (Put s1) -> runState s1 (q ^$ ()) - Right (Delay m1) -> let ~(x,s1) = run $ runState s0 m1 - in runState s1 (q ^$ x) - Left u -> E (singleK (\x -> runState s0 (q ^$ x))) u +runState s m = fix (handle_relay S.withState) m s -- | Transform the state with a function. modify :: (Member (OnDemandState s) r) => (s -> s) -> Eff r () @@ -112,49 +105,47 @@ -- existing ones. Thus we define a handler for two effects together. runStateR :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s) runStateR s (Val x) = S.withState x s -runStateR s (E q u) = case decomp u of - Right (Tell w) -> handle k (S.Put w) s - Left u1 -> case decomp u1 of - Right Ask -> handle k S.Get s - Left u2 -> relay k u2 s - where k s' x = qComp q (runStateR x) s' +runStateR s (E q u) = case u of + U0 (Tell w) -> handle loop q (S.Put w) s + U1 (U0 Ask) -> handle loop q S.Get s + U1 (U1 u') -> relay (qComp q loop) u' s + where loop = flip runStateR -- | Backwards state -- The overall state is represented with two attributes: the inherited -- getAttr and the synthesized putAttr. -- At the root node, putAttr becomes getAttr, tying the knot. --- As usual, the inherited attribute is the argument (i.e., the `environment') +-- As usual, the inherited attribute is the argument (i.e., the @environment@) -- and the synthesized is the result of the handler |go| below. runStateBack0 :: Eff '[OnDemandState s] a -> (a,s) runStateBack0 m = - let (x,s) = go s m in + let (x,s) = go m s in (x,s) where - go :: s -> Eff '[OnDemandState s] a -> (a,s) - go s (Val x) = (x,s) - go s0 (E q u) = case decomp u of - Right Get -> go s0 $ (q ^$ s0) - Right (Put s1) -> let ~(x,sp) = go sp $ (q ^$ ()) in (x,s1) - Right (Delay m1) -> let ~(x,s1) = go s0 m1 in go s1 $ (q ^$ x) - Left _ -> error "Impossible happened: Union []" + go :: Eff '[OnDemandState s] a -> s -> (a,s) + go (Val x) s = (x,s) + go (E q u) s0 = case decomp u of + Right Get -> k s0 s0 + Right (Put s1) -> let ~(x,sp) = k () sp in (x,s1) + Right (Delay m1) -> let ~(x,s1) = go m1 s0 in k x s1 + Left _ -> error "Impossible happened: Nothing to relay!" + where + k = qComp q go -- | Another implementation, exploring Haskell's laziness to make putAttr -- also technically inherited, to accumulate the sequence of -- updates. This implementation is compatible with deep handlers, and --- lets us play with different notions of `backwardness' +-- lets us play with different notions of backwardness. runStateBack :: Eff '[OnDemandState s] a -> (a,s) runStateBack m = - let (x,(_sg,sp)) = run $ go (sp,[]) m in + let (x,(_,sp)) = run $ go m (sp,[]) in (x,head sp) where - go :: ([s],[s]) -> Eff '[OnDemandState s] a -> Eff '[] (a,([s],[s])) - go s m' = handle_relay' S.withState - (\k req ss0@(sg,sp) -> case req of - Get -> k (head sg) ss0 - Put s1 -> k () (tail sg,sp++[s1]) - Delay m1 -> let ~(x,ss1) = run $ go ss0 m1 - in k x ss1) - m' s + go :: Eff '[OnDemandState s] a -> ([s],[s]) -> Eff '[] (a,([s],[s])) + go = fix (handle_relay' h S.withState) + h step q Get s0@(sg, _) = step (q ^$ head sg) s0 + h step q (Put s1) (sg, sp) = step (q ^$ ()) (tail sg,sp++[s1]) + h step q (Delay m1) s0 = let ~(x,s1) = run $ go m1 s0 in step (q ^$ x) s1 --- ^ A different notion of `backwards' is realized if we change the Put --- handler slightly. How? +-- ^ A different notion of backwards is realized if we change the Put handler +-- slightly. How? diff --git a/src/Control/Eff/State/Strict.hs b/src/Control/Eff/State/Strict.hs --- a/src/Control/Eff/State/Strict.hs +++ b/src/Control/Eff/State/Strict.hs @@ -22,6 +22,8 @@ import Control.Monad.Base import Control.Monad.Trans.Control +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | State, strict -- @@ -50,10 +52,10 @@ withState x s = return (x, s) -- | Handle 'State s' requests -instance Handle (State s) (s -> r) where - handle k sreq s = case sreq of - Get -> k s s - Put s' -> k () s' +instance Handle (State s) r a (s -> k) where + handle step q sreq s = case sreq of + Get -> step (q ^$ s) s + Put s' -> step (q ^$ ()) s' instance ( MonadBase m m , LiftedBase m r @@ -91,19 +93,11 @@ -- inline get/put, even if I put the INLINE directives and play with phases. -- (Inlining works if I use 'inline' explicitly). -runState' :: forall s r a. s -> Eff (State s ': r) a -> Eff r (a, s) -runState' !s m = handle_relay withState m s - --- Since State is so frequently used, we optimize it a bit -- | Run a State effect runState :: s -- ^ Initial state -> Eff (State s ': r) a -- ^ Effect incorporating State -> Eff r (a, s) -- ^ Effect containing final state and a return value -runState !s (Val x) = withState x s -runState !s (E q u) = case decomp u of - Right Get -> runState s (q ^$ s) - Right (Put s1) -> runState s1 (q ^$ ()) - Left u1 -> E (qComps q (runState s)) u1 +runState !s m = fix (handle_relay withState) m s -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r () @@ -133,19 +127,17 @@ => TxState s -> Eff r a -> Eff r a transactionState _ m = do s <- get - (respond_relay' @(State s) (withTxState @s)) m s + (fix $ respond_relay @(State s) (withTxState @s)) m s -- | A different representation of State: decomposing State into mutation -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones. Thus we define a handler for two effects together. runStateR :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) -runStateR !s m = loop s m +runStateR !s m = loop m s where - loop :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s) - loop s0 (Val x) = x `withState` s0 - loop s0 (E q u) = case decomp u of - Right (Tell w) -> handle k (Put w) s0 - Left u1 -> case decomp u1 of - Right Ask -> handle k Get s0 - Left u2 -> relay k u2 s0 - where k s' x = qComp q (loop x) s' + loop :: Eff (Writer s ': Reader s ': r) a -> s -> Eff r (a, s) + loop (Val x) = withState x + loop (E q u) = case u of + U0 (Tell w) -> handle loop q (Put w) + U1 (U0 Ask) -> handle loop q Get + U1 (U1 u') -> relay (qComp q loop) u' diff --git a/src/Control/Eff/Trace.hs b/src/Control/Eff/Trace.hs --- a/src/Control/Eff/Trace.hs +++ b/src/Control/Eff/Trace.hs @@ -23,8 +23,8 @@ withTrace = return -- | Given a callback and request, respond to it -instance Handle Trace (IO k) where - handle k (Trace s) = putStrLn s >> k () +instance Handle Trace r a (IO k) where + handle step q (Trace s) = putStrLn s >> step (q ^$ ()) -- | Print a string as a trace. trace :: Member Trace r => String -> Eff r () @@ -35,6 +35,6 @@ runTrace :: Eff '[Trace] w -> IO w runTrace = fix step where step next = eff return - (impureDecomp - (handle `andThen` next) - (\_ _ -> error "Impossible: Nothing to relay!")) + (\q u -> case u of + U0 x -> handle next q x + _ -> error "Impossible: Nothing to relay!") diff --git a/src/Control/Eff/Writer/Lazy.hs b/src/Control/Eff/Writer/Lazy.hs --- a/src/Control/Eff/Writer/Lazy.hs +++ b/src/Control/Eff/Writer/Lazy.hs @@ -37,6 +37,8 @@ import Data.Monoid #endif +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | The Writer monad -- @@ -53,8 +55,8 @@ withWriter x empty _append = return (x, empty) -- | Given a value to write, and a callback (which includes empty and -- append), respond to requests. -instance Monad m => Handle (Writer w) (b -> (w -> b -> b) -> m (a, b)) where - handle k (Tell w) e append = k () e append >>= +instance Monad m => Handle (Writer w) r a (b -> (w -> b -> b) -> m (a, b)) where + handle step q (Tell w) e append = step (q ^$ ()) e append >>= \(x, l) -> return (x, w `append` l) instance ( MonadBase m m @@ -73,16 +75,16 @@ -- | Transform the state being produced. censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a -censor f = respond_relay return h +censor f = fix (respond_relay' h return) where - h :: (v -> Eff r b) -> Writer w v -> Eff r b - h k (Tell w) = tell (f w) >>= k + h :: (Eff r b -> Eff r b) -> Arrs r v b -> Writer w v -> Eff r b + h step q (Tell w) = tell (f w) >>= \x -> step (q ^$ x) -- | Handle Writer requests, using a user-provided function to accumulate -- values, hence no Monoid constraints. runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b) -runWriter accum b m = handle_relay withWriter m b accum +runWriter accum b m = fix (handle_relay withWriter) m b accum -- | Handle Writer requests, using a List to accumulate values. runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w]) diff --git a/src/Control/Eff/Writer/Strict.hs b/src/Control/Eff/Writer/Strict.hs --- a/src/Control/Eff/Writer/Strict.hs +++ b/src/Control/Eff/Writer/Strict.hs @@ -37,6 +37,8 @@ import Data.Monoid #endif +import Data.Function (fix) + -- ------------------------------------------------------------------------ -- | The Writer monad -- @@ -53,8 +55,8 @@ withWriter x empty _append = return (x, empty) -- | Given a value to write, and a callback (which includes empty and -- append), respond to requests. -instance Monad m => Handle (Writer w) (b -> (w -> b -> b) -> m (a, b)) where - handle k (Tell w) e append = k () e append >>= +instance Monad m => Handle (Writer w) r a (b -> (w -> b -> b) -> m (a, b)) where + handle step q (Tell w) e append = step (q ^$ ()) e append >>= \(x, l) -> return (x, w `append` l) instance ( MonadBase m m @@ -73,16 +75,16 @@ -- | Transform the state being produced. censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a -censor f = respond_relay return h +censor f = fix (respond_relay' h return) where - h :: (v -> Eff r b) -> Writer w v -> Eff r b - h k (Tell w) = tell (f w) >>= k + h :: (Eff r b -> Eff r b) -> Arrs r v b -> Writer w v -> Eff r b + h step q (Tell w) = tell (f w) >>= \x -> step (q ^$ x) -- | Handle Writer requests, using a user-provided function to accumulate -- values, hence no Monoid constraints. runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b) -runWriter accum !b m = handle_relay withWriter m b accum +runWriter accum !b m = fix (handle_relay withWriter) m b accum -- | Handle Writer requests, using a List to accumulate values. runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w]) diff --git a/src/Data/FTCQueue.hs b/src/Data/FTCQueue.hs --- a/src/Data/FTCQueue.hs +++ b/src/Data/FTCQueue.hs @@ -2,10 +2,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} --- | Fast type-aligned queue optimized to effectful functions --- (a -> m b) --- (monad continuations have this type). --- Constant-time append and snoc and +-- | Fast type-aligned queue optimized to effectful functions @(a -> m b)@ +-- (monad continuations have this type). Constant-time append and snoc and -- average constant-time left-edge deconstruction module Data.FTCQueue ( FTCQueue, @@ -19,7 +17,7 @@ where -- | Non-empty tree. Deconstruction operations make it more and more --- left-leaning +-- left-leaning. data FTCQueue m a b where Leaf :: (a -> m b) -> FTCQueue m a b Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b @@ -27,7 +25,7 @@ -- Exported operations --- | There is no tempty: use (tsingleton return), which works just the same. +-- | There is no @tempty@: use (@tsingleton return@), which works just the same. -- The names are chosen for compatibility with FastTCQueue {-# INLINE tsingleton #-} tsingleton :: (a -> m b) -> FTCQueue m a b diff --git a/src/Data/OpenUnion.hs b/src/Data/OpenUnion.hs --- a/src/Data/OpenUnion.hs +++ b/src/Data/OpenUnion.hs @@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK show-extensions #-} {-# OPTIONS_GHC -Wwarn #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -8,6 +9,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} @@ -51,8 +53,8 @@ -- The interface is the same as of other OpenUnion*.hs module Data.OpenUnion ( Union , inj - , prj - , decomp + , prj, pattern U0' + , decomp, pattern U0, pattern U1 , Member , SetMember , type(<::) @@ -93,6 +95,11 @@ inj :: t v -> Union r v prj :: Union r v -> Maybe (t v) +-- | Pattern synonym to project the union onto the effect @t@. +pattern U0' :: Member t r => t v -> Union r v +pattern U0' h <- (prj -> Just h) where + U0' h = inj h + -- | Explicit type-level equality condition is a dirty -- hack to eliminate the type annotation in the trivial case, -- such as @run (runReader () get)@. @@ -131,10 +138,21 @@ (<::) (m ': ms) r = (Member m r, (<::) ms r) {-# INLINE [2] decomp #-} +-- | Orthogonal decomposition of the union: head and the rest. decomp :: Union (t ': r) v -> Either (Union r v) (t v) decomp (Union 0 v) = Right $ unsafeCoerce v decomp (Union n v) = Left $ Union (n-1) v +-- | Some helpful pattern synonyms. +-- U0 : the first element of the union +pattern U0 :: t v -> Union (t ': r) v +pattern U0 h <- (decomp -> Right h) where + U0 h = inj h +-- | U1 : everything excluding the first element of the union. +pattern U1 t <- (decomp -> Left t) where + U1 t = weaken t +{-# COMPLETE U0, U1 #-} + -- Specialized version {-# RULES "decomp/singleton" decomp = decomp0 #-} {-# INLINE decomp0 #-} @@ -145,7 +163,7 @@ weaken :: Union r w -> Union (any ': r) w weaken (Union n v) = Union (n+1) v --- | Find an index of an element in a `list' +-- | Find the index of an element in a type-level list. -- The element must exist -- This is essentially a compile-time computation. -- Using overlapping instances here is OK since this class is private to this diff --git a/test/Control/Eff/Choose/Test.hs b/test/Control/Eff/Choose/Test.hs deleted file mode 100644 --- a/test/Control/Eff/Choose/Test.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE FlexibleContexts, AllowAmbiguousTypes #-} -{-# LANGUAGE TemplateHaskell #-} - -module Control.Eff.Choose.Test (testGroups) where - -import Test.HUnit hiding (State) -import Control.Eff -import Control.Eff.Example -import Control.Eff.Example.Test (ex2) -import Control.Eff.Exception -import Control.Eff.Choose -import Utils - -import Test.Framework.TH -import Test.Framework.Providers.HUnit - -testGroups = [ $(testGroupGenerator) ] - -case_Choose1_exc11 :: Assertion -case_Choose1_exc11 = [2,3] @=? (run exc11) - where - exc11 = makeChoice exc1 - exc1 = return 1 `add` choose [1,2] - -case_Choose_ex2 :: Assertion -case_Choose_ex2 = - let ex2_1 = run . makeChoice . runErrBig $ ex2 (choose [5,7,1]) - ex2_2 = run . runErrBig . makeChoice $ ex2 (choose [5,7,1]) - in - assertEqual "Choose: Combining exceptions and non-determinism: ex2_1" - expected1 ex2_1 - >> assertEqual "Choose: Combining exceptions and non-determinism: ex2_2" - expected2 ex2_2 - where - expected1 = [Right 5,Left (TooBig 7),Right 1] - expected2 = Left (TooBig 7) - -case_Choose_exRec :: Assertion -case_Choose_exRec = - let exRec_1 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,1])) - exRec_2 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,1])) - exRec_3 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,11,1])) - exRec_4 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,11,1])) - in - assertEqual "Choose: error recovery: exRec_1" expected1 exRec_1 - >> assertEqual "Choose: error recovery: exRec_2" expected2 exRec_2 - >> assertEqual "Choose: error recovery: exRec_3" expected3 exRec_3 - >> assertEqual "Choose: error recovery: exRec_4" expected4 exRec_4 - where - expected1 = Right [5,7,1] - expected2 = [Right 5,Right 7,Right 1] - expected3 = Left (TooBig 11) - expected4 = [Right 5,Right 7,Left (TooBig 11),Right 1] - -- Errror recovery part - -- The code is the same as in transf1.hs. The inferred signatures differ - -- Was: exRec :: MonadError TooBig m => m Int -> m Int - -- exRec :: Member (Exc TooBig) r => Eff r Int -> Eff r Int - exRec m = catchError m handler - where handler (TooBig n) | n <= 7 = return n - handler e = throwError e - -case_Choose_monadBaseControl :: Assertion -case_Choose_monadBaseControl = runLift (makeChoice $ doThing $ choose [1,2,3]) @=? Just [1,2,3] diff --git a/test/Control/Eff/Coroutine/Test.hs b/test/Control/Eff/Coroutine/Test.hs --- a/test/Control/Eff/Coroutine/Test.hs +++ b/test/Control/Eff/Coroutine/Test.hs @@ -24,9 +24,9 @@ case_Coroutines_c1 :: Assertion case_Coroutines_c1 = do ((), actual) <- catchOutput c1 - assertEqual + assertOutput "Coroutine: Simple coroutines using Eff" - (unlines ["1", "2", "Done"]) actual + ["1", "2", "Done"] actual where th1 :: Member (Yield Int ()) r => Eff r () th1 = yieldInt 1 >> yieldInt 2 @@ -38,11 +38,11 @@ case_Coroutines_c2 :: Assertion case_Coroutines_c2 = do ((), actual1) <- catchOutput c2 - assertEqual "Coroutine: Add dynamic variables" - (unlines ["10", "10", "Done"]) actual1 + assertOutput "Coroutine: Add dynamic variables" + ["10", "10", "Done"] actual1 ((), actual2) <- catchOutput c21 - assertEqual "Coroutine: locally changing the dynamic environment for the suspension" - (unlines ["10", "11", "Done"]) actual2 + assertOutput "Coroutine: locally changing the dynamic environment for the suspension" + ["10", "11", "Done"] actual2 where -- The code is essentially the same as that in transf.hs (only added -- a type specializtion on yield). The inferred signature is different though. @@ -65,14 +65,14 @@ case_Coroutines_c3 :: Assertion case_Coroutines_c3 = do ((), actual1) <- catchOutput c3 - assertEqual "Coroutine: two sorts of local rebinding" - (unlines ["10", "10", "20", "20", "Done"]) actual1 + assertOutput "Coroutine: two sorts of local rebinding" + ["10", "10", "20", "20", "Done"] actual1 ((), actual2) <- catchOutput c31 - let expected2 = (unlines ["10", "11", "21", "21", "Done"]) - assertEqual "Coroutine: locally changing the dynamic environment for the suspension" + let expected2 = ["10", "11", "21", "21", "Done"] + assertOutput "Coroutine: locally changing the dynamic environment for the suspension" expected2 actual2 ((), actual3) <- catchOutput c4 - assertEqual "Coroutine: abstracting the client computation" + assertOutput "Coroutine: abstracting the client computation" expected2 actual3 where th3 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r () @@ -104,21 +104,21 @@ case_Corountines_c5 :: Assertion case_Corountines_c5 = do ((), actual) <- catchOutput c5 - let expected = unlines ["10" - ,"11" - ,"12" - ,"18" - ,"18" - ,"18" - ,"29" - ,"29" - ,"29" - ,"29" - ,"29" - ,"29" - ,"Done" - ] - assertEqual "Corountine: Even more dynamic example" + let expected = ["10" + ,"11" + ,"12" + ,"18" + ,"18" + ,"18" + ,"29" + ,"29" + ,"29" + ,"29" + ,"29" + ,"29" + ,"Done" + ] + assertOutput "Corountine: Even more dynamic example" expected actual where c5 = runTrace $ runReader (10::Int) (loop =<< runC (th client)) @@ -139,27 +139,27 @@ case_Coroutines_c7 :: Assertion case_Coroutines_c7 = do ((), actual) <- catchOutput c7 - let expected = unlines ["1010" - ,"1021" - ,"1032" - ,"1048" - ,"1064" - ,"1080" - ,"1101" - ,"1122" - ,"1143" - ,"1169" - ,"1195" - ,"1221" - ,"1252" - ,"1283" - ,"1314" - ,"1345" - ,"1376" - ,"1407" - ,"Done" - ] - assertEqual "Coroutine: And even more dynamic example" + let expected = ["1010" + ,"1021" + ,"1032" + ,"1048" + ,"1064" + ,"1080" + ,"1101" + ,"1122" + ,"1143" + ,"1169" + ,"1195" + ,"1221" + ,"1252" + ,"1283" + ,"1314" + ,"1345" + ,"1376" + ,"1407" + ,"Done" + ] + assertOutput "Coroutine: And even more dynamic example" expected actual where c7 = runTrace $ @@ -183,27 +183,27 @@ case_Coroutines_c7' :: Assertion case_Coroutines_c7' = do ((), actual) <- catchOutput c7' - let expected = unlines ["1010" - ,"1021" - ,"1032" - ,"1048" - ,"1048" - ,"1048" - ,"1069" - ,"1090" - ,"1111" - ,"1137" - ,"1137" - ,"1137" - ,"1168" - ,"1199" - ,"1230" - ,"1261" - ,"1292" - ,"1323" - ,"Done" - ] - assertEqual "Coroutine: And even more dynamic example" + let expected = ["1010" + ,"1021" + ,"1032" + ,"1048" + ,"1048" + ,"1048" + ,"1069" + ,"1090" + ,"1111" + ,"1137" + ,"1137" + ,"1137" + ,"1168" + ,"1199" + ,"1230" + ,"1261" + ,"1292" + ,"1323" + ,"Done" + ] + assertOutput "Coroutine: And even more dynamic example" expected actual where c7' = runTrace $ diff --git a/test/Control/Eff/Cut/Test.hs b/test/Control/Eff/Cut/Test.hs deleted file mode 100644 --- a/test/Control/Eff/Cut/Test.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TemplateHaskell #-} - -module Control.Eff.Cut.Test (testGroups) where - -import Test.HUnit hiding (State) -import Control.Eff -import Control.Eff.Choose -import Control.Eff.Cut - -import Test.Framework.TH -import Test.Framework.Providers.HUnit - -testGroups = [ $(testGroupGenerator) ] - -case_Cut_tcut :: Assertion -case_Cut_tcut = - let tcut1r = run . makeChoice $ call tcut1 - tcut2r = run . makeChoice $ call tcut2 - tcut3r = run . makeChoice $ call tcut3 - tcut4r = run . makeChoice $ call tcut4 - in - assertEqual "Cut: tcut1" [1,2] tcut1r - >> assertEqual "Cut: nested call: tcut2" [1,2,5] tcut2r - >> assertEqual "Cut: nested call: tcut3" [1,2,1,2,5] tcut3r - >> assertEqual "Cut: nested call: tcut4" [1,2,1,2,5] tcut4r - where - -- signature is inferred - -- tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int - tcut1 = (return (1::Int) `mplus'` return 2) `mplus'` - ((cutfalse `mplus'` return 4) `mplus'` - return 5) - -- Here we see nested call. It poses no problems... - tcut2 = return (1::Int) `mplus'` - call (return 2 `mplus'` (cutfalse `mplus'` return 3) `mplus'` - return 4) - `mplus'` return 5 - tcut3 = call tcut1 `mplus'` call (tcut2 `mplus'` cutfalse) - tcut4 = call tcut1 `mplus'` (tcut2 `mplus'` cutfalse) diff --git a/test/Control/Eff/Fresh/Test.hs b/test/Control/Eff/Fresh/Test.hs --- a/test/Control/Eff/Fresh/Test.hs +++ b/test/Control/Eff/Fresh/Test.hs @@ -19,8 +19,8 @@ case_Fresh_tfresh' :: Assertion case_Fresh_tfresh' = do ((), actual) <- catchOutput tfresh' - assertEqual "Fresh: test" - (unlines ["Fresh 0", "Fresh 1"]) actual + assertOutput "Fresh: test" + ["Fresh 0", "Fresh 1"] actual where tfresh' = runTrace $ runFresh' 0 $ do n <- fresh diff --git a/test/Control/Eff/Logic/NDet/Bench.hs b/test/Control/Eff/Logic/NDet/Bench.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Logic/NDet/Bench.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} + +-- A benchmark of shift/reset: Filinski's representing non-determinism monads +-- +-- The benchmark is taken from Sec 6.1 of +-- Martin Gasbichler, Michael Sperber: Final Shift for Call/cc: Direct +-- Implementation of Shift and Reset, ICFP'02, pp. 271-282. +-- http://www-pu.informatik.uni-tuebingen.de/users/sperber/papers/shift-reset-direct.pdf +-- This code is a straightforward translation of bench_nondet.ml +-- +-- This is a micro-benchmark: it is very non-determinism-intensive. It is +-- *not* representative: the benchmark does nothing else but +-- concatenates lists. The List monad does this directly; whereas +-- continuation monads do the concatenation with more overhead (e.g., +-- building the closures representing continuations). Therefore, +-- the List monad here outperforms all other implementations of +-- non-determinism. +-- It should be stressed that the delimited control is optimized +-- for the case where control operations are infrequent, so we pay +-- as we go. The use of the delimited control operators is more +-- expensive, but the code that does not use delimited control does not +-- have to pay anything for delimited control. +-- Again, in the present micro-benchmark, there is hardly any code that +-- does not use non-determinism, so the overhead of delimited control +-- is very noticeable. That is why this benchmark is good at estimating +-- the overhead of different implementations of delimited control. + +-- To compile this code +-- ghc -O2 -rtsopts -main-is Bench_nondet.main_list5 Bench_nondet.hs +-- To run this code +-- GHCRTS="-tstderr" /usr/bin/time ./Bench_nondet + +module Control.Eff.Logic.NDet.Bench where + +import Control.Eff +import qualified Control.Eff.Logic.NDet as E + +import Data.List (sort) +-- import Control.Monad.Identity +-- import Control.Monad (liftM2) +import Control.Monad (MonadPlus(..), msum) +import Control.Applicative +-- import System.CPUTime + +-- Small language with non-determinism: just like the one in our DSL-WC paper + +int :: MonadPlus repr => Int -> repr Int +int x = return x + +add :: MonadPlus repr => repr Int -> repr Int -> repr Int +-- add xs ys = liftM2 (+) xs ys +add xs ys = do {x <- xs; y <- ys; return $! x+y } + +lam :: MonadPlus repr => (repr a -> repr b) -> repr (a -> repr b) +lam f = return $ f . return + +app :: MonadPlus repr => repr (a -> repr b) -> (repr a -> repr b) +app xs ys = do {x <- xs; y <- ys; x y} + +amb :: MonadPlus repr => [repr Int] -> repr Int +amb = msum + +-- Benchmark cases + +test_ww :: MonadPlus repr => repr Int +test_ww = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32] + +ww_answer = + sort [8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 4, 6, 7, 6, 3, 10, 12, 13, + 12, 9, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 12, 14, 15, + 14, 11, 11, 13, 14, 13, 10, 9, 11, 12, 11, 8, 7, 9, 10, 9, 6, 13, 15, + 16, 15, 12, 12, 14, 15, 14, 11, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, + 14, 16, 17, 16, 13, 13, 15, 16, 15, 12, 11, 13, 14, 13, 10, 9, 11, 12, + 11, 8, 15, 17, 18, 17, 14, 40, 42, 43, 42, 39, 38, 40, 41, 40, 37, 36, + 38, 39, 38, 35, 42, 44, 45, 44, 41] + +-- Real benchmark cases + +test_www :: MonadPlus repr => repr Int +test_www = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]) + +test_wwww :: MonadPlus repr => repr Int +test_wwww = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])) + +test_w5 :: MonadPlus repr => repr Int +test_w5 = + let f = lam (\x -> + add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1])) + in f `app` (f `app` + (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]))) + + +-- Different implementations of our language (MonadPlus) + +-- The List monad: Non-determinism monad as a list of successes + +run_list :: [Int] -> [Int] +run_list = id + +testl1 = (==) [101, 201, 102, 202] . run_list $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testl2 = ww_answer == sort (run_list test_ww) + + +-- CPS-monad, implemented by hand; it must be quite efficient therefore +-- It is a monad, not a transformer. It cannot do any other effects beside +-- the non-determinism. +newtype CPS a = CPS{unCPS:: (a -> [Int]) -> [Int]} + +instance Functor CPS where + fmap f fa = CPS $ \k -> unCPS fa (k . f) +instance Applicative CPS where + pure x = CPS $ \k -> k x + mf <*> fa = CPS $ \k -> unCPS mf (\f -> unCPS fa (k . f)) +instance Monad CPS where + return x = CPS $ \k -> k x + m >>= f = CPS $ \k -> unCPS m (\a -> unCPS (f a) k) + +instance Alternative CPS where + empty = mzero + (<|>) = mplus +instance MonadPlus CPS where + mzero = CPS $ \_ -> [] + mplus m1 m2 = CPS $ \k -> unCPS m1 k ++ unCPS m2 k + +run_cps :: CPS Int -> [Int] +run_cps m = unCPS m (\x -> [x]) + + +testc1 = (==) [101, 201, 102, 202] . run_cps $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testc2 = ww_answer == sort (run_cps test_ww) + +-- ExtEff implementation +-- Eff is already an instance of MonadPlus. Thus we only need to +-- define the run instance + +-- run_eff :: Eff '[E.Choose] Int -> [Int] +-- run_eff = run . E.makeChoice + +-- More direct interpreter +-- makeChoiceA :: Eff (E.NDet ': r) a -> Eff r [a] +-- makeChoiceA = handle_relay (\x -> x `seq` return [x] ) $ \m k -> case m of +-- E.MZero -> return [] +-- E.MPlus -> liftM2 (++) (k True) (k False) + +run_eff :: Eff '[E.NDet] Int -> [Int] +run_eff = run . E.makeChoiceA + +teste2 = ww_answer == sort (run_eff test_ww) + + +data Count a = Count (Maybe a) !Int +instance Functor Count where + fmap f (Count (Just x) n) = Count (Just (f x)) n + fmap _ _ = Count Nothing 0 + +instance Applicative Count where + pure x = Count (Just x) 1 + Count (Just f) nf <*> Count (Just x) nx = Count (Just (f x)) (nf + nx) + _ <*> _ = Count Nothing 0 + +instance Alternative Count where + empty = Count Nothing 0 + Count m1@Just{} n1 <|> Count _ n2 = Count m1 (n1+n2) + _ <|> m2 = m2 + +run_effc :: Eff '[E.NDet] Int -> Int +run_effc m = let Count _ n = run . E.makeChoiceA $ m in n + + +teste12 = length ww_answer == run_effc test_ww + +{- +-- CCEx monad +-- Not a very optimal implementation of mplus (a tree would be better) +-- But is suffices as a benchmark of different implementations of CC +instance Monad m => MonadPlus (CC (PS [Int]) m) where + mzero = abortP ps (return []) + mplus m1 m2 = takeSubCont ps (\k -> + liftM2 (++) + (pushPrompt ps (pushSubCont k m1)) + (pushPrompt ps (pushSubCont k m2))) + +run_dir :: CC (PS [Int]) Identity Int -> [Int] +run_dir m = runIdentity . runCC $ + pushPrompt ps (m >>= return . (:[])) + + +testd1 = (==) [101, 201, 102, 202] . run_dir $ + add (amb [int 1, int 2]) (amb [int 100, int 200]) + +testd2 = ww_answer == sort (run_dir test_ww) + +-} + + +-- Benchmarks themselves + +main_list3 = print $ 2400 == (length . run_list $ test_www) +main_list4 = print $ 48000 == (length . run_list $ test_wwww) +main_list5 = print $ 960000 == (length . run_list $ test_w5) + +main_cps3 = print $ 2400 == (length . run_cps $ test_www) +main_cps4 = print $ 48000 == (length . run_cps $ test_wwww) +main_cps5 = print $ 960000 == (length . run_cps $ test_w5) + +-- We expect the direct implementation to be slower since CC is the transformer, +-- whereas CPS is not. The latter is hand-written for a specific answer-type. +main_eff3 = print $ 2400 == (length . run_eff $ test_www) +main_eff4 = print $ 48000 == (length . run_eff $ test_wwww) +main_eff5 = print $ 960000 == (length . run_eff $ test_w5) + +main_eff5c = print $ 960000 == (run_effc $ test_w5) + +-- To clarify the effect of building a list +main_eff5m = print $ ((run . E.makeChoiceA $ test_w5) :: Maybe Int) + +{- +-- Instantiate CC to the IO as the base monad, attempting to quantify the +-- effect of the Identity transformer +main_dir5io = do + l <- runCC $ pushPrompt ps (test_w5 >>= return . (:[])) + print $ length l == 960000 +-} + +-- ------------------------------------------------------------------------ +-- Old results, from 2010 + +{- Median of 5 runs + +main_list5 +<> + 0.30 real 0.30 user 0.00 sys + +main_cps5 +<> + 0.60 real 0.58 user 0.01 sys + +main_dir5 (CCExc implementation) +<> + 4.48 real 4.22 user 0.24 sys + +main_dir5io (CCExc implementation) +<> + 5.45 real 5.18 user 0.21 sys + + +main_dir5 (CCCxe implementation) +./Bench_nondet +RTS -tstderr +True +<> + 4.70 real 4.44 user 0.23 sys + +main_dir5io (CCCxe implementation) +./Bench_nondet +RTS -tstderr +True +<> + 4.72 real 4.44 user 0.23 sys + +main_ref5io (without pushDelimSubCont) +./Bench_nondet +RTS -tstderr +True +<> + 68.94 real 67.51 user 1.03 sys + + +main_ref5io (with pushDelimSubCont) +./Bench_nondet +RTS -tstderr +True +<> + 20.50 real 19.92 user 0.46 sys + +-} + +-- ------------------------------------------------------------------------ +-- Newer Benchmarks, July 2015 + +{- +main_list5 +True +<> + +main_cps5 +True +<> + +-- using makeChoiceA (setting f as an Alternative) +main_eff5 +True +<> + +With strict add: +True +<> +1.32user 0.08system 0:01.40elapsed 99%CPU (0avgtext+0avgdata 819408maxresident)k +0inputs+0outputs (0major+51485minor)pagefaults 0swaps + +It looks like a huge memory leak. Perhaps the list is fully realized? + + +Using the counting Alternative Count +True +<> + +Using Maybe +Just 32 +<> +0.67user 0.05system 0:00.72elapsed 100%CPU (0avgtext+0avgdata 620752maxresident)k +0inputs+0outputs (0major+38937minor)pagefaults 0swaps + +-- using Maybe, but with the better makeChoice +Just 32 +<> +0.63user 0.04system 0:00.68elapsed 100%CPU (0avgtext+0avgdata 570720maxresident)k +0inputs+0outputs (0major+35760minor)pagefaults 0swaps + +Better makeChoiceA, full list +True +<> +0.42user 0.02system 0:00.44elapsed 100%CPU (0avgtext+0avgdata 244064maxresident)k +0inputs+0outputs (0major+15391minor)pagefaults 0swaps + +-} diff --git a/test/Control/Eff/Logic/NDet/Test.hs b/test/Control/Eff/Logic/NDet/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Logic/NDet/Test.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Logic.NDet.Test (testGroups, gen_testCA, gen_ifte_test) +where + +import Test.HUnit hiding (State) +import Control.Applicative +import Control.Eff +import Control.Eff.Example +import Control.Eff.Example.Test (ex2) +import Control.Eff.Exception +import Control.Eff.Logic.NDet +import Control.Eff.Writer.Strict +import Control.Monad (msum, guard, mzero, mplus) +import Control.Eff.Logic.Test +import Utils + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +gen_testCA :: (Integral a) => a -> Eff (NDet ': r) a +gen_testCA x = do + i <- msum . fmap return $ [1..x] + guard (i `mod` 2 == 0) + return i + +case_NDet_testCA :: Assertion +case_NDet_testCA = [2, 4..10] @=? (run $ makeChoiceA (gen_testCA 10)) + +case_Choose1_exc11 :: Assertion +case_Choose1_exc11 = [2,3] @=? (run exc11) + where + exc11 = makeChoice exc1 + exc1 = return 1 `add` choose [1,2] + +case_Choose_exRec :: Assertion +case_Choose_exRec = + let exRec_1 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,1])) + exRec_2 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,1])) + exRec_3 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,11,1])) + exRec_4 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,11,1])) + in + assertEqual "Choose: error recovery: exRec_1" expected1 exRec_1 + >> assertEqual "Choose: error recovery: exRec_2" expected2 exRec_2 + >> assertEqual "Choose: error recovery: exRec_3" expected3 exRec_3 + >> assertEqual "Choose: error recovery: exRec_4" expected4 exRec_4 + where + expected1 = Right [5,7,1] + expected2 = [Right 5,Right 7,Right 1] + expected3 = Left (TooBig 11) + expected4 = [Right 5,Right 7,Left (TooBig 11),Right 1] + -- Errror recovery part + -- The code is the same as in transf1.hs. The inferred signatures differ + -- Was: exRec :: MonadError TooBig m => m Int -> m Int + -- exRec :: Member (Exc TooBig) r => Eff r Int -> Eff r Int + exRec m = catchError m handler + where handler (TooBig n) | n <= 7 = return n + handler e = throwError e + +case_Choose_ex2 :: Assertion +case_Choose_ex2 = + let ex2_1 = run . makeChoice . runErrBig $ ex2 (choose [5,7,1]) + ex2_2 = run . runErrBig . makeChoice $ ex2 (choose [5,7,1]) + in + assertEqual "Choose: Combining exceptions and non-determinism: ex2_1" + expected1 ex2_1 + >> assertEqual "Choose: Combining exceptions and non-determinism: ex2_2" + expected2 ex2_2 + where + expected1 = [Right 5,Left (TooBig 7),Right 1] + expected2 = Left (TooBig 7) + +gen_ifte_test x = do + n <- gen x + ifte (do + d <- gen x + guard $ d < n && n `mod` d == 0 + -- _ <- trace ("d: " ++ show d) (return ()) + ) + (\_ -> mzero) + (return n) + where gen x = msum . fmap return $ [2..x] + + +case_NDet_ifte :: Assertion +case_NDet_ifte = + let primes = ifte_test_run + in + assertEqual "NDet: test ifte using primes" + [2,3,5,7,11,13,17,19,23,29] primes + where + ifte_test_run :: [Int] + ifte_test_run = run . makeChoiceA $ (gen_ifte_test 30) + + +-- called reflect in the LogicT paper +case_NDet_reflect :: Assertion +case_NDet_reflect = + let tsplitr10 = run $ runListWriter $ makeChoiceA tsplit + tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= reflect) + tsplitr20 = run $ makeChoiceA $ runListWriter tsplit + tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= reflect) + in + assertEqual "tsplitr10" expected1 tsplitr10 + >> assertEqual "tsplitr11" expected1 tsplitr11 + >> assertEqual "tsplitr20" expected2 tsplitr20 + >> assertEqual "tsplitr21" expected21 tsplitr21 + where + expected1 = ([1, 2],["begin", "end"]) + expected2 = [(1, ["begin"]), (2, ["end"])] + expected21 = [(1, ["begin"]), (2, ["begin", "end"])] + + tsplit = + (tell "begin" >> return 1) `mplus` + (tell "end" >> return 2) + +case_NDet_monadBaseControl :: Assertion +case_NDet_monadBaseControl = runLift (makeChoiceA $ doThing (return 1 <|> return 2)) @=? Just [1,2] + +case_Choose_monadBaseControl :: Assertion +case_Choose_monadBaseControl = runLift (makeChoice $ doThing $ choose [1,2,3]) @=? Just [1,2,3] + +case_NDet_cut :: Assertion +case_NDet_cut = testCut (run . makeChoice) + +case_NDet_monadplus :: Assertion +case_NDet_monadplus = + let evalnw = run . (runListWriter @Int) . makeChoice + evalwn = run . makeChoice . (runListWriter @Int) + casesnw = [ + -- mplus laws + ("0 | NDet, Writer", evalnw t0, nw0) + , ("zm0 = 0 | NDet, Writer", evalnw tzm0, nw0) + , ("0m1 | NDet, Writer", evalnw t0m1, nw0m1) + , ("zm0mzm1 = 0m1 | NDet, Writer", evalnw tzm0mzm1, nw0m1) + -- mzero laws + , ("z | NDet, Writer", evalnw tz, nwz) + , ("z0 = z | NDet, Writer", evalnw tz0, nwz) + , ("0z /= z | NDet, Writer", evalnw t0z, nw0z) + , ("z0m1 = 1 | NDet, Writer", evalnw tz0m1, nw1) + , ("0zm1 /= 1 | NDet, Writer", evalnw t0zm1, nw0zm1) + ] + caseswn = [ + -- mplus laws + ("0 | Writer, NDet", evalwn t0, wn0) + , ("zm0 = 0 | Writer, NDet", evalwn tzm0, wn0) + , ("0m1 | Writer, NDet", evalwn t0m1, wn0m1) + , ("zm0mzm1 = 0m1 | Writer, NDet", evalwn tzm0mzm1, wn0m1) + -- mzero laws + , ("z | Writer, NDet", evalwn tz, wnz) + , ("z0 = z | Writer, NDet", evalwn tz0, wnz) + , ("0z = z | Writer, NDet", evalwn t0z, wnz) + , ("z0m1 = 1 | Writer, NDet", evalwn tz0m1, wn1) + , ("0zm1 = 1 | Writer, NDet", evalwn t0zm1, wn1) + ] + in runAsserts assertEqual casesnw + >> runAsserts assertEqual caseswn + where + nwz = ([]::[Int],[]) + wnz = [] ::[(Int, [Int])] + nw0z = ([]::[Int],[0]) + nw0 = ([0],[0]) + nw1 = ([1],[1]) + nw0zm1 = ([1],[0,1]) + wn0 = [(0,[0])] + wn1 = [(1,[1])] + + nw0m1 = ([0::Int,1],[0,1]) + wn0m1 = [(0,[0]), (1,[1])] + + t0 = wr @Int 0 + t1 = wr @Int 1 + + tz = mzero + tz0 = tz >> t0 + t0z = t0 >> tz + tz0m1 = tz0 `mplus` t1 + t0zm1 = t0z `mplus` t1 + + t0m1 = t0 `mplus` t1 + tzm0 = tz `mplus` t0 + tzm1 = tz `mplus` t1 + tzm0mzm1 = tzm0 `mplus` tzm1 + + wr :: forall a r. [Writer a, NDet] <:: r => a -> Eff r a + wr i = tell i >> return i diff --git a/test/Control/Eff/Logic/Test.hs b/test/Control/Eff/Logic/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/Logic/Test.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TemplateHaskell #-} + +module Control.Eff.Logic.Test where + +import Test.HUnit hiding (State) +import Control.Eff.Logic.Core +import Control.Monad + +-- the inferred signature of testCut is insightful +testCut runChoice = + let cases = [tcut1, tcut2, tcut3, tcut4, tcut5, tcut6, tcut7, tcut8 + , tcut9] + runCall = runChoice . call + in + forM_ cases $ \(test, result) -> + assertEqual "Cut: tcut" result (runCall test) + where + -- signature is inferred + -- tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int + tc1 = (return (1::Int) `mplus` return 2) `mplus` + ((cutfalse `mplus` return 4) `mplus` + return 5) + rc1 = [1,2] + tcut1 = (tc1, rc1) + -- Here we see nested call. It poses no problems... + tc2 = return (1::Int) `mplus` + call (return 2 `mplus` (cutfalse `mplus` return 3) `mplus` + return 4) + `mplus` return 5 + rc2 = [1,2,5] + tcut2 = (tc2, rc2) + tcut3 = ((call tc1 `mplus` call (tc2 `mplus` cutfalse)) + , rc1 ++ rc2) + tcut4 = ((call tc1 `mplus` (tc2 `mplus` cutfalse)) + , rc1 ++ rc2) + tcut5 = ((call tc1 `mplus` (cutfalse `mplus` tc2)) + , rc1) + tcut6 = ((call tc1 `mplus` call (cutfalse `mplus` tc2)) + , rc1) + tcut7 = ((call tc1 `mplus` (cutfalse `mplus` tc2) `mplus` tc2) + , rc1) + tcut8 = ((call tc1 `mplus` call (cutfalse `mplus` tc2) `mplus` tc2) + , rc1 ++ rc2) + incrOrDecr = \x -> (return $! x + 1) + `mplus` cutfalse + `mplus` (return $! x - 1) + tc9 = tc1 >>= incrOrDecr + rc9 = [2] + tcut9 = (tc9, rc9) + -- tcut10 = ((return rc1 >>= incrOrDecr) + -- , rc9) diff --git a/test/Control/Eff/NdetEff/Bench.hs b/test/Control/Eff/NdetEff/Bench.hs deleted file mode 100644 --- a/test/Control/Eff/NdetEff/Bench.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} - --- A benchmark of shift/reset: Filinski's representing non-determinism monads --- --- The benchmark is taken from Sec 6.1 of --- Martin Gasbichler, Michael Sperber: Final Shift for Call/cc: Direct --- Implementation of Shift and Reset, ICFP'02, pp. 271-282. --- http://www-pu.informatik.uni-tuebingen.de/users/sperber/papers/shift-reset-direct.pdf --- This code is a straightforward translation of bench_nondet.ml --- --- This is a micro-benchmark: it is very non-determinism-intensive. It is --- *not* representative: the benchmark does nothing else but --- concatenates lists. The List monad does this directly; whereas --- continuation monads do the concatenation with more overhead (e.g., --- building the closures representing continuations). Therefore, --- the List monad here outperforms all other implementations of --- non-determinism. --- It should be stressed that the delimited control is optimized --- for the case where control operations are infrequent, so we pay --- as we go. The use of the delimited control operators is more --- expensive, but the code that does not use delimited control does not --- have to pay anything for delimited control. --- Again, in the present micro-benchmark, there is hardly any code that --- does not use non-determinism, so the overhead of delimited control --- is very noticeable. That is why this benchmark is good at estimating --- the overhead of different implementations of delimited control. - --- To compile this code --- ghc -O2 -rtsopts -main-is Bench_nondet.main_list5 Bench_nondet.hs --- To run this code --- GHCRTS="-tstderr" /usr/bin/time ./Bench_nondet - -module Control.Eff.NdetEff.Bench where - -import Control.Eff -import qualified Control.Eff.NdetEff as E - -import Data.List (sort) --- import Control.Monad.Identity --- import Control.Monad (liftM2) -import Control.Monad (MonadPlus(..), msum) -import Control.Applicative --- import System.CPUTime - --- Small language with non-determinism: just like the one in our DSL-WC paper - -int :: MonadPlus repr => Int -> repr Int -int x = return x - -add :: MonadPlus repr => repr Int -> repr Int -> repr Int --- add xs ys = liftM2 (+) xs ys -add xs ys = do {x <- xs; y <- ys; return $! x+y } - -lam :: MonadPlus repr => (repr a -> repr b) -> repr (a -> repr b) -lam f = return $ f . return - -app :: MonadPlus repr => repr (a -> repr b) -> (repr a -> repr b) -app xs ys = do {x <- xs; y <- ys; x y} - -amb :: MonadPlus repr => [repr Int] -> repr Int -amb = msum - --- Benchmark cases - -test_ww :: MonadPlus repr => repr Int -test_ww = - let f = lam (\x -> - add (add x (amb [int 6, int 4, int 2, int 8])) - (amb [int 2, int 4, int 5, int 4, int 1])) - in f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32] - -ww_answer = - sort [8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 4, 6, 7, 6, 3, 10, 12, 13, - 12, 9, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 12, 14, 15, - 14, 11, 11, 13, 14, 13, 10, 9, 11, 12, 11, 8, 7, 9, 10, 9, 6, 13, 15, - 16, 15, 12, 12, 14, 15, 14, 11, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, - 14, 16, 17, 16, 13, 13, 15, 16, 15, 12, 11, 13, 14, 13, 10, 9, 11, 12, - 11, 8, 15, 17, 18, 17, 14, 40, 42, 43, 42, 39, 38, 40, 41, 40, 37, 36, - 38, 39, 38, 35, 42, 44, 45, 44, 41] - --- Real benchmark cases - -test_www :: MonadPlus repr => repr Int -test_www = - let f = lam (\x -> - add (add x (amb [int 6, int 4, int 2, int 8])) - (amb [int 2, int 4, int 5, int 4, int 1])) - in f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]) - -test_wwww :: MonadPlus repr => repr Int -test_wwww = - let f = lam (\x -> - add (add x (amb [int 6, int 4, int 2, int 8])) - (amb [int 2, int 4, int 5, int 4, int 1])) - in f `app` (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])) - -test_w5 :: MonadPlus repr => repr Int -test_w5 = - let f = lam (\x -> - add (add x (amb [int 6, int 4, int 2, int 8])) - (amb [int 2, int 4, int 5, int 4, int 1])) - in f `app` (f `app` - (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]))) - - --- Different implementations of our language (MonadPlus) - --- The List monad: Non-determinism monad as a list of successes - -run_list :: [Int] -> [Int] -run_list = id - -testl1 = (==) [101, 201, 102, 202] . run_list $ - add (amb [int 1, int 2]) (amb [int 100, int 200]) - -testl2 = ww_answer == sort (run_list test_ww) - - --- CPS-monad, implemented by hand; it must be quite efficient therefore --- It is a monad, not a transformer. It cannot do any other effects beside --- the non-determinism. -newtype CPS a = CPS{unCPS:: (a -> [Int]) -> [Int]} - -instance Functor CPS where - fmap f fa = CPS $ \k -> unCPS fa (k . f) -instance Applicative CPS where - pure x = CPS $ \k -> k x - mf <*> fa = CPS $ \k -> unCPS mf (\f -> unCPS fa (k . f)) -instance Monad CPS where - return x = CPS $ \k -> k x - m >>= f = CPS $ \k -> unCPS m (\a -> unCPS (f a) k) - -instance Alternative CPS where - empty = mzero - (<|>) = mplus -instance MonadPlus CPS where - mzero = CPS $ \_ -> [] - mplus m1 m2 = CPS $ \k -> unCPS m1 k ++ unCPS m2 k - -run_cps :: CPS Int -> [Int] -run_cps m = unCPS m (\x -> [x]) - - -testc1 = (==) [101, 201, 102, 202] . run_cps $ - add (amb [int 1, int 2]) (amb [int 100, int 200]) - -testc2 = ww_answer == sort (run_cps test_ww) - --- ExtEff implementation --- Eff is already an instance of MonadPlus. Thus we only need to --- define the run instance - --- run_eff :: Eff '[E.Choose] Int -> [Int] --- run_eff = run . E.makeChoice - --- More direct interpreter --- makeChoiceA :: Eff (E.NdetEff ': r) a -> Eff r [a] --- makeChoiceA = handle_relay (\x -> x `seq` return [x] ) $ \m k -> case m of --- E.MZero -> return [] --- E.MPlus -> liftM2 (++) (k True) (k False) - -run_eff :: Eff '[E.NdetEff] Int -> [Int] -run_eff = run . E.makeChoiceA - -teste2 = ww_answer == sort (run_eff test_ww) - - -data Count a = Count (Maybe a) !Int -instance Functor Count where - fmap f (Count (Just x) n) = Count (Just (f x)) n - fmap _ _ = Count Nothing 0 - -instance Applicative Count where - pure x = Count (Just x) 1 - Count (Just f) nf <*> Count (Just x) nx = Count (Just (f x)) (nf + nx) - _ <*> _ = Count Nothing 0 - -instance Alternative Count where - empty = Count Nothing 0 - Count m1@Just{} n1 <|> Count _ n2 = Count m1 (n1+n2) - _ <|> m2 = m2 - -run_effc :: Eff '[E.NdetEff] Int -> Int -run_effc m = let Count _ n = run . E.makeChoiceA $ m in n - - -teste12 = length ww_answer == run_effc test_ww - -{- --- CCEx monad --- Not a very optimal implementation of mplus (a tree would be better) --- But is suffices as a benchmark of different implementations of CC -instance Monad m => MonadPlus (CC (PS [Int]) m) where - mzero = abortP ps (return []) - mplus m1 m2 = takeSubCont ps (\k -> - liftM2 (++) - (pushPrompt ps (pushSubCont k m1)) - (pushPrompt ps (pushSubCont k m2))) - -run_dir :: CC (PS [Int]) Identity Int -> [Int] -run_dir m = runIdentity . runCC $ - pushPrompt ps (m >>= return . (:[])) - - -testd1 = (==) [101, 201, 102, 202] . run_dir $ - add (amb [int 1, int 2]) (amb [int 100, int 200]) - -testd2 = ww_answer == sort (run_dir test_ww) - --} - - --- Benchmarks themselves - -main_list3 = print $ 2400 == (length . run_list $ test_www) -main_list4 = print $ 48000 == (length . run_list $ test_wwww) -main_list5 = print $ 960000 == (length . run_list $ test_w5) - -main_cps3 = print $ 2400 == (length . run_cps $ test_www) -main_cps4 = print $ 48000 == (length . run_cps $ test_wwww) -main_cps5 = print $ 960000 == (length . run_cps $ test_w5) - --- We expect the direct implementation to be slower since CC is the transformer, --- whereas CPS is not. The latter is hand-written for a specific answer-type. -main_eff3 = print $ 2400 == (length . run_eff $ test_www) -main_eff4 = print $ 48000 == (length . run_eff $ test_wwww) -main_eff5 = print $ 960000 == (length . run_eff $ test_w5) - -main_eff5c = print $ 960000 == (run_effc $ test_w5) - --- To clarify the effect of building a list -main_eff5m = print $ ((run . E.makeChoiceA $ test_w5) :: Maybe Int) - -{- --- Instantiate CC to the IO as the base monad, attempting to quantify the --- effect of the Identity transformer -main_dir5io = do - l <- runCC $ pushPrompt ps (test_w5 >>= return . (:[])) - print $ length l == 960000 --} - --- ------------------------------------------------------------------------ --- Old results, from 2010 - -{- Median of 5 runs - -main_list5 -<> - 0.30 real 0.30 user 0.00 sys - -main_cps5 -<> - 0.60 real 0.58 user 0.01 sys - -main_dir5 (CCExc implementation) -<> - 4.48 real 4.22 user 0.24 sys - -main_dir5io (CCExc implementation) -<> - 5.45 real 5.18 user 0.21 sys - - -main_dir5 (CCCxe implementation) -./Bench_nondet +RTS -tstderr -True -<> - 4.70 real 4.44 user 0.23 sys - -main_dir5io (CCCxe implementation) -./Bench_nondet +RTS -tstderr -True -<> - 4.72 real 4.44 user 0.23 sys - -main_ref5io (without pushDelimSubCont) -./Bench_nondet +RTS -tstderr -True -<> - 68.94 real 67.51 user 1.03 sys - - -main_ref5io (with pushDelimSubCont) -./Bench_nondet +RTS -tstderr -True -<> - 20.50 real 19.92 user 0.46 sys - --} - --- ------------------------------------------------------------------------ --- Newer Benchmarks, July 2015 - -{- -main_list5 -True -<> - -main_cps5 -True -<> - --- using makeChoiceA (setting f as an Alternative) -main_eff5 -True -<> - -With strict add: -True -<> -1.32user 0.08system 0:01.40elapsed 99%CPU (0avgtext+0avgdata 819408maxresident)k -0inputs+0outputs (0major+51485minor)pagefaults 0swaps - -It looks like a huge memory leak. Perhaps the list is fully realized? - - -Using the counting Alternative Count -True -<> - -Using Maybe -Just 32 -<> -0.67user 0.05system 0:00.72elapsed 100%CPU (0avgtext+0avgdata 620752maxresident)k -0inputs+0outputs (0major+38937minor)pagefaults 0swaps - --- using Maybe, but with the better makeChoice -Just 32 -<> -0.63user 0.04system 0:00.68elapsed 100%CPU (0avgtext+0avgdata 570720maxresident)k -0inputs+0outputs (0major+35760minor)pagefaults 0swaps - -Better makeChoiceA, full list -True -<> -0.42user 0.02system 0:00.44elapsed 100%CPU (0avgtext+0avgdata 244064maxresident)k -0inputs+0outputs (0major+15391minor)pagefaults 0swaps - --} diff --git a/test/Control/Eff/NdetEff/Test.hs b/test/Control/Eff/NdetEff/Test.hs deleted file mode 100644 --- a/test/Control/Eff/NdetEff/Test.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} -{-# LANGUAGE TypeOperators, DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} - -module Control.Eff.NdetEff.Test (testGroups, gen_testCA, gen_ifte_test) where - -import Test.HUnit hiding (State) -import Control.Applicative -import Control.Eff -import Control.Eff.NdetEff -import Control.Eff.Writer.Strict -import Control.Monad (msum, guard, mzero, mplus) -import Utils - -import Test.Framework.TH -import Test.Framework.Providers.HUnit - -testGroups = [ $(testGroupGenerator) ] - --- TODO: add quickcheck test to test conformance of different --- implementations of 'makeChoiceA' and 'msplit'. - --- TODO: add benchmarks for different implementations of 'makeChoiceA' --- and 'msplit'. - -gen_testCA :: (Integral a) => a -> Eff (NdetEff ': r) a -gen_testCA x = do - i <- msum . fmap return $ [1..x] - guard (i `mod` 2 == 0) - return i - -case_NdetEff_testCA :: Assertion -case_NdetEff_testCA = [2, 4..10] @=? (run $ makeChoiceA (gen_testCA 10)) - -gen_ifte_test x = do - n <- gen x - ifte (do - d <- gen x - guard $ d < n && n `mod` d == 0 - -- _ <- trace ("d: " ++ show d) (return ()) - ) - (\_ -> mzero) - (return n) - where gen x = msum . fmap return $ [2..x] - - -case_NdetEff_ifte :: Assertion -case_NdetEff_ifte = - let primes = ifte_test_run - in - assertEqual "NdetEff: test ifte using primes" - [2,3,5,7,11,13,17,19,23,29] primes - where - ifte_test_run :: [Int] - ifte_test_run = run . makeChoiceA $ (gen_ifte_test 30) - - --- called reflect in the LogicT paper -case_NdetEff_reflect :: Assertion -case_NdetEff_reflect = - let tsplitr10 = run $ runListWriter $ makeChoiceA tsplit - tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= reflect) - tsplitr20 = run $ makeChoiceA $ runListWriter tsplit - tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= reflect) - in - assertEqual "tsplitr10" expected1 tsplitr10 - >> assertEqual "tsplitr11" expected1 tsplitr11 - >> assertEqual "tsplitr20" expected2 tsplitr20 - >> assertEqual "tsplitr21" expected21 tsplitr21 - where - expected1 = ([1, 2],["begin", "end"]) - expected2 = [(1, ["begin"]), (2, ["end"])] - expected21 = [(1, ["begin"]), (2, ["begin", "end"])] - - tsplit = - (tell "begin" >> return 1) `mplus` - (tell "end" >> return 2) - -case_NdetEff_monadBaseControl :: Assertion -case_NdetEff_monadBaseControl = runLift (makeChoiceA $ doThing (return 1 <|> return 2)) @=? Just [1,2] diff --git a/test/Control/Eff/Test.hs b/test/Control/Eff/Test.hs --- a/test/Control/Eff/Test.hs +++ b/test/Control/Eff/Test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TypeOperators, DataKinds #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Control.Eff.Test (testGroups) where @@ -46,7 +47,7 @@ case_Lift_tl1r :: Assertion case_Lift_tl1r = do ((), output) <- catchOutput tl1r - assertEqual "Test tl1r" (showLn input) output + assertOutput "Test tl1r" [show input] output where input = (5::Int) -- tl1r :: IO () @@ -56,9 +57,9 @@ case_Lift_tMd' :: Assertion case_Lift_tMd' = do - actual <- catchOutput tMd' - let expected = (output, (showLines input)) - assertEqual "Test mapMdebug using Lift" expected actual + (actualResult, actualOutput) <- catchOutput tMd' + let expected = (output, map show input) + assertEqual "Test mapMdebug using Lift" expected (actualResult, lines actualOutput) where input = [1..5] val = (10::Int) @@ -87,21 +88,23 @@ exfn False = return True testc m = catchDynE (m >>= return . show) (\ (MyException s) -> return s) +test1 m = do runLift (tf m True) >>= print; runLift (tf m False) >>= print +tf m x = runReader (x::Bool) . runState ([]::[String]) $ m +runErrorStr = runError @String + case_catchDynE_test1 :: Assertion case_catchDynE_test1 = do - ((), actual) <- catchOutput test1 - let expected = unlines [ "(\"thrown\",[\"begin\"])" - , "(\"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test1: exception shouldn't drop Writer's state" + ((), actual) <- catchOutput $ test1 (testc m) + let expected = [ "(\"thrown\",[\"begin\"])" + , "(\"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test1: exception shouldn't drop Writer's state" expected actual where -- In CatchMonadIO, the result of tf True is ("thrown",[]) -- -- that is, an exception will drop the Writer's state, even if that -- exception is caught. Here, the state is preserved! -- So, this is an advantage over MTL! - test1 = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ testc m m = do modify ("begin":) x <- ask @@ -112,18 +115,16 @@ -- Let us use an Error effect instead case_catchDynE_test1' :: Assertion case_catchDynE_test1' = do - ((), actual') <- catchOutput test1' - let expected' = unlines [ "(Left \"thrown\",[\"begin\"])" - , "(Right \"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test1': Error shouldn't drop Writer's state" + ((), actual') <- catchOutput $ test1 (runErrorStr (testc m)) + let expected' = [ "(Left \"thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test1': Error shouldn't drop Writer's state" expected' actual' where -- In CatchMonadIO, the result of tf True is ("thrown",[]) -- -- that is, an exception will drop the Writer's state, even if that -- exception is caught. Here, the state is preserved! -- So, this is an advantage over MTL! - test1' = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) m = do modify ("begin":) x <- ask @@ -131,27 +132,19 @@ modify ("end":) return r - runErrorStr = asEStr . runError - asEStr :: m (Either String a) -> m (Either String a) - asEStr = id exfn True = throwError $ ("thrown") exfn False = return True - -- Now, the behavior of the dynamic Exception and Error effect is consistent. -- The state is preserved. Before it wasn't. + case_catchDynE_test2 :: Assertion case_catchDynE_test2 = do - ((), actual) <- catchOutput test2 - let expected = unlines [ "(Left \"thrown\",[\"begin\"])" - , "(Right \"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test2: Error shouldn't drop Writer's state" + ((), actual) <- catchOutput $ test1 (runErrorStr (testc m)) + let expected = [ "(Left \"thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test2: Error shouldn't drop Writer's state" expected actual where - test2 = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) - runErrorStr = asEStr . runError - asEStr :: m (Either String a) -> m (Either String a) - asEStr = id m = do modify ("begin":) x <- ask @@ -162,17 +155,12 @@ -- Full recovery case_catchDynE_test2' :: Assertion case_catchDynE_test2' = do - ((), actual) <- catchOutput test2' - let expected = unlines [ "(Right \"False\",[\"end\",\"begin\"])" - , "(Right \"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test2': Fully recover from errors" + ((), actual) <- catchOutput $ test1 (runErrorStr (testc m)) + let expected = [ "(Right \"False\",[\"end\",\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test2': Fully recover from errors" expected actual where - test2' = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) - runErrorStr = asEStr . runError - asEStr :: m (Either String a) -> m (Either String a) - asEStr = id m = do modify ("begin":) x <- ask @@ -183,17 +171,12 @@ -- Throwing within a handler case_catchDynE_test3 :: Assertion case_catchDynE_test3 = do - ((), actual) <- catchOutput test3 - let expected = unlines [ "(Right \"rethrow:thrown\",[\"begin\"])" - , "(Right \"True\",[\"end\",\"begin\"])"] - assertEqual "catchDynE: test3: Throwing within a handler" + ((), actual) <- catchOutput $ test1 (runErrorStr (testc m)) + let expected = [ "(Right \"rethrow:thrown\",[\"begin\"])" + , "(Right \"True\",[\"end\",\"begin\"])"] + assertOutput "catchDynE: test3: Throwing within a handler" expected actual where - test3 = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m) - runErrorStr = asEStr . runError - asEStr :: m (Either String a) -> m (Either String a) - asEStr = id m = do modify ("begin":) x <- ask @@ -209,30 +192,24 @@ -- This is the ``scoping behavior'' of `Handlers in action' case_catchDynE_tran :: Assertion case_catchDynE_tran = do - ((), actual) <- catchOutput tran - let expected = unlines ["(\"thrown\",[\"init\"])" - ,"(\"True\",[\"end\",\"begin\",\"init\"])"] - assertEqual "catchDynE: tran: Transactional behaviour" - expected actual + ((), actual1) <- catchOutput $ test1 m1 + ((), actual2) <- catchOutput $ test1 m2 + let expected1 = ["(\"thrown\",[\"init\"])" + ,"(\"True\",[\"end\",\"begin\",\"init\"])"] + let expected2 = ["(\"thrown\",[\"begin\",\"init\"])" + ,"(\"True\",[\"end\",\"begin\",\"init\"])"] + assertOutput "catchDynE: tran: Transactional behaviour" expected1 actual1 + >> assertOutput "catchDynE: tran: usual behaviour" expected2 actual2 where - tran = do runLift (tf True) >>= print; runLift (tf False) >>= print - tf x = runReader (x :: Bool) . runState ([]::[String]) $ m1 m1 = do modify ("init":) testc (transactionState (TxState :: TxState [String]) m) + m2 = do + modify ("init":) + testc m m = do modify ("begin":) x <- ask r <- exfn x modify ("end":) return r -{- -- without transaction -("thrown",["begin","init"]) -("True",["end","begin","init"]) --} - --- With transaction -{- -("thrown",["init"]) -("True",["end","begin","init"]) --} diff --git a/test/Control/Eff/Trace/Test.hs b/test/Control/Eff/Trace/Test.hs --- a/test/Control/Eff/Trace/Test.hs +++ b/test/Control/Eff/Trace/Test.hs @@ -20,7 +20,7 @@ case_Trace_tdup = do ((), actual) <- catchOutput tdup assertEqual "Trace: duplicate layers" - (unlines ["Asked: 20", "Asked: 10"]) actual + ["Asked: 20", "Asked: 10"] (lines actual) where tdup = runTrace $ runReader (10::Int) m where diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,13 +1,11 @@ import Test.Framework (defaultMain, Test) import qualified Control.Eff.Test -import qualified Control.Eff.Choose.Test import qualified Control.Eff.Coroutine.Test -import qualified Control.Eff.Cut.Test import qualified Control.Eff.Example.Test import qualified Control.Eff.Exception.Test import qualified Control.Eff.Fresh.Test -import qualified Control.Eff.NdetEff.Test +import qualified Control.Eff.Logic.NDet.Test import qualified Control.Eff.Operational.Test import qualified Control.Eff.Reader.Lazy.Test import qualified Control.Eff.Reader.Strict.Test @@ -27,13 +25,11 @@ testGroups :: [Test] testGroups = [] ++ Control.Eff.Test.testGroups - ++ Control.Eff.Choose.Test.testGroups ++ Control.Eff.Coroutine.Test.testGroups - ++ Control.Eff.Cut.Test.testGroups ++ Control.Eff.Example.Test.testGroups ++ Control.Eff.Exception.Test.testGroups ++ Control.Eff.Fresh.Test.testGroups - ++ Control.Eff.NdetEff.Test.testGroups + ++ Control.Eff.Logic.NDet.Test.testGroups ++ Control.Eff.Operational.Test.testGroups ++ Control.Eff.Reader.Lazy.Test.testGroups ++ Control.Eff.Reader.Strict.Test.testGroups diff --git a/test/Utils.hs b/test/Utils.hs --- a/test/Utils.hs +++ b/test/Utils.hs @@ -14,12 +14,6 @@ catchOutput :: IO a -> IO (a, String) catchOutput f = swap `fmap` capture f -showLn :: Show a => a -> String -showLn x = unlines $ [show x] - -showLines :: Show a => [a] -> String -showLines xs = unlines $ map show xs - withError :: a -> ErrorCall -> a withError a _ = a @@ -28,6 +22,12 @@ assertNoUndefined :: a -> Assertion assertNoUndefined a = catch (seq a $ return ()) (withError $ assertFailure "") + +assertOutput :: String -> [String] -> String -> Assertion +assertOutput msg expected actual = assertEqual msg expected (lines actual) + +runAsserts :: (String -> a -> e -> Assertion) -> [(String, e, a)] -> Assertion +runAsserts run cases = forM_ cases $ \(prop, test, res) -> run prop res test allEqual :: Eq a => [a] -> Bool allEqual = all (uncurry (==)) . pairs