fused-effects 0.1.1.0 → 0.1.2.0
raw patch · 15 files changed
+507/−56 lines, 15 filesdep +QuickCheckdep ~base
Dependencies added: QuickCheck
Dependency ranges changed: base
Files
- ChangeLog.md +8/−0
- LICENSE +19/−20
- README.md +87/−13
- examples/Main.hs +4/−1
- examples/Parser.hs +134/−0
- fused-effects.cabal +18/−8
- src/Control/Effect.hs +2/−0
- src/Control/Effect/Carrier.hs +1/−0
- src/Control/Effect/Cull.hs +67/−0
- src/Control/Effect/Cut.hs +89/−0
- src/Control/Effect/Internal.hs +17/−0
- src/Control/Effect/NonDet.hs +12/−13
- src/Control/Effect/NonDet/Internal.hs +41/−1
- src/Control/Effect/Sum.hs +2/−0
- src/Control/Effect/Void.hs +6/−0
ChangeLog.md view
@@ -1,3 +1,11 @@+# 0.1.2.0++- Adds support for ghc 8.6.2, courtesy of @jkachmar.+- Adds a `Cut` effect which adds committed choice to nondeterminism.+- Adds a `Cull` effect which adds pruning to nondeterminism.+- Adds an example of using `NonDet`, `Cut`, and a character parser effect to define parsers.+- Fixes the table of contents links in the README.+ # 0.1.1.0 - Adds a `runNonDetOnce` handler which terminates immediately upon finding a solution.
LICENSE view
@@ -1,30 +1,29 @@-Copyright (c) 2018, Rob Rix and Patrick Thomson+BSD 3-Clause License +Copyright (c) 2018, Nicolas Wu, Tom Schrijvers, Rob Rix, and Patrick Thomson All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.+* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution. - * Neither the name of Rob Rix nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.+* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -2,21 +2,47 @@ [](https://travis-ci.com/robrix/fused-effects) -- [Overview](#overview)- - [Algebraic effects](#algebraic-effects)- - [Higher-order effects](#higher-order-effects)- - [Fusion](#fusion)-- [Usage](#usage)- - [Using built-in effects](#using-built-in-effects)- - [Running effects](#running-effects)- - [Defining new effects](#defining-new-effects)- - [Defining effect handlers](#defining-effect-handlers)-- [Benchmarks](#benchmarks)-- [Related work](#related-work)- - [Comparison to `mtl`](#comparison-to--mtl-)- - [Comparison to `freer-simple`](#comparison-to--freer-simple-)+- [Overview][]+ - [Algebraic effects][]+ - [Higher-order effects][]+ - [Fusion][]+- [Usage][]+ - [Using built-in effects][]+ - [Running effects][]+ - [Required compiler extensions][]+ - [Defining new effects][]+ - [Defining effect handlers][]+- [Project overview][]+ - [Development][]+ - [Versioning][]+- [Benchmarks][]+- [Related work][]+ - [Comparison to `mtl`][]+ - [Comparison to `freer-simple`][] +[Overview]: https://github.com/robrix/fused-effects#overview+[Algebraic effects]: https://github.com/robrix/fused-effects#algebraic-effects+[Higher-order effects]: https://github.com/robrix/fused-effects#higher-order-effects+[Fusion]: https://github.com/robrix/fused-effects#fusion +[Usage]: https://github.com/robrix/fused-effects#usage+[Using built-in effects]: https://github.com/robrix/fused-effects#using-built-in-effects+[Running effects]: https://github.com/robrix/fused-effects#running-effects+[Required compiler extensions]: https://github.com/robrix/fused-effects#required-compiler-extensions+[Defining new effects]: https://github.com/robrix/fused-effects#defining-new-effects+[Defining effect handlers]: https://github.com/robrix/fused-effects#defining-effect-handlers++[Project overview]: https://github.com/robrix/fused-effects#project-overview+[Development]: https://github.com/robrix/fused-effects#development+[Versioning]: https://github.com/robrix/fused-effects#versioning++[Benchmarks]: https://github.com/robrix/fused-effects#benchmarks++[Related work]: https://github.com/robrix/fused-effects#related-work+[Comparison to `mtl`]: https://github.com/robrix/fused-effects#comparison-to-mtl+[Comparison to `freer-simple`]: https://github.com/robrix/fused-effects#comparison-to-freer-simple++ ## Overview `fused-effects` is an effect system for Haskell emphasizing expressivity and efficiency. The former is achieved by encoding [algebraic](#algebraic-effects), [higher-order](#higher-order-effects) effects, while the latter is the result of [fusing](#fusion) effect handlers all the way through computations.@@ -125,7 +151,21 @@ (Note that we no longer need to give a type annotation for `list`, since `putStrLn` constrains the type for us.) +### Required compiler extensions +To use effects, you'll need a relatively-uncontroversial set of extensions: `-XFlexibleContexts`, `-XFlexibleInstances`, and `-XMultiParamTypeClasses`.++When defining your own effects, you'll need `-XTypeOperators` to declare a `Carrier` instance over (`:+:`), and `-XUndecidableInstances` to satisfy the coverage condition for this instance. `-XLambdaCase` provides a measure of syntactic convenience when handling an effect type with `handleSum.` You may need `-XKindSignatures` if GHC cannot correctly infer the type of your handler; see the [documentation on common errors][common] for more information about this case.++[common]: https://github.com/robrix/fused-effects/blob/master/docs/common_errors.md++The following invocation, taken from the teletype example, should suffice for any use or construction of effects:++```haskell+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,+ KindSignatures, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+```+ ### Defining new effects Effects are a powerful mechanism for abstraction, and so defining new effects is a valuable tool for system architecture. Effects are modelled as (higher-order) functors, with an explicit continuation denoting the remainder of the computation after the effect.@@ -230,6 +270,40 @@ Write s k -> liftIO (putStrLn s) >> k) ``` +## Project overview++This project builds a Haskell package named `fused-effects`. The library’s sources are in [`src`][], with doctests (property tests written in documentation comments) attached to most functions. Unit tests are in [`test`][], and library usage examples are in [`examples`][]. Further documentation can be found in [`docs`][].++This project adheres to the Contributor Covenant [code of conduct][]. By participating, you are expected to uphold this code.++Finally, this project is licensed under the BSD 3-clause [license][].++[`src`]: https://github.com/robrix/fused-effects/tree/master/src+[`test`]: https://github.com/robrix/fused-effects/tree/master/test+[`examples`]: https://github.com/robrix/fused-effects/tree/master/examples+[`docs`]: https://github.com/robrix/fused-effects/tree/master/docs+[code of conduct]: https://github.com/robrix/fused-effects/blob/master/CODE_OF_CONDUCT.md+[license]: https://github.com/robrix/fused-effects/blob/master/LICENSE.md+++### Development++Development of `fused-effects` is typically done using `cabal new-build`:++```shell+cabal new-build # build the library+cabal new-test # build and run the examples, unit tests, and doctests+```++The package is available on [hackage][], and can be used by adding it to a component’s `build-depends` field in your `.cabal` file.++[hackage]: http://hackage.haskell.org++### Versioning++Though `fused-effects` is suitable for production work, it is currently in a pre-release state. Though we will attempt to comply with the Haskell [Package Versioning Policy][pvp] standard, we make no concrete guarantees of API stability between versions < 1.0.0.0. Once v1.0.0.0 lands, all changes will abide by the PVP MAJOR.MAJOR.MINOR.PATCH standard.++[pvp]: https://pvp.haskell.org/faq/ ## Benchmarks
examples/Main.hs view
@@ -1,7 +1,10 @@ module Main where +import qualified Parser import qualified Teletype import Test.Hspec main :: IO ()-main = hspec Teletype.spec+main = hspec $ do+ Teletype.spec+ Parser.spec
+ examples/Parser.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveTraversable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, KindSignatures, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+module Parser+( spec+) where++import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Cut+import Control.Effect.NonDet+import Control.Effect.Sum hiding (L)+import Control.Monad (replicateM)+import Data.Char+import Data.Coerce+import Data.List (intercalate)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++spec :: Spec+spec = describe "parser" $ do+ describe "parse" $ do+ prop "returns pure values at the end of input" $+ \ a -> run (runNonDet (parse "" (pure a))) == [a :: Integer]++ prop "fails if input remains" $+ \ c cs a -> run (runNonDet (parse (c:cs) (pure (a :: Integer)))) == []++ describe "satisfy" $ do+ prop "matches with a predicate" $+ \ c f -> run (runNonDet (parse [c] (satisfy (applyFun f)))) == if applyFun f c then [c] else []++ prop "fails at end of input" $+ \ f -> run (runNonDet (parse "" (satisfy (applyFun f)))) == []++ prop "fails if input remains" $+ \ c1 c2 f -> run (runNonDet (parse [c1, c2] (satisfy (applyFun f)))) == []++ prop "consumes input" $+ \ c1 c2 f -> run (runNonDet (parse [c1, c2] ((,) <$> satisfy (applyFun f) <*> satisfy (applyFun f)))) == if applyFun f c1 && applyFun f c2 then [(c1, c2)] else []++ describe "factor" $ do+ prop "matches positive integers" $+ \ a -> run (runNonDet (runCut (parse (show (abs a)) factor))) == [abs a]++ prop "matches parenthesized expressions" . forAll (sized arbNested) $+ \ as -> run (runNonDet (runCut (parse ('(' : intercalate "+" (intercalate "*" . map (show . abs) . (1:) <$> [0]:as) ++ ")") factor))) == [sum (map (product . map abs) as)]++ describe "term" $ do+ prop "matches factors" $+ \ a -> run (runNonDet (runCut (parse (show (abs a)) term))) == [abs a]++ prop "matches multiplication" $+ \ as -> run (runNonDet (runCut (parse (intercalate "*" (show . abs <$> 1:as)) term))) == [product (map abs as)]++ describe "expr" $ do+ prop "matches factors" $+ \ a -> run (runNonDet (runCut (parse (show (abs a)) expr))) == [abs a]++ prop "matches multiplication" $+ \ as -> run (runNonDet (runCut (parse (intercalate "*" (show . abs <$> 1:as)) expr))) == [product (map abs as)]++ prop "matches addition" $+ \ as -> run (runNonDet (runCut (parse (intercalate "+" (show . abs <$> 0:as)) expr))) == [sum (map abs as)]++ prop "respects order of operations" . forAll (sized arbNested) $+ \ as -> run (runNonDet (runCut (parse (intercalate "+" (intercalate "*" . map (show . abs) . (1:) <$> [0]:as)) expr))) == [sum (map (product . map abs) as)]++ where arbNested :: Arbitrary a => Int -> Gen [[a]]+ arbNested 0 = pure []+ arbNested n = do+ Positive m <- arbitrary+ let n' = n `div` (m + 1)+ replicateM m (vector n')+++data Symbol (m :: * -> *) k = Satisfy (Char -> Bool) (Char -> k)+ deriving (Functor)++instance HFunctor Symbol where+ hmap _ = coerce+ {-# INLINE hmap #-}++instance Effect Symbol where+ handle state handler = coerce . fmap (handler . (<$ state))++satisfy :: (Carrier sig m, Member Symbol sig) => (Char -> Bool) -> m Char+satisfy p = send (Satisfy p ret)++char :: (Carrier sig m, Member Symbol sig) => Char -> m Char+char = satisfy . (==)++digit :: (Carrier sig m, Member Symbol sig) => m Char+digit = satisfy isDigit++parens :: (Applicative m, Carrier sig m, Member Symbol sig) => m a -> m a+parens m = char '(' *> m <* char ')'+++parse :: (Alternative m, Carrier sig m, Effect sig, Monad m) => String -> Eff (ParseC m) a -> m a+parse input = (>>= exhaustive) . flip runParseC input . interpret+ where exhaustive ("", a) = pure a+ exhaustive _ = empty++newtype ParseC m a = ParseC { runParseC :: String -> m (String, a) }++instance (Alternative m, Carrier sig m, Effect sig) => Carrier (Symbol :+: sig) (ParseC m) where+ ret a = ParseC (\ input -> ret (input, a))+ {-# INLINE ret #-}++ eff op = ParseC (\ input -> handleSum+ (eff . handleState input runParseC)+ (\ (Satisfy p k) -> case input of+ c:cs | p c -> runParseC (k c) cs+ _ -> empty)+ op)+ {-# INLINE eff #-}+++expr :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig, Monad m) => m Int+expr = do+ i <- term+ call ((i +) <$ char '+' <* cut <*> expr+ <|> pure i)++term :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig, Monad m) => m Int+term = do+ i <- factor+ call ((i *) <$ char '*' <* cut <*> term+ <|> pure i)++factor :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig, Monad m) => m Int+factor+ = read <$> some digit+ <|> parens expr
fused-effects.cabal view
@@ -1,13 +1,13 @@ name: fused-effects-version: 0.1.1.0+version: 0.1.2.0 synopsis: A fast, flexible, fused effect system. description: A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers. homepage: https://github.com/robrix/fused-effects license: BSD3 license-file: LICENSE-author: Rob Rix, Patrick Thomson+author: Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson maintainer: robrix@github.com-copyright: 2018 Rob Rix, Patrick Thomson+copyright: 2018 Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson category: Control build-type: Simple extra-source-files:@@ -17,10 +17,13 @@ tested-with: GHC == 8.2.2 , GHC == 8.4.4+ , GHC == 8.6.2 library exposed-modules: Control.Effect , Control.Effect.Carrier+ , Control.Effect.Cull+ , Control.Effect.Cut , Control.Effect.Error , Control.Effect.Fail , Control.Effect.Fail.Internal@@ -40,21 +43,28 @@ , Control.Effect.Trace , Control.Effect.Void , Control.Effect.Writer- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 , deepseq >=1.4.3 && <1.5 , MonadRandom >=0.5 && <0.6 , random hs-source-dirs: src default-language: Haskell2010+ ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations+ if (impl(ghc >= 8.4))+ ghc-options: -Wno-missing-export-lists+ if (impl(ghc >= 8.6))+ ghc-options: -Wno-star-is-type test-suite examples type: exitcode-stdio-1.0 main-is: Main.hs- other-modules: Teletype- build-depends: base >=4.9 && <4.12+ other-modules: Parser+ , Teletype+ build-depends: base >=4.9 && <4.13 , fused-effects , hspec >=2.4.1+ , QuickCheck >= 2.7 && < 2.12 hs-source-dirs: examples default-language: Haskell2010 @@ -63,7 +73,7 @@ main-is: Spec.hs other-modules: Control.Effect.Spec , Control.Effect.NonDet.Spec- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 , fused-effects , hspec >=2.4.1 hs-source-dirs: test@@ -72,7 +82,7 @@ test-suite doctest type: exitcode-stdio-1.0 main-is: Doctest.hs- build-depends: base >=4.9 && <4.12+ build-depends: base >=4.9 && <4.13 , doctest >=0.7 && <1.0 hs-source-dirs: test default-language: Haskell2010
src/Control/Effect.hs view
@@ -3,6 +3,8 @@ ) where import Control.Effect.Carrier as X (Carrier, Effect)+import Control.Effect.Cull as X (Cull, CullC)+import Control.Effect.Cut as X (Cut, CutC) import Control.Effect.Error as X (Error, ErrorC) import Control.Effect.Fail as X (Fail, FailC) import Control.Effect.Fresh as X (Fresh, FreshC)
src/Control/Effect/Carrier.hs view
@@ -21,6 +21,7 @@ fmap' :: (a -> b) -> (h m a -> h m b) default fmap' :: Functor (h m) => (a -> b) -> (h m a -> h m b) fmap' = fmap+ {-# INLINE fmap' #-} -- | Higher-order functor map of a natural transformation over higher-order positions within the effect. hmap :: (forall x . m x -> n x) -> (h m a -> h n a)
+ src/Control/Effect/Cull.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+module Control.Effect.Cull+( Cull(..)+, cull+, runCull+, CullC(..)+) where++import Control.Applicative (Alternative(..))+import Control.Effect.Carrier+import Control.Effect.Internal+import Control.Effect.NonDet.Internal+import Control.Effect.Sum++-- | 'Cull' effects are used with 'NonDet' to provide control over branching.+data Cull m k+ = forall a . Cull (m a) (a -> k)++deriving instance Functor (Cull m)++instance HFunctor Cull where+ hmap f (Cull m k) = Cull (f m) k+ {-# INLINE hmap #-}++instance Effect Cull where+ handle state handler (Cull m k) = Cull (handler (m <$ state)) (handler . fmap k)+ {-# INLINE handle #-}++-- | Cull nondeterminism in the argument, returning at most one result.+--+-- prop> run (runNonDet (runCull (cull (pure a <|> pure b)))) == [a]+-- prop> run (runNonDet (runCull (cull (pure a <|> pure b) <|> pure c))) == [a, c]+-- prop> run (runNonDet (runCull (cull (asum (map pure (repeat a)))))) == [a]+cull :: (Carrier sig m, Member Cull sig) => m a -> m a+cull m = send (Cull m ret)+++-- | Run a 'Cull' effect. Branches outside of any 'cull' block will not be pruned.+--+-- prop> run (runNonDet (runCull (pure a <|> pure b))) == [a, b]+runCull :: (Alternative m, Carrier sig m, Effect sig, Monad m) => Eff (CullC m) a -> m a+runCull = (>>= runBranch (const empty)) . flip runCullC False . interpret++newtype CullC m a = CullC { runCullC :: Bool -> m (Branch m () a) }++instance (Alternative m, Carrier sig m, Effect sig, Monad m) => Carrier (Cull :+: NonDet :+: sig) (CullC m) where+ ret = CullC . const . ret . Pure+ {-# INLINE ret #-}++ eff op = CullC (\ cull -> handleSum (handleSum+ (eff . handle (Pure ()) (bindBranch (flip runCullC cull)))+ (\case+ Empty -> ret (None ())+ Choose k -> runCullC (k True) cull >>= branch (const (runCullC (k False) cull)) (if cull then ret . Pure else \ a -> ret (Alt (ret a) (runCullC (k False) cull >>= runBranch (const empty)))) (fmap ret . Alt)))+ (\ (Cull m k) -> runCullC m True >>= bindBranch (flip runCullC cull . k))+ op)+ where bindBranch :: (Alternative m, Carrier sig m, Monad m) => (b -> m (Branch m () a)) -> Branch m () b -> m (Branch m () a)+ bindBranch bind = branch (const (ret (None ()))) bind (\ a b -> ret (Alt (a >>= bind >>= runBranch (const empty)) (b >>= bind >>= runBranch (const empty))))+ {-# INLINE eff #-}+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.NonDet+-- >>> import Control.Effect.Void+-- >>> import Data.Foldable (asum)
+ src/Control/Effect/Cut.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+module Control.Effect.Cut+( Cut(..)+, cutfail+, call+, cut+, runCut+, CutC(..)+) where++import Control.Applicative (Alternative(..))+import Control.Effect.Carrier+import Control.Effect.Internal+import Control.Effect.NonDet+import Control.Effect.Sum++-- | 'Cut' effects are used with 'NonDet' to provide control over backtracking.+data Cut m k+ = Cutfail+ | forall a . Call (m a) (a -> k)++deriving instance Functor (Cut m)++instance HFunctor Cut where+ hmap _ Cutfail = Cutfail+ hmap f (Call m k) = Call (f m) k+ {-# INLINE hmap #-}++instance Effect Cut where+ handle _ _ Cutfail = Cutfail+ handle state handler (Call m k) = Call (handler (m <$ state)) (handler . fmap k)+ {-# INLINE handle #-}++-- | Fail the current branch, and prevent backtracking within the nearest enclosing 'call' (if any).+--+-- Contrast with 'empty', which fails the current branch but allows backtracking.+--+-- prop> run (runNonDet (runCut (cutfail <|> pure a))) == []+-- prop> run (runNonDet (runCut (pure a <|> cutfail))) == [a]+cutfail :: (Carrier sig m, Member Cut sig) => m a+cutfail = send Cutfail+{-# INLINE cutfail #-}++-- | Delimit the effect of 'cutfail's, allowing backtracking to resume.+--+-- prop> run (runNonDet (runCut (call (cutfail <|> pure a) <|> pure b))) == [b]+call :: (Carrier sig m, Member Cut sig) => m a -> m a+call m = send (Call m ret)+{-# INLINE call #-}++-- | Commit to the current branch, preventing backtracking within the nearest enclosing 'call' (if any) on failure.+--+-- prop> run (runNonDet (runCut (pure a <|> cut *> pure b))) == [a, b]+-- prop> run (runNonDet (runCut (cut *> pure a <|> pure b))) == [a]+-- prop> run (runNonDet (runCut (cut *> empty <|> pure a))) == []+cut :: (Alternative m, Carrier sig m, Member Cut sig) => m ()+cut = pure () <|> cutfail+{-# INLINE cut #-}+++-- | Run a 'Cut' effect within an underlying 'Alternative' instance (typically 'Eff' carrying a 'NonDet' effect).+--+-- prop> run (runNonDetOnce (runCut (pure a))) == Just a+runCut :: (Alternative m, Carrier sig m, Effect sig, Monad m) => Eff (CutC m) a -> m a+runCut = (>>= runBranch (const empty)) . runCutC . interpret++newtype CutC m a = CutC { runCutC :: m (Branch m Bool a) }++instance (Alternative m, Carrier sig m, Effect sig, Monad m) => Carrier (Cut :+: NonDet :+: sig) (CutC m) where+ ret = CutC . ret . Pure+ {-# INLINE ret #-}++ eff = CutC . handleSum (handleSum+ (eff . handle (Pure ()) (bindBranch (ret (None False)) runCutC))+ (\case+ Empty -> ret (None True)+ Choose k -> runCutC (k True) >>= branch (\ e -> if e then runCutC (k False) else ret (None False)) (\ a -> ret (Alt (ret a) (runCutC (k False) >>= runBranch (const empty)))) (fmap ret . Alt)))+ (\case+ Cutfail -> ret (None False)+ Call m k -> runCutC m >>= bindBranch (ret (None True)) (runCutC . k))+ where bindBranch :: (Alternative m, Carrier sig m, Monad m) => m (Branch m Bool a) -> (b -> m (Branch m Bool a)) -> Branch m Bool b -> m (Branch m Bool a)+ bindBranch cut bind = branch (\ e -> if e then ret (None True) else cut) bind (\ a b -> ret (Alt (a >>= bind >>= runBranch (const empty)) (b >>= bind >>= runBranch (const empty))))+ {-# INLINE eff #-}+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void
src/Control/Effect/Internal.hs view
@@ -30,11 +30,14 @@ instance Functor (Eff carrier) where fmap = liftM+ {-# INLINE fmap #-} instance Applicative (Eff carrier) where pure a = Eff ($ a)+ {-# INLINE pure #-} (<*>) = ap+ {-# INLINE (<*>) #-} -- | Run computations nondeterministically. --@@ -60,35 +63,49 @@ -- prop> run (runNonDet (pure a <|> empty)) == (run (runNonDet (pure a)) :: Maybe Integer) instance (Member NonDet sig, Carrier sig carrier) => Alternative (Eff carrier) where empty = send Empty+ {-# INLINE empty #-} l <|> r = send (Choose (\ c -> if c then l else r))+ {-# INLINE (<|>) #-} instance Monad (Eff carrier) where return = pure+ {-# INLINE return #-} Eff m >>= f = Eff (\ k -> m (runEff k . f))+ {-# INLINE (>>=) #-} instance (Member Fail sig, Carrier sig carrier) => MonadFail (Eff carrier) where fail = send . Fail+ {-# INLINE fail #-} instance (Member NonDet sig, Carrier sig carrier) => MonadPlus (Eff carrier) instance (Member (Lift IO) sig, Carrier sig carrier) => MonadIO (Eff carrier) where liftIO = send . Lift . fmap pure+ {-# INLINE liftIO #-} instance (Member Random sig, Carrier sig carrier) => MonadRandom (Eff carrier) where getRandom = send (Random ret)+ {-# INLINE getRandom #-} getRandomR r = send (RandomR r ret)+ {-# INLINE getRandomR #-} getRandomRs interval = (:) <$> getRandomR interval <*> getRandomRs interval+ {-# INLINE getRandomRs #-} getRandoms = (:) <$> getRandom <*> getRandoms+ {-# INLINE getRandoms #-} instance (Member Random sig, Carrier sig carrier) => MonadInterleave (Eff carrier) where interleave m = send (Interleave m ret)+ {-# INLINE interleave #-} instance Carrier sig carrier => Carrier sig (Eff carrier) where ret = pure+ {-# INLINE ret #-}+ eff op = Eff (\ k -> eff (hmap (runEff ret) (fmap' (runEff k) op)))+ {-# INLINE eff #-} -- $setup
src/Control/Effect/NonDet.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, FlexibleInstances, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} module Control.Effect.NonDet ( NonDet(..) , Alternative(..)@@ -6,10 +6,14 @@ , AltC(..) , runNonDetOnce , OnceC(..)+, Branch(..)+, branch+, runBranch ) where import Control.Applicative (Alternative(..), liftA2) import Control.Effect.Carrier+import Control.Effect.Cull import Control.Effect.Internal import Control.Effect.NonDet.Internal import Control.Effect.Sum@@ -39,20 +43,15 @@ -- prop> run (runNonDetOnce (asum (map pure (repeat a)))) == [a] -- prop> run (runNonDetOnce (asum (map pure (repeat a)))) == Just a runNonDetOnce :: (Alternative f, Monad f, Traversable f, Carrier sig m, Effect sig, Monad m) => Eff (OnceC f m) a -> m (f a)-runNonDetOnce = runOnceC . interpret+runNonDetOnce = runNonDet . runCull . cull . runOnceC . interpret -newtype OnceC f m a = OnceC { runOnceC :: m (f a) }+newtype OnceC f m a = OnceC { runOnceC :: Eff (CullC (Eff (AltC f m))) a } -instance (Alternative f, Monad f, Traversable f, Carrier sig m, Effect sig, Monad m) => Carrier (NonDet :+: sig) (OnceC f m) where- ret a = OnceC (ret (pure a))- eff = OnceC . handleSum (eff . handleTraversable runOnceC) (\case- Empty -> ret empty- Choose k -> do- l <- runOnceC (k True)- if null l then- runOnceC (k False)- else- pure l)+instance (Alternative f, Carrier sig m, Effect sig, Traversable f, Monad f, Monad m) => Carrier (NonDet :+: sig) (OnceC f m) where+ ret = OnceC . ret+ eff = OnceC . handleSum (eff . R . R . R . handleCoercible) (\case+ Empty -> empty+ Choose k -> runOnceC (k True) <|> runOnceC (k False)) -- $setup
src/Control/Effect/NonDet/Internal.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE DeriveFunctor, KindSignatures #-}+{-# LANGUAGE DeriveTraversable, KindSignatures #-} module Control.Effect.NonDet.Internal ( NonDet(..)+, Branch(..)+, branch+, runBranch ) where +import Control.Applicative (Alternative(..)) import Control.Effect.Carrier import Data.Coerce @@ -18,3 +22,39 @@ instance Effect NonDet where handle _ _ Empty = Empty handle state handler (Choose k) = Choose (handler . (<$ state) . k)+++-- | The result of a nondeterministic branch of a computation.+--+-- 'Branch' can be used to define 'NonDet' carriers which control nondeterminism in some specific way, e.g. pruning branches according to some specific heuristic.+data Branch m e a+ = None e+ | Pure a+ | Alt (m a) (m a)+ deriving (Eq, Foldable, Functor, Ord, Show, Traversable)++-- | Case analysis for 'Branch', taking a value to use for 'Cut', a value to use for 'None', and a function to apply to the contents of 'Pure'.+--+-- prop> branch None Pure Alt a == (a :: Branch e [] a)+-- prop> branch (applyFun f) (applyFun g) (applyFun2 h) (None a :: Branch [] a) == applyFun f a+-- prop> branch (applyFun f) (applyFun g) (applyFun2 h) (Pure a :: Branch [] a) == applyFun g a+-- prop> branch (applyFun f) (applyFun g) (applyFun2 h) (Alt a b :: Branch [] a) == applyFun2 h a b+branch :: (e -> a) -> (b -> a) -> (m b -> m b -> a) -> Branch m e b -> a+branch f _ _ (None a) = f a+branch _ f _ (Pure a) = f a+branch _ _ f (Alt a b) = f a b+{-# INLINE branch #-}++-- | Interpret a 'Branch' into an underlying 'Alternative' context.+runBranch :: Alternative m => (e -> m a) -> Branch m e a -> m a+runBranch f = branch f pure (<|>)+{-# INLINE runBranch #-}+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void+-- >>> import Data.Foldable (asum)+-- >>> instance (Arbitrary1 m, Arbitrary e) => Arbitrary1 (Branch m e) where liftArbitrary arb = frequency [(1, None <$> arbitrary), (3, Pure <$> arb), (3, Alt <$> liftArbitrary arb <*> liftArbitrary arb)]+-- >>> instance (Arbitrary1 m, Arbitrary e, Arbitrary a) => Arbitrary (Branch m e a) where arbitrary = arbitrary1
src/Control/Effect/Sum.hs view
@@ -35,6 +35,7 @@ -> ((sig1 :+: sig2) m a -> b) handleSum alg1 _ (R op) = alg1 op handleSum _ alg2 (L op) = alg2 op+{-# INLINE handleSum #-} class Member (sub :: (* -> *) -> (* -> *)) sup where@@ -59,3 +60,4 @@ -- | Construct a request for an effect to be interpreted by some handler later on. send :: (Member effect sig, Carrier sig m) => effect m (m a) -> m a send = eff . inj+{-# INLINE send #-}
src/Control/Effect/Void.hs view
@@ -13,17 +13,23 @@ instance HFunctor Void where hmap _ v = case v of {}+ {-# INLINE hmap #-} instance Effect Void where handle _ _ v = case v of {}+ {-# INLINE handle #-} -- | Run an 'Eff' exhausted of effects to produce its final result value. run :: Eff VoidC a -> a run = runVoidC . interpret+{-# INLINE run #-} newtype VoidC a = VoidC { runVoidC :: a } instance Carrier Void VoidC where ret = VoidC+ {-# INLINE ret #-}+ eff v = case v of {}+ {-# INLINE eff #-}