freer-simple (empty) → 1.0.0.0

raw patch · 33 files changed

+2911/−0 lines, 33 filesdep +QuickCheckdep +basedep +criterionsetup-changed

Dependencies added: QuickCheck, base, criterion, extensible-effects, free, freer-simple, mtl, natural-transformation, tasty, tasty-hunit, tasty-quickcheck, transformers-base

Files

• CHANGELOG.md +3/−0
• LICENSE +30/−0
• README.md +114/−0
• Setup.hs +2/−0
• bench/Core.hs +162/−0
• examples/src/Capitalize.hs +18/−0
• examples/src/Console.hs +90/−0
• examples/src/Coroutine.hs +215/−0
• examples/src/Fresh.hs +16/−0
• examples/src/Main.hs +68/−0
• examples/src/Trace.hs +54/−0
• freer-simple.cabal +122/−0
• src/Control/Monad/Freer.hs +367/−0
• src/Control/Monad/Freer/Coroutine.hs +71/−0
• src/Control/Monad/Freer/Error.hs +54/−0
• src/Control/Monad/Freer/Fresh.hs +41/−0
• src/Control/Monad/Freer/Internal.hs +370/−0
• src/Control/Monad/Freer/NonDet.hs +55/−0
• src/Control/Monad/Freer/Reader.hs +137/−0
• src/Control/Monad/Freer/State.hs +109/−0
• src/Control/Monad/Freer/Trace.hs +34/−0
• src/Control/Monad/Freer/Writer.hs +37/−0
• src/Data/FTCQueue.hs +74/−0
• src/Data/OpenUnion.hs +78/−0
• src/Data/OpenUnion/Internal.hs +205/−0
• tests/Tests.hs +41/−0
• tests/Tests/Coroutine.hs +51/−0
• tests/Tests/Exception.hs +89/−0
• tests/Tests/Fresh.hs +24/−0
• tests/Tests/Loop.hs +38/−0
• tests/Tests/NonDet.hs +41/−0
• tests/Tests/Reader.hs +50/−0
• tests/Tests/State.hs +51/−0

@@ -0,0 +1,3 @@+# 1.0.0.0++- Initial release.

@@ -0,0 +1,30 @@+Copyright (c) 2016, Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King++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 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 Allele Dev nor the names of other+      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+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,114 @@+# Freer: Extensible Effects with Freer Monads [![Build Status](https://travis-ci.org/lexi-lambda/freer-simple.svg?branch=master)](https://travis-ci.org/lexi-lambda/freer-simple)++# Description++The `freer-simple` library (a fork of [`freer-effects`](http://hackage.haskell.org/package/freer-effects)) is an implementation of an effect system for Haskell, which is based on the work of Oleg Kiselyov et al.:++  - [Freer Monads, More Extensible Effects](http://okmij.org/ftp/Haskell/extensible/more.pdf)+  - [Reflection without Remorse](http://okmij.org/ftp/Haskell/zseq.pdf)+  - [Extensible Effects](http://okmij.org/ftp/Haskell/extensible/exteff.pdf)++Much of the implementation is a repackaging and cleaning up of the reference materials provided [here](http://okmij.org/ftp/Haskell/extensible/).++# Features++The key features of `freer-simple` are:++  - An efficient effect system for Haskell as a library.+  - Implementations for several common Haskell monads as effects:+    - `Reader`+    - `Writer`+    - `State`+    - `Trace`+    - `Error`+  - Core components for defining your own Effects.++# Example: Console DSL++Here's what using `freer-simple` looks like:++```haskell+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+module Console where++import Control.Monad.Freer+import System.Exit hiding (ExitCode(ExitSuccess))++--------------------------------------------------------------------------------+                               -- Effect Model --+--------------------------------------------------------------------------------+data Console r where+  PutStrLn    :: String -> Console ()+  GetLine     :: Console String+  ExitSuccess :: Console ()++putStrLn' :: Member Console effs => String -> Eff effs ()+putStrLn' = send . PutStrLn++getLine' :: Member Console effs => Eff effs String+getLine' = send GetLine++exitSuccess' :: Member Console effs => Eff effs ()+exitSuccess' = send ExitSuccess++--------------------------------------------------------------------------------+                          -- Effectful Interpreter --+--------------------------------------------------------------------------------+runConsole :: Eff '[Console, IO] a -> IO a+runConsole = runM . interpretM (\case+  PutStrLn msg -> putStrLn msg+  GetLine -> getLine+  ExitSuccess -> exitSuccess)++--------------------------------------------------------------------------------+                             -- Pure Interpreter --+--------------------------------------------------------------------------------+runConsolePure :: [String] -> Eff '[Console] w -> [String]+runConsolePure inputs req = snd . fst $+    run (runWriter (runState inputs (runError (reinterpret3 go req))))+  where+    go :: Console v -> Eff '[Error (), State [String], Writer [String]] v+    go (PutStrLn msg) = tell [msg]+    go GetLine = get >>= \case+      [] -> error "not enough lines"+      (x:xs) -> put xs >> pure x+    go ExitSuccess = throwError ()+```++# Contributing++Contributions are welcome! Documentation, examples, code, and feedback - they all help.+++## Developer Setup++The easiest way to start contributing is to install [stack](https://haskellstack.org/). Stack can install GHC/Haskell for you, and automates common developer tasks.++The key commands are:++  - `stack setup` — install required version of GHC compiler+  - `stack build` — builds project, dependencies are automatically resolved+  - `stack test` — builds project, its tests, and executes the tests+  - `stack bench` — builds project, its benchmarks, and executes the benchamks+  - `stack ghci` — start a REPL instance with a project modules loaded+  - `stack clean`+  - `stack haddock` — builds documentation++More information about `stack` can be found in its [documentation](https://haskellstack.org/).++# Licensing++This project is distributed under a BSD3 license. See the included LICENSE file for more details.++# Acknowledgements++The `freer-simple` package started as a fork of [freer-effects](http://hackage.haskell.org/package/freer-effects) by Ixperta Solutions, which in turn is a fork of [freer](http://hackage.haskell.org/package/freer) by Allele Dev. All implementations are based on the paper and reference implementation by Oleg Kiselyov. In particular:++  - `Data.OpenUnion` maps to [OpenUnion51.hs](http://okmij.org/ftp/Haskell/extensible/OpenUnion51.hs)+  - `Data.FTCQueue` maps to [FTCQueue1](http://okmij.org/ftp/Haskell/extensible/FTCQueue1.hs)+  - `Control.Monad.Freer*` maps to [Eff1.hs](http://okmij.org/ftp/Haskell/extensible/Eff1.hs)++There will be deviations from the source.

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

@@ -0,0 +1,162 @@+module Main (main) where++import Control.Monad (replicateM_)++import qualified Control.Monad.Except as MTL+import qualified Control.Monad.State as MTL+import qualified Control.Monad.Free as Free++import Criterion (bench, bgroup, whnf)+import Criterion.Main (defaultMain)++import Control.Monad.Freer (Member, Eff, run, send)+import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton)+import Control.Monad.Freer.Error (runError, throwError)+import Control.Monad.Freer.State (get, put, runState)++import qualified Control.Eff as EE+import qualified Control.Eff.Exception as EE+import qualified Control.Eff.State.Lazy as EE++--------------------------------------------------------------------------------+                        -- State Benchmarks --+--------------------------------------------------------------------------------++oneGet :: Int -> (Int, Int)+oneGet n = run (runState n get)++oneGetMTL :: Int -> (Int, Int)+oneGetMTL = MTL.runState MTL.get++oneGetEE :: Int -> (Int, Int)+oneGetEE n = EE.run $ EE.runState n EE.get++countDown :: Int -> (Int, Int)+countDown start = run (runState start go)+  where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)++countDownMTL :: Int -> (Int, Int)+countDownMTL = MTL.runState go+  where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)++countDownEE :: Int -> (Int, Int)+countDownEE start = EE.run $ EE.runState start go+  where go = EE.get >>= (\n -> if n <= 0 then pure n else EE.put (n-1) >> go)++--------------------------------------------------------------------------------+                       -- Exception + State --+--------------------------------------------------------------------------------+countDownExc :: Int -> Either String (Int,Int)+countDownExc start = run $ runError (runState start go)+  where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)++countDownExcMTL :: Int -> Either String (Int,Int)+countDownExcMTL = MTL.runStateT go+  where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)++countDownExcEE :: Int -> Either String (Int,Int)+countDownExcEE start = EE.run $ EE.runExc (EE.runState start go)+  where go = EE.get >>= (\n -> if n <= (0 :: Int) then EE.throwExc "wat" else EE.put (n-1) >> go)++--------------------------------------------------------------------------------+                          -- Freer: Interpreter --+--------------------------------------------------------------------------------+data Http out where+  Open :: String -> Http ()+  Close :: Http ()+  Post  :: String -> Http String+  Get   :: Http String++open' :: Member Http r => String -> Eff r ()+open'  = send . Open++close' :: Member Http r => Eff r ()+close' = send Close++post' :: Member Http r => String -> Eff r String+post' = send . Post++get' :: Member Http r => Eff r String+get' = send Get++runHttp :: Eff (Http ': r) w -> Eff r w+runHttp (Val x) = pure x+runHttp (E u q) = case decomp u of+  Right (Open _) -> runHttp (qApp q ())+  Right Close    -> runHttp (qApp q ())+  Right (Post d) -> runHttp (qApp q d)+  Right Get      -> runHttp (qApp q "")+  Left u'        -> E u' (tsingleton (runHttp . qApp q ))++--------------------------------------------------------------------------------+                          -- Free: Interpreter --+--------------------------------------------------------------------------------+data FHttpT x+  = FOpen String x+  | FClose x+  | FPost String (String -> x)+  | FGet (String -> x)+    deriving Functor++type FHttp = Free.Free FHttpT++fopen' :: String -> FHttp ()+fopen' s = Free.liftF $ FOpen s ()++fclose' :: FHttp ()+fclose' = Free.liftF $ FClose ()++fpost' :: String -> FHttp String+fpost' s = Free.liftF $ FPost s id++fget' :: FHttp String+fget' = Free.liftF $ FGet id++runFHttp :: FHttp a -> Maybe a+runFHttp (Free.Pure x) = pure x+runFHttp (Free.Free (FOpen _ n)) = runFHttp n+runFHttp (Free.Free (FClose n))  = runFHttp n+runFHttp (Free.Free (FPost s n)) = pure s  >>= runFHttp . n+runFHttp (Free.Free (FGet n))    = pure "" >>= runFHttp . n++--------------------------------------------------------------------------------+                        -- Benchmark Suite --+--------------------------------------------------------------------------------+prog :: Member Http r => Eff r ()+prog = open' "cats" >> get' >> post' "cats" >> close'++prog' :: FHttp ()+prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose'++p :: Member Http r => Int -> Eff r ()+p count   =  open' "cats" >> replicateM_ count (get' >> post' "cats") >>  close'++p' :: Int -> FHttp ()+p' count  = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose'++main :: IO ()+main =+  defaultMain [+    bgroup "State" [+        bench "freer.get"          $ whnf oneGet 0+      , bench "mtl.get"            $ whnf oneGetMTL 0+      , bench "ee.get"             $ whnf oneGetEE 0+    ],+    bgroup "Countdown Bench" [+        bench "freer.State"    $ whnf countDown 10000+      , bench "mtl.State"      $ whnf countDownMTL 10000+      , bench "ee.State"       $ whnf countDownEE 10000+    ],+    bgroup "Countdown+Except Bench" [+        bench "freer.ExcState"  $ whnf countDownExc 10000+      , bench "mtl.ExceptState" $ whnf countDownExcMTL 10000+      , bench "ee.ExcState"     $ whnf countDownExcEE 10000+    ],+    bgroup "HTTP Simple DSL" [+        bench "freer" $ whnf (run . runHttp) prog+      , bench "free" $ whnf runFHttp prog'++      , bench "freerN"      $ whnf (run . runHttp . p) 1000+      , bench "freeN"       $ whnf (runFHttp . p')     1000+    ]+  ]

@@ -0,0 +1,18 @@+module Capitalize+  ( Capitalize+  , capitalize+  , runCapitalize+  ) where++import Data.Char (toUpper)++import Control.Monad.Freer (Eff, Member, interpret, send)++data Capitalize v where+  Capitalize :: String -> Capitalize String++capitalize :: Member Capitalize r => String -> Eff r String+capitalize = send . Capitalize++runCapitalize :: Eff (Capitalize ': r) w -> Eff r w+runCapitalize = interpret $ \(Capitalize s) -> pure (map toUpper s)

@@ -0,0 +1,90 @@+module Console+  ( Console+  , exitSuccess'+  , getLine'+  , putStrLn'+  , runConsole+  , runConsoleM+  , runConsolePure+  , runConsolePureM+  ) where++import Data.Function ((&))+import System.Exit (exitSuccess)++import Control.Monad.Freer (Eff, LastMember, Member, interpretM, reinterpret3, run, runM, send)+import Control.Monad.Freer.Error (Error, runError, throwError)+import Control.Monad.Freer.State (State, get, put, runState)+import Control.Monad.Freer.Writer (Writer, runWriter, tell)+++-------------------------------------------------------------------------------+                          -- Effect Model --+-------------------------------------------------------------------------------+data Console s where+  PutStrLn    :: String -> Console ()+  GetLine     :: Console String+  ExitSuccess :: Console ()++putStrLn' :: Member Console r => String -> Eff r ()+putStrLn' = send . PutStrLn++getLine'  :: Member Console r => Eff r String+getLine' = send GetLine++exitSuccess' :: Member Console r => Eff r ()+exitSuccess' = send ExitSuccess++-------------------------------------------------------------------------------+                     -- Effectful Interpreter Simple --+-------------------------------------------------------------------------------+runConsole :: Eff '[Console, IO] a -> IO a+runConsole = runM . interpretM (\case+  PutStrLn msg -> putStrLn msg+  GetLine -> getLine+  ExitSuccess -> exitSuccess)++-------------------------------------------------------------------------------+                        -- Pure Interpreter Simple --+-------------------------------------------------------------------------------+runConsolePure :: [String] -> Eff '[Console] w -> [String]+runConsolePure inputs req = snd . fst $+    run (runWriter (runState inputs (runError (reinterpret3 go req))))+  where+    go :: Console v -> Eff '[Error (), State [String], Writer [String]] v+    go (PutStrLn msg) = tell [msg]+    go GetLine = get >>= \case+      [] -> error "not enough lines"+      (x:xs) -> put xs >> pure x+    go ExitSuccess = throwError ()++-------------------------------------------------------------------------------+                     -- Effectful Interpreter for Deeper Stack --+-------------------------------------------------------------------------------+runConsoleM :: forall effs a. LastMember IO effs+            => Eff (Console ': effs) a -> Eff effs a+runConsoleM = interpretM $ \case+  PutStrLn msg -> putStrLn msg+  GetLine -> getLine+  ExitSuccess -> exitSuccess++-------------------------------------------------------------------------------+                     -- Pure Interpreter for Deeper Stack --+-------------------------------------------------------------------------------+runConsolePureM+  :: forall effs w+   . [String]+  -> Eff (Console ': effs) w+  -> Eff effs (Maybe w, [String], [String])+runConsolePureM inputs req = do+    ((x, inputs'), output) <- reinterpret3 go req+      & runError & runState inputs & runWriter+    pure (either (const Nothing) Just x, inputs', output)+  where+    go :: Console v+       -> Eff (Error () ': State [String] ': Writer [String] ': effs) v+    go (PutStrLn msg) = tell [msg]+    go GetLine = get >>= \case+      [] -> error "not enough lines"+      (x:xs) -> put xs >> pure x+    go ExitSuccess = throwError ()

@@ -0,0 +1,215 @@+module Coroutine () where++-- import Control.Monad.Freer.Coroutine++{-++-- First example of coroutines+yieldInt :: Member (Yield Int ()) r => Int -> Eff r ()+yieldInt = yield++th1 :: Member (Yield Int ()) r => Eff r ()+th1 = yieldInt 1 >> yieldInt 2+++c1 = runTrace (loop =<< runC th1)+ where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+       loop Done    = trace "Done"+{-+1+2+Done+-}++-- Add dynamic variables+-- The code is essentially the same as that in transf.hs (only added+-- a type specializtion on yield). The inferred signature is different though.+-- Before it was+--    th2 :: MonadReader Int m => CoT Int m ()+-- Now it is more general:+th2 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r ()+th2 = ask >>= yieldInt >> (ask >>= yieldInt)+++-- Code is essentially the same as in transf.hs; no liftIO though+c2 = runTrace $ runReader (loop =<< runC th2) (10::Int)+ where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+       loop Done    = trace "Done"+{-+10+10+Done+-}++-- locally changing the dynamic environment for the suspension+c21 = runTrace $ runReader (loop =<< runC th2) (10::Int)+ where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+       loop Done    = trace "Done"+{-+10+11+Done+-}++-- Real example, with two sorts of local rebinding+th3 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r ()+th3 = ay >> ay >> local (+(10::Int)) (ay >> ay)+ where ay = ask >>= yieldInt++c3 = runTrace $ runReader (loop =<< runC th3) (10::Int)+ where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+       loop Done    = trace "Done"+{-+10+10+20+20+Done+-}++-- locally changing the dynamic environment for the suspension+c31 = runTrace $ runReader (loop =<< runC th3) (10::Int)+ where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+       loop Done    = trace "Done"+{-+10+11+21+21+Done+-}+-- The result is exactly as expected and desired: the coroutine shares the+-- dynamic environment with its parent; however, when the environment+-- is locally rebound, it becomes private to coroutine.++-- We now make explicit that the client computation, run by th4,+-- is abstract. We abstract it out of th4+c4 = runTrace $ runReader (loop =<< runC (th4 client)) (10::Int)+ where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+       loop Done    = trace "Done"++       -- cl, client, ay are monomorphic bindings+       th4 cl = cl >> local (+(10::Int)) cl+       client = ay >> ay+       ay     = ask >>= yieldInt++{-+10+11+21+21+Done+-}++-- Even more dynamic example+c5 = runTrace $ runReader (loop =<< runC (th client)) (10::Int)+ where loop (Y x k) = trace (show (x::Int)) >> local (\y->x+1) (k ()) >>= loop+       loop Done    = trace "Done"++       -- cl, client, ay are monomorphic bindings+       client = ay >> ay >> ay+       ay     = ask >>= yieldInt++       -- There is no polymorphic recursion here+       th cl = do+         cl+         v <- ask+         (if v > (20::Int) then id else local (+(5::Int))) cl+         if v > (20::Int) then return () else local (+(10::Int)) (th cl)+{-+10+11+12+18+18+18+29+29+29+29+29+29+Done+-}++-- And even more+c7 = runTrace $+      runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double)+ where loop (Y x k) = trace (show (x::Int)) >>+                      local (\y->fromIntegral (x+1)::Double) (k ()) >>= loop+       loop Done    = trace "Done"++       -- cl, client, ay are monomorphic bindings+       client = ay >> ay >> ay+       ay     = ask >>= \x -> ask >>=+                 \y -> yieldInt (x + round (y::Double))++       -- There is no polymorphic recursion here+       th cl = do+         cl+         v <- ask+         (if v > (20::Int) then id else local (+(5::Int))) cl+         if v > (20::Int) then return () else local (+(10::Int)) (th cl)++{-+1010+1021+1032+1048+1064+1080+1101+1122+1143+1169+1195+1221+1252+1283+1314+1345+1376+1407+Done+-}++c7' = runTrace $+      runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double)+ where loop (Y x k) = trace (show (x::Int)) >>+                      local (\y->fromIntegral (x+1)::Double) (k ()) >>= loop+       loop Done    = trace "Done"++       -- cl, client, ay are monomorphic bindings+       client = ay >> ay >> ay+       ay     = ask >>= \x -> ask >>=+                 \y -> yieldInt (x + round (y::Double))++       -- There is no polymorphic recursion here+       th cl = do+         cl+         v <- ask+         (if v > (20::Int) then id else local (+(5::Double))) cl+         if v > (20::Int) then return () else local (+(10::Int)) (th cl)+{-+1010+1021+1032+1048+1048+1048+1069+1090+1111+1137+1137+1137+1168+1199+1230+1261+1292+1323+Done+-}++-}

@@ -0,0 +1,16 @@+module Fresh (module Fresh) where++import Control.Monad.Freer.Fresh (evalFresh, fresh)+import Control.Monad.Freer.Trace (runTrace, trace)++-- | Generate two fresh values.+--+-- >>> traceFresh+-- Fresh 0+-- Fresh 1+traceFresh :: IO ()+traceFresh = runTrace $ evalFresh 0 $ do+  n <- fresh+  trace $ "Fresh " ++ show n+  n' <- fresh+  trace $ "Fresh " ++ show n'

@@ -0,0 +1,68 @@+module Main (main) where++import Control.Monad (forever, when)+import Data.Maybe (fromMaybe)+import Data.List (intercalate)+import System.Environment (getArgs)++import Control.Monad.Freer (Eff, Member, run, runM)++import Capitalize (Capitalize, capitalize, runCapitalize)+import Console+  ( Console+  , exitSuccess'+  , getLine'+  , putStrLn'+  , runConsolePureM+  , runConsoleM+  )+import Coroutine ()+import Fresh ()+import Trace ()++-------------------------------------------------------------------------------+-- Example+-------------------------------------------------------------------------------+capitalizingService :: (Member Console r, Member Capitalize r) => Eff r ()+capitalizingService = forever $ do+    putStrLn' "Send something to capitalize..."+    l <- getLine'+    when (null l) exitSuccess'+    capitalize l >>= putStrLn'+-------------------------------------------------------------------------------++mainPure :: IO ()+mainPure = print . run+    . runConsolePureM ["cat", "fish", "dog", "bird", ""]+    $ runCapitalize capitalizingService++mainConsoleA :: IO ()+mainConsoleA = runM (runConsoleM (runCapitalize capitalizingService))+--             |     |            |             |+--      IO () -'     |            |             |+--     Eff '[IO] () -'            |             |+--         Eff '[Console, IO] () -'             |+--           Eff '[Capitalize, Console, IO] () -'++mainConsoleB :: IO ()+mainConsoleB = runM (runCapitalize (runConsoleM capitalizingService))+--             |     |              |           |+--      IO () -'     |              |           |+--     Eff '[IO] () -'              |           |+--        Eff '[Capitalize, IO] () -'           |+--           Eff '[Console, Capitalize, IO] () -'++examples :: [(String, IO ())]+examples =+    [ ("pure", mainPure)+    , ("consoleA", mainConsoleA)+    , ("consoleB", mainConsoleB)+    ]++main :: IO ()+main = getArgs >>= \case+    [x] -> fromMaybe e $ lookup x examples+    _ -> e+  where+    e = putStrLn msg+    msg = "Usage: prog [" ++ intercalate "|" (map fst examples) ++ "]"

@@ -0,0 +1,54 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++module Trace (module Trace) where++import Control.Applicative ((<$>), (<*>), pure)+import Data.Function (($))+import Data.Int (Int)+import Data.Monoid ((<>))+import System.IO (IO)+import Text.Show (Show(show))++import Control.Monad.Freer (Eff, Member)+import Control.Monad.Freer.Reader (ask, runReader)+import Control.Monad.Freer.Trace (Trace, runTrace, trace)+++-- Higher-order effectful function+-- The inferred type shows that the Trace affect is added to the effects+-- of r+mapMdebug:: (Show a, Member Trace r) =>+     (a -> Eff r b) -> [a] -> Eff r [b]+mapMdebug _ [] = pure []+mapMdebug f (h:t) = do+  trace $ "mapMdebug: " <> show h+  h' <- f h+  t' <- mapMdebug f t+  pure (h':t')++tMd :: IO [Int]+tMd = runTrace $ runReader (10::Int) (mapMdebug f [1..5])+ where f x = (+) <$> ask <*> pure x+{-+mapMdebug: 1+mapMdebug: 2+mapMdebug: 3+mapMdebug: 4+mapMdebug: 5+[11,12,13,14,15]+-}++-- duplicate layers+tdup :: IO ()+tdup = runTrace $ runReader (10::Int) m+ where+ m = do+     runReader (20::Int) tr+     tr+ tr = do+      v <- ask+      trace $ "Asked: " <> show (v::Int)+{-+Asked: 20+Asked: 10+-}

@@ -0,0 +1,122 @@+-- This file has been generated from package.yaml by hpack version 0.18.1.+--+-- see: https://github.com/sol/hpack++name:           freer-simple+version:        1.0.0.0+synopsis:       Implementation of a friendly effect system for Haskell.+description:    An implementation of an effect system for Haskell (a fork of+                <http://hackage.haskell.org/package/freer-effects freer-effects>), which is+                based on the work of Oleg Kiselyov et al.:+                .+                  * <http://okmij.org/ftp/Haskell/extensible/more.pdf Freer Monads, More Extensible Effects>+                  * <http://okmij.org/ftp/Haskell/zseq.pdf Reflection without Remorse>+                  * <http://okmij.org/ftp/Haskell/extensible/exteff.pdf Extensible Effects>+                .+                The key features are:+                .+                  * An efficient effect system for Haskell - as a library!+                  * Reimplementations of several common Haskell monad transformers as effects.+                  * Core components for defining your own Effects.+category:       Control+homepage:       https://github.com/lexi-lambda/freer-simple#readme+bug-reports:    https://github.com/lexi-lambda/freer-simple/issues+author:         Allele Dev, Ixcom Core Team, Alexis King, and other contributors+maintainer:     Alexis King <lexi.lambda@gmail.com>+copyright:      (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    CHANGELOG.md+    README.md++source-repository head+  type: git+  location: https://github.com/lexi-lambda/freer-simple++library+  hs-source-dirs:+      src+  default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >= 4.9 && < 5+    , natural-transformation >= 0.2+    , transformers-base+  exposed-modules:+      Control.Monad.Freer+      Control.Monad.Freer.Coroutine+      Control.Monad.Freer.Error+      Control.Monad.Freer.Fresh+      Control.Monad.Freer.Internal+      Control.Monad.Freer.NonDet+      Control.Monad.Freer.Reader+      Control.Monad.Freer.State+      Control.Monad.Freer.Trace+      Control.Monad.Freer.Writer+      Data.FTCQueue+      Data.OpenUnion+      Data.OpenUnion.Internal+  other-modules:+      Paths_freer_simple+  default-language: Haskell2010++executable freer-examples+  main-is: Main.hs+  hs-source-dirs:+      examples/src+  default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >= 4.9 && < 5+    , freer-simple+  other-modules:+      Capitalize+      Console+      Coroutine+      Fresh+      Trace+  default-language: Haskell2010++test-suite unit+  type: exitcode-stdio-1.0+  main-is: Tests.hs+  hs-source-dirs:+      tests+  default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >= 4.9 && < 5+    , QuickCheck+    , freer-simple+    , tasty+    , tasty-hunit+    , tasty-quickcheck+  other-modules:+      Tests.Coroutine+      Tests.Exception+      Tests.Fresh+      Tests.Loop+      Tests.NonDet+      Tests.Reader+      Tests.State+  default-language: Haskell2010++benchmark core+  type: exitcode-stdio-1.0+  main-is: Core.hs+  hs-source-dirs:+      bench+  default-extensions: ConstraintKinds DataKinds DeriveFunctor FlexibleContexts FlexibleInstances FunctionalDependencies GADTs LambdaCase MultiParamTypeClasses RankNTypes ScopedTypeVariables TypeApplications TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -O2+  build-depends:+      base >= 4.9 && < 5+    , criterion+    , extensible-effects+    , free+    , freer-simple+    , mtl+  default-language: Haskell2010

@@ -0,0 +1,367 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{-|+Module:       Control.Monad.Freer+Description:  Freer - an extensible effects library+Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+License:      BSD3+Maintainer:   Alexis King <lexi.lambda@gmail.com>+Stability:    experimental+Portability:  GHC specific language extensions.++This library is an implementation of an /extensible effect system/ for Haskell,+a general-purpose way of tracking effects at the type level and handling them in+different ways. The concept of an “effect” is very general: it encompasses the+things most people consider side-effects, like generating random values,+interacting with the file system, and mutating state, but it also includes+things like access to an immutable global environment and exception handling.++Traditional Haskell tracks and composes effects using /monad transformers/,+which involves modeling each effects using what is conceptually a separate+monad. In contrast, @freer-simple@ provides exactly __one__ monad, 'Eff',+parameterized by a type-level list of effects. For example, a computation that+produces an 'Integer' by consuming a 'String' from the global environment and+acting upon a single mutable cell containing a 'Bool' would have the following+type:++@+'Eff' '['Control.Monad.Freer.Reader.Reader' 'String', 'Control.Monad.Freer.State.State' 'Bool'] 'Integer'+@++For comparison, this is the equivalent stack of monad transformers:++@+ReaderT 'String' (State 'Bool') 'Integer'+@++However, this is slightly misleading: the example with 'Eff' is actually+/more general/ than the corresponding example using transformers because the+implementations of effects are not /concrete/. While @StateT@ specifies a+/specific/ implementation of a pseudo-mutable cell,+'Control.Monad.Freer.State.State' is merely an interface with a set of available+operations. Using 'Control.Monad.Freer.State.runState' will “run” the+'Control.Monad.Freer.State.State' effect much the same way that @StateT@ does,+but a hypothetical handler function @runStateTVar@ could implement the state in+terms of a STM 'Control.Concurrent.STM.TVar'.++The @freer-simple@ effect library is divided into three parts:++  1. First, @freer-simple@ provides the 'Eff' monad, an implementation of+     extensible effects that allows effects to be tracked at the type level and+     interleaved at runtime.++  2. Second, it provides a built-in library of common effects, such as+     'Control.Monad.Freer.Reader.Reader', 'Control.Monad.Freer.Writer.Writer',+     'Control.Monad.Freer.State.State', and 'Control.Monad.Freer.Error.Error'.+     These effects can be used with 'Eff' out of the box with an interface that+     is similar to the equivalent monad transformers.++  3. Third, it provides a set of combinators for implementing your /own/+     effects, which can either be implemented entirely independently, in terms+     of other existing effects, or even in terms of existing monads, making it+     possible to use @freer-simple@ with existing monad transformer stacks.++One of the core ideas of @freer-simple@ is that /most/ effects that occur in+practical applications are really different incarnations of a small set of+fundamental effect types. Therefore, while it’s possible to write new effect+handlers entirely from scratch, it’s more common that you will wish to define+new effects in terms of other effects. @freer-simple@ makes this possible by+providing the 'reinterpret' function, which allows /translating/ an effect into+another one.++For example, imagine an effect that represents interactions with a file system:++@+data FileSystem r where+  ReadFile :: 'FilePath' -> FileSystem 'String'+  WriteFile :: 'FilePath' -> 'String' -> FileSystem ()+@++An implementation that uses the real file system would, of course, be+implemented in terms of 'IO'. An alternate implementation, however, might be+implemented in-memory in terms of 'Control.Monad.Freer.State.State'. With+'reinterpret', this implementation is trivial:++@+runInMemoryFileSystem :: [('FilePath', 'String')] -> 'Eff' (FileSystem ': effs) '~>' 'Eff' effs+runInMemoryFileSystem initVfs = 'Control.Monad.Freer.State.runState' initVfs '.' fsToState where+  fsToState :: 'Eff' (FileSystem ': effs) '~>' 'Eff' ('Control.Monad.Freer.State.State' [('FilePath', 'String')] ': effs)+  fsToState = 'reinterpret' '$' \case+    ReadFile path -> 'Control.Monad.Freer.State.get' '>>=' \\vfs -> case 'lookup' path vfs of+      'Just' contents -> 'pure' contents+      'Nothing' -> 'error' ("readFile: no such file " ++ path)+    WriteFile path contents -> 'Control.Monad.Freer.State.modify' $ \\vfs ->+      (path, contents) : 'Data.List.delete' (path, contents) vfs+@++This handler is easy to write, doesn’t require any knowledge of how+'Control.Monad.Freer.State.State' is implemented, is entirely encapsulated, and+is composable with all other effect handlers. This idea—making it easy to define+new effects in terms of existing ones—is the concept around which @freer-simple@+is based.++= Effect Algebras++In @freer-simple@, effects are defined using /effect algebras/, which are+representations of an effect’s operations as a generalized algebraic datatype,+aka GADT. This might sound intimidating, but you really don’t need to know very+much at all about how GADTs work to use @freer-simple@; instead, you can just+learn the syntax entirely in terms of what it means for defining effects.++Consider the definition of the @FileSystem@ effect from the above example:++@+data FileSystem r where+  ReadFile :: 'FilePath' -> FileSystem 'String'+  WriteFile :: 'FilePath' -> 'String' -> FileSystem ()+@++The first line, @data FileSystem r where@, defines a new effect. All effects+have at least one parameter, normally named @r@, which represents the /result/+or /return type/ of the operation. For example, take a look at the type of+@ReadFile@:++@+ReadFile :: 'FilePath' -> FileSystem 'String'+@++This is very similar to the type of 'readFile' from the standard "Prelude",+which has type @'FilePath' -> 'IO' 'String'@. The only difference is that the+name of the effect, in this case @FileSystem@, replaces the use of the monad,+in this case 'IO'.++Also notice that @ReadFile@ and @WriteFile@ begin with capital letters. This is+because they are actually /data constructors/. This means that+@ReadFile "foo.txt"@ actually constructs a /value/ of type+@FileSystem 'String'@, and this is useful, since it allows effect handlers like+@runInMemoryFileSystem@ to pattern-match on the effect’s constructors and get+the values out.++To actually /use/ our @FileSystem@ effect, however, we have to write just a+little bit of glue to connect our effect definition to the 'Eff' monad, which we+do using the 'send' function. We can write an ordinary function for each of the+@FileSystem@ constructors that mechanically calls 'send':++@+readFile :: 'Member' FileSystem effs => 'FilePath' -> 'Eff' effs 'String'+readFile path = 'send' (ReadFile path)++writeFile :: 'Member' FileSystem effs => 'FilePath' -> 'String' -> 'Eff' effs ()+writeFile path contents = 'send' (WriteFile path contents)+@++Notice the use of the 'Member' constraint on these functions. This constraint+means that the 'FileSystem' effect can be anywhere within the type-level list+represented by the @effs@ variable. If the signature of 'readFile' were more+concrete, like this:++@+readFile :: 'FilePath' -> 'Eff' '[FileSystem] 'String'+@++…then 'readFile' would /only/ be usable with an 'Eff' computation that /only/+performed @FileSystem@ effects, which isn’t especially useful.+-}+module Control.Monad.Freer+  ( -- * Effect Monad+    Eff++    -- ** Effect Constraints+    -- | As mentioned in the documentation for 'Eff', it’s rare to actually+    -- specify a concrete list of effects for an 'Eff' computation, since that+    -- has two significant downsides:+    --+    --   1. It couples the computation to that /specific/ list of effects, so it+    --      cannot be used in functions that perform a strict superset of+    --      effects.+    --+    --   2. It forces the effects to be handled in a particular order, which+    --      can make handler code brittle when the list of effects is changed.+    --+    -- Fortunately, these restrictions are easily avoided by using+    -- /effect constraints/, such as 'Member' or 'Members', which decouple a+    -- computation from a particular concrete list of effects.+  , Member+  , Members+  , LastMember++    -- ** Sending Arbitrary Effects+  , send+  , sendM++    -- ** Lifting Effect Stacks+  , raise++    -- * Handling Effects+    -- | Once an effectful computation has been produced, it needs to somehow be+    -- executed. This is where /effect handlers/ come in. Each effect can have+    -- an arbitrary number of different effect handlers, which can be used to+    -- interpret the same effects in different ways. For example, it is often+    -- useful to have two effect handlers: one that uses 'sendM' and+    -- 'interpretM' to interpret the effect in 'IO', and another that uses+    -- 'interpret', 'reinterpret', or 'translate' to interpret the effect in an+    -- entirely pure way for the purposes of testing.+    --+    -- This module doesn’t provide any effects or effect handlers (those are in+    -- their own modules, like "Control.Monad.Freer.Reader" and+    -- "Control.Monad.Freer.Error"), but it /does/ provide a set of combinators+    -- for constructing new effect handlers. It also provides the 'run' and+    -- 'runM' functions for extracting the actual result of an effectful+    -- computation once all effects have been handled.++    -- ** Running the Eff monad+  , run+  , runM++    -- ** Building Effect Handlers+    -- *** Basic effect handlers+  , interpret+  , interpose+    -- *** Derived effect handlers+  , reinterpret+  , reinterpret2+  , reinterpret3+  , reinterpretN+  , translate+    -- *** Monadic effect handlers+  , interpretM+    -- *** Advanced effect handlers+  , interpretWith+  , interposeWith+  ) where++import Control.Natural (type (~>))++import qualified Control.Monad.Freer.Internal as Internal++import Control.Monad.Freer.Internal+  ( Eff+  , LastMember+  , Member+  , Members+  , Weakens+  , (:++:)+  , handleRelay+  , raise+  , replaceRelay+  , replaceRelayN+  , run+  , runM+  , send+  , sendM+  )++-- | The simplest way to produce an effect handler. Given a natural+-- transformation from some effect @eff@ to some effectful computation with+-- effects @effs@, produces a natural transformation from @'Eff' (eff ': effs)@+-- to @'Eff' effs@.+interpret :: forall eff effs. (eff ~> Eff effs) -> Eff (eff ': effs) ~> Eff effs+interpret f = interpretWith (\e -> (f e >>=))+{-# INLINE interpret #-}++-- | Like 'interpret', but instead of handling the effect, allows responding to+-- the effect while leaving it unhandled.+interpose :: forall eff effs. Member eff effs => (eff ~> Eff effs) -> Eff effs ~> Eff effs+interpose f = interposeWith (\e -> (f e >>=))+{-# INLINE interpose #-}++-- | Like 'interpret', but instead of removing the interpreted effect @f@,+-- reencodes it in some new effect @g@.+reinterpret :: forall f g effs. (f ~> Eff (g ': effs)) -> Eff (f ': effs) ~> Eff (g ': effs)+reinterpret f = replaceRelay pure (\e -> (f e >>=))+{-# INLINE reinterpret #-}++-- | Like 'reinterpret', but encodes the @f@ effect in /two/ new effects instead+-- of just one.+reinterpret2+  :: forall f g h effs+   . (f ~> Eff (g ': h ': effs)) -> Eff (f ': effs) ~> Eff (g ': h ': effs)+reinterpret2 = reinterpretN @[g, h]+{-# INLINE reinterpret2 #-}++-- | Like 'reinterpret', but encodes the @f@ effect in /three/ new effects+-- instead of just one.+reinterpret3+  :: forall f g h i effs+   . (f ~> Eff (g ': h ': i ': effs))+  -> Eff (f ': effs) ~> Eff (g ': h ': i ': effs)+reinterpret3 = reinterpretN @[g, h, i]+{-# INLINE reinterpret3 #-}++-- | Like 'interpret', 'reinterpret', 'reinterpret2', and 'reinterpret3', but+-- allows the result to have any number of additional effects instead of simply+-- 0-3. The problem is that this completely breaks type inference, so you will+-- have to explicitly pick @gs@ using @TypeApplications@. Prefer 'interpret',+-- 'reinterpret', 'reinterpret2', or 'reinterpret3' where possible.+reinterpretN+  :: forall gs f effs. Weakens gs+  => (f ~> Eff (gs :++: effs)) -> Eff (f ': effs) ~> Eff (gs :++: effs)+reinterpretN f = replaceRelayN @gs pure (\e -> (f e >>=))+{-# INLINE reinterpretN #-}++-- | Runs an effect by translating it into another effect. This is effectively a+-- more restricted form of 'reinterpret', since both produce a natural+-- transformation from @'Eff' (f ': effs)@ to @'Eff' (g ': effs)@ for some+-- effects @f@ and @g@, but 'translate' does not permit using any of the other+-- effects in the implementation of the interpreter.+--+-- In practice, this difference in functionality is not particularly useful, and+-- 'reinterpret' easily subsumes all of the functionality of 'translate', but+-- the way 'translate' restricts the result leads to much better type inference.+--+-- @+-- 'translate' f = 'reinterpret' ('send' . f)+-- @+translate :: forall f g effs. (f ~> g) -> Eff (f ': effs) ~> Eff (g ': effs)+translate f = reinterpret (send . f)+{-# INLINE translate #-}++-- | Like 'interpret', this function runs an effect without introducing another+-- one. Like 'translate', this function runs an effect by translating it into+-- another effect in isolation, without access to the other effects in @effs@.+-- Unlike either of those functions, however, this runs the effect in a final+-- monad in @effs@, intended to be run with 'runM'.+--+-- @+-- 'interpretM' f = 'interpret' ('sendM' . f)+-- @+interpretM+  :: forall eff effs m+   . (Monad m, LastMember m effs)+  => (eff ~> m) -> Eff (eff ': effs) ~> Eff effs+interpretM f = interpret (sendM . f)+{-# INLINE interpretM #-}++-- | A highly general way of handling an effect. Like 'interpret', but+-- explicitly passes the /continuation/, a function of type @v -> 'Eff' effs b@,+-- to the handler function. Most handlers invoke this continuation to resume the+-- computation with a particular value as the result, but some handlers may+-- return a value without resumption, effectively aborting the computation to+-- the point where the handler is invoked. This is useful for implementing+-- things like 'Control.Monad.Freer.Error.catchError', for example.+--+-- @+-- 'interpret' f = 'interpretWith' (\e -> (f e '>>='))+-- @+interpretWith+  :: forall eff effs b+   . (forall v. eff v -> (v -> Eff effs b) -> Eff effs b)+  -> Eff (eff ': effs) b+  -> Eff effs b+interpretWith = handleRelay pure+{-# INLINE interpretWith #-}++-- | Combines the interposition behavior of 'interpose' with the+-- continuation-passing capabilities of 'interpretWith'.+--+-- @+-- 'interpose' f = 'interposeWith' (\e -> (f e '>>='))+-- @+interposeWith+  :: forall eff effs b+   . Member eff effs+  => (forall v. eff v -> (v -> Eff effs b) -> Eff effs b)+  -> Eff effs b+  -> Eff effs b+interposeWith = Internal.interpose pure+{-# INLINE interposeWith #-}

@@ -0,0 +1,71 @@+-- |+-- Module:       Control.Monad.Freer.Coroutine+-- Description:  Composable coroutine effects layer.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- An effect to compose functions with the ability to yield.+--+-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.Coroutine+  ( -- * Yield Control+    Yield(..)+  , yield++    -- * Handle Yield Effect+  , Status(..)+  , runC+  , interposeC+  , replyC+  ) where++import Control.Monad.Freer.Internal (Eff, Member, handleRelay, interpose, send)++-- | A type representing a yielding of control.+--+-- Type variables have following meaning:+--+-- [@a@]+--   The current type.+--+-- [@b@]+--   The input to the continuation function.+--+-- [@c@]+--   The output of the continuation.+data Yield a b c = Yield a (b -> c)+  deriving (Functor)++-- | Lifts a value and a function into the Coroutine effect.+yield :: Member (Yield a b) effs => a -> (b -> c) -> Eff effs c+yield x f = send (Yield x f)++-- | Represents status of a coroutine.+data Status effs a b r+  = Done r+  -- ^ Coroutine is done with a result value of type @r@.+  | Continue a (b -> Eff effs (Status effs a b r))+  -- ^ Reporting a value of the type @a@, and resuming with the value of type+  -- @b@, possibly ending with a value of type @x@.++-- | Reply to a coroutine effect by returning the Continue constructor.+replyC+  :: Yield a b c+  -> (c -> Eff effs (Status effs a b r))+  -> Eff effs (Status effs a b r)+replyC (Yield a k) arr = pure $ Continue a (arr . k)++-- | Launch a coroutine and report its status.+runC :: Eff (Yield a b ': effs) r -> Eff effs (Status effs a b r)+runC = handleRelay (pure . Done) replyC++-- | Launch a coroutine and report its status, without handling (removing)+-- 'Yield' from the typelist. This is useful for reducing nested coroutines.+interposeC+  :: Member (Yield a b) effs+  => Eff effs r+  -> Eff effs (Status effs a b r)+interposeC = interpose (pure . Done) replyC

@@ -0,0 +1,54 @@+-- |+-- Module:       Control.Monad.Freer.Error+-- Description:  An Error effect and handler.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- Composable handler for Error effects. Communicates success\/failure via an+-- 'Either' type.+--+-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.Error+  ( Error(..)+  , throwError+  , runError+  , catchError+  , handleError+  ) where++import Control.Monad.Freer (Eff, Member, interposeWith, interpretWith, send)+import Control.Monad.Freer.Internal (handleRelay)++-- | Exceptions of the type @e :: *@ with no resumption.+newtype Error e r where+  Error :: e -> Error e r++-- | Throws an error carrying information of type @e :: *@.+throwError :: forall e effs a. Member (Error e) effs => e -> Eff effs a+throwError e = send (Error e)++-- | Handler for exception effects. If there are no exceptions thrown, returns+-- 'Right'. If exceptions are thrown and not handled, returns 'Left', while+-- interrupting the execution of any other effect handlers.+runError :: forall e effs a. Eff (Error e ': effs) a -> Eff effs (Either e a)+runError = handleRelay (pure . Right) (\(Error e) _ -> pure (Left e))++-- | A catcher for Exceptions. Handlers are allowed to rethrow exceptions.+catchError+  :: forall e effs a+   . Member (Error e) effs+  => Eff effs a+  -> (e -> Eff effs a)+  -> Eff effs a+catchError m handle = interposeWith (\(Error e) _ -> handle e) m++-- | A catcher for Exceptions. Handlers are /not/ allowed to rethrow exceptions.+handleError+  :: forall e effs a+   . Eff (Error e ': effs) a+  -> (e -> Eff effs a)+  -> Eff effs a+handleError m handle = interpretWith (\(Error e) _ -> handle e) m

@@ -0,0 +1,41 @@+-- |+-- Module:       Control.Monad.Freer.Fresh+-- Description:  Generation of fresh integers as an effect.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- Composable handler for 'Fresh' effects. This is likely to be of use when+-- implementing De Bruijn naming/scopes.+--+-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.++module Control.Monad.Freer.Fresh+  ( Fresh(..)+  , fresh+  , runFresh+  , evalFresh+  ) where++import Control.Monad.Freer.Internal (Eff, Member, handleRelayS, send)++-- | Fresh effect model.+data Fresh r where+  Fresh :: Fresh Int++-- | Request a fresh effect.+fresh :: Member Fresh effs => Eff effs Int+fresh = send Fresh++-- | Handler for 'Fresh' effects, with an 'Int' for a starting value. The+-- return value includes the next fresh value.+runFresh :: Int -> Eff (Fresh ': effs) a -> Eff effs (a, Int)+runFresh s =+  handleRelayS s (\s' a -> pure (a, s')) (\s' Fresh k -> (k $! s' + 1) s')++-- | Handler for 'Fresh' effects, with an 'Int' for a starting value. Discards+-- the next fresh value.+evalFresh :: Int -> Eff (Fresh ': effs) a -> Eff effs a+evalFresh s = fmap fst . runFresh s

@@ -0,0 +1,370 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- Due to sendM.+{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- The following is needed to define MonadPlus instance. It is decidable+-- (there is no recursion!), but GHC cannot see that.+--+-- TODO: Remove once GHC can deduce the decidability of this instance.+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module:       Control.Monad.Freer.Internal+-- Description:  Mechanisms to make effects work.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- Internal machinery for this effects library. This includes:+--+-- * 'Eff' data type, for expressing effects.+-- * 'NonDet' data type, for nondeterministic effects.+-- * Functions for facilitating the construction of effects and their handlers.+--+-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.Internal+  ( -- * Effect Monad+    Eff(..)+  , Arr+  , Arrs++    -- ** Open Union+    --+    -- | Open Union (type-indexed co-product) of effects.+  , module Data.OpenUnion++    -- ** Fast Type-aligned Queue+    --+    -- | Fast type-aligned queue optimized to effectful functions of type+    -- @(a -> m b)@.+  , module Data.FTCQueue++    -- ** Sending Arbitrary Effect+  , send+  , sendM++    -- ** Lifting Effect Stacks+  , raise++    -- * Handling Effects+  , run+  , runM++    -- ** Building Effect Handlers+  , handleRelay+  , handleRelayS+  , interpose+  , interposeS+  , replaceRelay+  , replaceRelayS+  , replaceRelayN++    -- *** Low-level Functions for Building Effect Handlers+  , qApp+  , qComp++    -- ** Nondeterminism Effect+  , NonDet(..)+  ) where++import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus(..))+import Control.Monad.Base (MonadBase, liftBase)+import Control.Monad.IO.Class (MonadIO, liftIO)++import Data.FTCQueue+import Data.OpenUnion++-- | Effectful arrow type: a function from @a :: *@ to @b :: *@ that also does+-- effects denoted by @effs :: [* -> *]@.+type Arr effs a b = a -> Eff effs b++-- | An effectful function from @a :: *@ to @b :: *@ that is a composition of+-- several effectful functions. The paremeter @eff :: [* -> *]@ describes the+-- overall effect. The composition members are accumulated in a type-aligned+-- queue.+type Arrs effs a b = FTCQueue (Eff effs) a b++-- | The 'Eff' monad provides the implementation of a computation that performs+-- an arbitrary set of algebraic effects. In @'Eff' effs a@, @effs@ is a+-- type-level list that contains all the effects that the computation may+-- perform. For example, a computation that produces an 'Integer' by consuming a+-- 'String' from the global environment and acting upon a single mutable cell+-- containing a 'Bool' would have the following type:+--+-- @+-- 'Eff' '['Control.Monad.Freer.Reader.Reader' 'String', 'Control.Monad.Freer.State.State' 'Bool'] 'Integer'+-- @+--+-- Normally, a concrete list of effects is not used to parameterize 'Eff'.+-- Instead, the 'Member' or 'Members' constraints are used to express+-- constraints on the list of effects without coupling a computation to a+-- concrete list of effects. For example, the above example would more commonly+-- be expressed with the following type:+--+-- @+-- 'Members' '['Control.Monad.Freer.Reader.Reader' 'String', 'Control.Monad.Freer.State.State' 'Bool'] effs => 'Eff' effs 'Integer'+-- @+--+-- This abstraction allows the computation to be used in functions that may+-- perform other effects, and it also allows the effects to be handled in any+-- order.+data Eff effs a+  = Val a+  -- ^ Pure value (@'return' = 'pure' = 'Val'@).+  | forall b. E (Union effs b) (Arrs effs b a)+  -- ^ Sending a request of type @Union effs@ with the continuation+  -- @'Arrs' r b a@.++-- | Function application in the context of an array of effects,+-- @'Arrs' effs b w@.+qApp :: Arrs effs b w -> b -> Eff effs w+qApp q' x = case tviewl q' of+  TOne k  -> k x+  k :| t -> case k x of+    Val y -> qApp t y+    E u q -> E u (q >< t)++-- | Composition of effectful arrows ('Arrs'). Allows for the caller to change+-- the effect environment, as well.+qComp :: Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c+qComp g h a = h $ qApp g a++instance Functor (Eff effs) where+  fmap f (Val x) = Val (f x)+  fmap f (E u q) = E u (q |> (Val . f))+  {-# INLINE fmap #-}++instance Applicative (Eff effs) where+  pure = Val+  {-# INLINE pure #-}++  Val f <*> Val x = Val $ f x+  Val f <*> E u q = E u (q |> (Val . f))+  E u q <*> m     = E u (q |> (`fmap` m))+  {-# INLINE (<*>) #-}++instance Monad (Eff effs) where+  Val x >>= k = k x+  E u q >>= k = E u (q |> k)+  {-# INLINE (>>=) #-}++instance (MonadBase b m, LastMember m effs) => MonadBase b (Eff effs) where+  liftBase = sendM . liftBase+  {-# INLINE liftBase #-}++instance (MonadIO m, LastMember m effs) => MonadIO (Eff effs) where+  liftIO = sendM . liftIO+  {-# INLINE liftIO #-}++-- | “Sends” an effect, which should be a value defined as part of an effect+-- algebra (see the module documentation for "Control.Monad.Freer"), to an+-- effectful computation. This is used to connect the definition of an effect to+-- the 'Eff' monad so that it can be used and handled.+send :: Member eff effs => eff a -> Eff effs a+send t = E (inj t) (tsingleton Val)+{-# INLINE send #-}++-- | Identical to 'send', but specialized to the final effect in @effs@ to+-- assist type inference. This is useful for running actions in a monad+-- transformer stack used in conjunction with 'runM'.+sendM :: (Monad m, LastMember m effs) => m a -> Eff effs a+sendM = send+{-# INLINE sendM #-}++--------------------------------------------------------------------------------+                       -- Base Effect Runner --+--------------------------------------------------------------------------------++-- | Runs a pure 'Eff' computation, since an 'Eff' computation that performs no+-- effects (i.e. has no effects in its type-level list) is guaranteed to be+-- pure. This is usually used as the final step of running an effectful+-- computation, after all other effects have been discharged using effect+-- handlers.+--+-- Typically, this function is composed as follows:+--+-- @+-- someProgram+--   'Data.Function.&' runEff1 eff1Arg+--   'Data.Function.&' runEff2 eff2Arg1 eff2Arg2+--   'Data.Function.&' 'run'+-- @+run :: Eff '[] a -> a+run (Val x) = x+run _       = error "Internal:run - This (E) should never happen"++-- | Like 'run', 'runM' runs an 'Eff' computation and extracts the result.+-- /Unlike/ 'run', 'runM' allows a single effect to remain within the type-level+-- list, which must be a monad. The value returned is a computation in that+-- monad, which is useful in conjunction with 'sendM' or 'liftBase' for plugging+-- in traditional transformer stacks.+runM :: Monad m => Eff '[m] a -> m a+runM (Val x) = return x+runM (E u q) = case extract u of+  mb -> mb >>= runM . qApp q+  -- The other case is unreachable since Union [] a cannot be constructed.+  -- Therefore, run is a total function if its argument terminates.++-- | Like 'replaceRelay', but with support for an explicit state to help+-- implement the interpreter.+replaceRelayS+  :: s+  -> (s -> a -> Eff (v ': effs) w)+  -> (forall x. s -> t x -> (s -> Arr (v ': effs) x w) -> Eff (v ': effs) w)+  -> Eff (t ': effs) a+  -> Eff (v ': effs) w+replaceRelayS s' pure' bind = loop s'+  where+    loop s (Val x)  = pure' s x+    loop s (E u' q) = case decomp u' of+        Right x -> bind s x k+        Left  u -> E (weaken u) (tsingleton (k s))+      where+        k s'' x = loop s'' $ qApp q x+{-# INLINE replaceRelayS #-}++-- | Interpret an effect by transforming it into another effect on top of the+-- stack. The primary use case of this function is allow interpreters to be+-- defined in terms of other ones without leaking intermediary implementation+-- details through the type signature.+replaceRelay+  :: (a -> Eff (v ': effs) w)+  -> (forall x. t x -> Arr (v ': effs) x w -> Eff (v ': effs) w)+  -> Eff (t ': effs) a+  -> Eff (v ': effs) w+replaceRelay pure' bind = loop+  where+    loop (Val x)  = pure' x+    loop (E u' q) = case decomp u' of+        Right x -> bind x k+        Left  u -> E (weaken u) (tsingleton k)+      where+        k = qComp q loop+{-# INLINE replaceRelay #-}++replaceRelayN+  :: forall gs t a effs w+   . Weakens gs+  => (a -> Eff (gs :++: effs) w)+  -> (forall x. t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w)+  -> Eff (t ': effs) a+  -> Eff (gs :++: effs) w+replaceRelayN pure' bind = loop+  where+    loop :: Eff (t ': effs) a -> Eff (gs :++: effs) w+    loop (Val x)  = pure' x+    loop (E u' (q :: Arrs (t ': effs) b a)) = case decomp u' of+        Right x -> bind x k+        Left  u -> E (weakens @gs u) (tsingleton k)+      where+        k :: Arr (gs :++: effs) b w+        k = qComp q loop+{-# INLINE replaceRelayN #-}++-- | Given a request, either handle it or relay it.+handleRelay+  :: (a -> Eff effs b)+  -- ^ Handle a pure value.+  -> (forall v. eff v -> Arr effs v b -> Eff effs b)+  -- ^ Handle a request for effect of type @eff :: * -> *@.+  -> Eff (eff ': effs) a+  -> Eff effs b+  -- ^ Result with effects of type @eff :: * -> *@ handled.+handleRelay ret h = loop+  where+    loop (Val x)  = ret x+    loop (E u' q) = case decomp u' of+        Right x -> h x k+        Left  u -> E u (tsingleton k)+      where+        k = qComp q loop+{-# INLINE handleRelay #-}++-- | Parameterized 'handleRelay'. Allows sending along some state of type+-- @s :: *@ to be handled for the target effect, or relayed to a handler that+-- can- handle the target effect.+handleRelayS+  :: s+  -> (s -> a -> Eff effs b)+  -- ^ Handle a pure value.+  -> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)+  -- ^ Handle a request for effect of type @eff :: * -> *@.+  -> Eff (eff ': effs) a+  -> Eff effs b+  -- ^ Result with effects of type @eff :: * -> *@ handled.+handleRelayS s' ret h = loop s'+  where+    loop s (Val x)  = ret s x+    loop s (E u' q) = case decomp u' of+        Right x -> h s x k+        Left  u -> E u (tsingleton (k s))+      where+        k s'' x = loop s'' $ qApp q x+{-# INLINE handleRelayS #-}++-- | Intercept the request and possibly reply to it, but leave it unhandled.+interpose+  :: Member eff effs+  => (a -> Eff effs b)+  -> (forall v. eff v -> Arr effs v b -> Eff effs b)+  -> Eff effs a+  -> Eff effs b+interpose ret h = loop+  where+    loop (Val x) = ret x+    loop (E u q) = case prj u of+        Just x -> h x k+        _      -> E u (tsingleton k)+      where+        k = qComp q loop+{-# INLINE interpose #-}++-- | Like 'interpose', but with support for an explicit state to help implement+-- the interpreter.+interposeS+  :: Member eff effs+  => s+  -> (s -> a -> Eff effs b)+  -> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)+  -> Eff effs a+  -> Eff effs b+interposeS s' ret h = loop s'+  where+    loop s (Val x) = ret s x+    loop s (E u q) = case prj u of+        Just x -> h s x k+        _      -> E u (tsingleton (k s))+      where+        k s'' x = loop s'' $ qApp q x+{-# INLINE interposeS #-}++-- | Embeds a less-constrained 'Eff' into a more-constrained one. Analogous to+-- MTL's 'lift'.+raise :: Eff effs a -> Eff (e ': effs) a+raise = loop+  where+    loop (Val x) = pure x+    loop (E u q) = E (weaken u) . tsingleton $ qComp q loop+{-# INLINE raise #-}++--------------------------------------------------------------------------------+                    -- Nondeterministic Choice --+--------------------------------------------------------------------------------++-- | A data type for representing nondeterminstic choice.+data NonDet a where+  MZero :: NonDet a+  MPlus :: NonDet Bool++instance Member NonDet effs => Alternative (Eff effs) where+  empty = mzero+  (<|>) = mplus++instance Member NonDet effs => MonadPlus (Eff effs) where+  mzero       = send MZero+  mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2

@@ -0,0 +1,55 @@+-- |+-- Module:       Control.Monad.Freer.NonDet+-- Description:  Non deterministic effects+-- Copyright:    2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- Composable handler for 'NonDet' effects.+module Control.Monad.Freer.NonDet+  ( NonDet(..)+  , makeChoiceA+  , msplit+  ) where++import Control.Applicative (Alternative, (<|>), empty)+import Control.Monad (msum)++import Control.Monad.Freer.Internal+  ( Eff(..)+  , Member+  , NonDet(..)+  , handleRelay+  , prj+  , qApp+  , qComp+  , tsingleton+  )++-- | A handler for nondeterminstic effects.+makeChoiceA+  :: Alternative f+  => Eff (NonDet ': effs) a+  -> Eff effs (f a)+makeChoiceA = handleRelay (pure . pure) $ \m k ->+  case m of+    MZero -> pure empty+    MPlus -> (<|>) <$> k True <*> k False++msplit+  :: Member NonDet effs+  => Eff effs a+  -> Eff effs (Maybe (a, Eff effs a))+msplit = loop []+  where+    loop jq (Val x) = pure (Just (x, msum jq))+    loop jq (E u q) = case prj u of+        Just MZero -> case jq of+          []      -> pure Nothing+          (j:jq') -> loop jq' j+        Just MPlus -> loop (qApp q False : jq) (qApp q True)+        Nothing    -> E u (tsingleton k)+      where+        k = qComp q (loop jq)

@@ -0,0 +1,137 @@+-- |+-- Module:       Control.Monad.Freer.Reader+-- Description:  Reader effects, for encapsulating an environment.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- Composable handler for 'Reader' effects. Handy for encapsulating an+-- environment with immutable state for interpreters.+--+-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.Reader+  ( -- * Reader Effect+    Reader(..)++    -- * Reader Operations+  , ask+  , asks+  , local++    -- * Reader Handlers+  , runReader++    -- * Example 1: Simple Reader Usage+    -- $simpleReaderExample++    -- * Example 2: Modifying Reader Content With @local@+    -- $localExample+  ) where++import Control.Monad.Freer (Eff, Member, interpose, interpret, send)++-- | Represents shared immutable environment of type @(e :: *)@ which is made+-- available to effectful computation.+data Reader r a where+  Ask :: Reader r r++-- | Request a value of the environment.+ask :: forall r effs. Member (Reader r) effs => Eff effs r+ask = send Ask++-- | Request a value of the environment, and apply as selector\/projection+-- function to it.+asks+  :: forall r effs a+   . Member (Reader r) effs+  => (r -> a)+  -- ^ The selector\/projection function to be applied to the environment.+  -> Eff effs a+asks f = f <$> ask++-- | Handler for 'Reader' effects.+runReader :: forall r effs a. r -> Eff (Reader r ': effs) a -> Eff effs a+runReader r = interpret (\Ask -> pure r)++-- | 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.+local+  :: forall r effs a. Member (Reader r) effs+  => (r -> r)+  -> Eff effs a+  -> Eff effs a+local f m = do+  r <- asks f+  interpose @(Reader r) (\Ask -> pure r) m++-- $simpleReaderExample+--+-- In this example the 'Reader' effect provides access to variable bindings.+-- Bindings are a @Map@ of integer variables. The variable @count@ contains+-- number of variables in the bindings. You can see how to run a Reader effect+-- and retrieve data from it with 'runReader', how to access the Reader data+-- with 'ask' and 'asks'.+--+-- > import Control.Monad.Freer+-- > import Control.Monad.Freer.Reader+-- > import Data.Map as Map+-- > import Data.Maybe+-- >+-- > type Bindings = Map String Int+-- >+-- > -- Returns True if the "count" variable contains correct bindings size.+-- > isCountCorrect :: Bindings -> Bool+-- > isCountCorrect bindings = run $ runReader bindings calc_isCountCorrect+-- >+-- > -- The Reader effect, which implements this complicated check.+-- > calc_isCountCorrect :: Eff '[Reader Bindings] Bool+-- > calc_isCountCorrect = do+-- >   count <- asks (lookupVar "count")+-- >   bindings <- (ask :: Eff '[Reader Bindings] Bindings)+-- >   return (count == (Map.size bindings))+-- >+-- > -- The selector function to  use with 'asks'.+-- > -- Returns value of the variable with specified name.+-- > lookupVar :: String -> Bindings -> Int+-- > lookupVar name bindings = fromJust (Map.lookup name bindings)+-- >+-- > sampleBindings :: Map.Map String Int+-- > sampleBindings = Map.fromList [("count",3), ("1",1), ("b",2)]+-- >+-- > main :: IO ()+-- > main = putStrLn+-- >   $ "Count is correct for bindings " ++ show sampleBindings ++ ": "+-- >   ++ show (isCountCorrect sampleBindings)++-- $localExample+--+-- Shows how to modify 'Reader' content with 'local'.+--+-- > import Control.Monad.Freer+-- > import Control.Monad.Freer.Reader+-- >+-- > import Data.Map as Map+-- > import Data.Maybe+-- >+-- > type Bindings = Map String Int+-- >+-- > calculateContentLen :: Eff '[Reader String] Int+-- > calculateContentLen = do+-- >   content <- (ask :: Eff '[Reader String] String)+-- >   return (length content)+-- >+-- > -- Calls calculateContentLen after adding a prefix to the Reader content.+-- > calculateModifiedContentLen :: Eff '[Reader String] Int+-- > calculateModifiedContentLen = local ("Prefix " ++) calculateContentLen+-- >+-- > main :: IO ()+-- > main = do+-- >   let s = "12345"+-- >   let modifiedLen = run $ runReader s calculateModifiedContentLen+-- >   let len = run $ runReader s calculateContentLen+-- >   putStrLn $ "Modified 's' length: " ++ (show modifiedLen)+-- >   putStrLn $ "Original 's' length: " ++ (show len)

@@ -0,0 +1,109 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- |+-- Module:       Control.Monad.Freer.State+-- Description:  State effects, for state-carrying computations.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- Composable handler for 'State' effects. Handy for passing an updatable state+-- through a computation.+--+-- Some computations may not require the full power of 'State' effect:+--+-- * For a read-only state, see "Control.Monad.Freer.Reader".+-- * To accumulate a value without using it on the way, see+--   "Control.Monad.Freer.Writer".+--+-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.State+  ( -- * State Effect+    State(..)++    -- * State Operations+  , get+  , put+  , modify++    -- * State Handlers+  , runState+  , evalState+  , execState++    -- * State Utilities+  , transactionState+  , transactionState'+  ) where++import Data.Proxy (Proxy)++import Control.Monad.Freer (Eff, Member, send)+import Control.Monad.Freer.Internal (Arr, handleRelayS, interposeS)++-- | Strict 'State' effects: one can either 'Get' values or 'Put' them.+data State s r where+  Get :: State s s+  Put :: !s -> State s ()++-- | Retrieve the current value of the state of type @s :: *@.+get :: forall s effs. Member (State s) effs => Eff effs s+get = send Get++-- | Set the current state to a specified value of type @s :: *@.+put :: forall s effs. Member (State s) effs => s -> Eff effs ()+put s = send (Put s)++-- | Modify the current state of type @s :: *@ using provided function+-- @(s -> s)@.+modify :: forall s effs. Member (State s) effs => (s -> s) -> Eff effs ()+modify f = fmap f get >>= put++-- | Handler for 'State' effects.+runState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs (a, s)+runState s0 = handleRelayS s0 (\s x -> pure (x, s)) $ \s x k -> case x of+  Get -> k s s+  Put s' -> k s' ()++-- | Run a 'State' effect, returning only the final state.+execState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs s+execState s = fmap snd . runState s++-- | Run a State effect, discarding the final state.+evalState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs a+evalState s = fmap fst . runState s++-- | An encapsulated State handler, for transactional semantics. The global+-- state is updated only if the 'transactionState' finished successfully.+--+-- GHC cannot infer the @s@ type parameter for this function, so it must be+-- specified explicitly with @TypeApplications@. Alternatively, it can be+-- specified by supplying a 'Proxy' to 'transactionState''.+transactionState+  :: forall s effs a+   . Member (State s) effs+  => Eff effs a+  -> Eff effs a+transactionState m = do+    s0 <- get @s+    (x, s) <- interposeS s0 (\s x -> pure (x, s)) handle m+    put s+    pure x+  where+    handle :: s -> State s v -> (s -> Arr effs v b) -> Eff effs b+    handle s x k = case x of+      Get -> k s s+      Put s' -> k s' ()++-- | Like 'transactionState', but @s@ is specified by providing a 'Proxy'+-- instead of requiring @TypeApplications@.+transactionState'+  :: forall s effs a+   . Member (State s) effs+  => Proxy s+  -> Eff effs a+  -> Eff effs a+transactionState' _ = transactionState @s+{-# INLINE transactionState' #-}

@@ -0,0 +1,34 @@+-- |+-- Module:       Control.Monad.Freer.Trace+-- Description:  Composable Trace effects.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- Composable handler for 'Trace' effects. Trace allows one to debug the+-- operation of sequences of effects by outputing to the console.+--+-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.Trace+  ( Trace(..)+  , trace+  , runTrace+  ) where++import Control.Monad.Freer.Internal (Eff(..), Member, extract, qApp, send)++-- | A Trace effect; takes a 'String' and performs output.+data Trace a where+  Trace :: String -> Trace ()++-- | Printing a string in a trace.+trace :: Member Trace effs => String -> Eff effs ()+trace = send . Trace++-- | An 'IO' handler for 'Trace' effects.+runTrace :: Eff '[Trace] a -> IO a+runTrace (Val x) = return x+runTrace (E u q) = case extract u of+  Trace s -> putStrLn s >> runTrace (qApp q ())

@@ -0,0 +1,37 @@+-- |+-- Module:       Control.Monad.Freer.Writer+-- Description:  Composable Writer effects.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- 'Writer' effects, for writing\/appending values (line count, list of+-- messages, etc.) to an output. Current value of 'Writer' effect output is not+-- accessible to the computation.+--+-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.Writer+  ( Writer(..)+  , tell+  , runWriter+  ) where++import Control.Arrow (second)+import Data.Monoid ((<>))++import Control.Monad.Freer.Internal (Eff, Member, handleRelay, send)++-- | Writer effects - send outputs to an effect environment.+data Writer w r where+  Tell :: w -> Writer w ()++-- | Send a change to the attached environment.+tell :: forall w effs. Member (Writer w) effs => w -> Eff effs ()+tell w = send (Tell w)++-- | Simple handler for 'Writer' effects.+runWriter :: forall w effs a. Monoid w => Eff (Writer w ': effs) a -> Eff effs (a, w)+runWriter = handleRelay (\a -> pure (a, mempty)) $ \(Tell w) k ->+  second (w <>) <$> k ()

@@ -0,0 +1,74 @@+-- |+-- Module:       Data.FTCQueue+-- Description:  Fast type-aligned queue optimized to effectful functions.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- * Constant-time append\/('><') and snoc\/('|>')+-- * Average constant-time 'viewL' (left-edge deconstruction).+--+-- Using <http://okmij.org/ftp/Haskell/extensible/FTCQueue1.hs> as a starting+-- point.+--+-- A minimal version of FTCQueue from "Reflection w/o Remorse":+--+-- * Research: <http://okmij.org/ftp/Haskell/Reflection.html>+-- * <https://hackage.haskell.org/package/type-aligned type-aligned> (FTCQueue)+module Data.FTCQueue+  ( FTCQueue+  , tsingleton+  , (|>)+  , snoc+  , (><)+  , append+  , ViewL(..)+  , tviewl+  ) where++-- | Non-empty tree. Deconstruction operations make it more and more+-- 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++-- | Build a leaf from a single operation. [O(1)]+tsingleton :: (a -> m b) -> FTCQueue m a b+tsingleton = Leaf+{-# INLINE tsingleton #-}++-- | Append an operation to the right of the tree. [O(1)]+(|>) :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b+t |> r = Node t (Leaf r)+{-# INLINE (|>) #-}++-- | An alias for '(|>)'+snoc :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b+snoc = (|>)+{-# INLINE snoc #-}++-- | Append two trees of operations. [O(1)]+(><)   :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b+t1 >< t2 = Node t1 t2+{-# INLINE (><) #-}++-- | An alias for '(><)'+append :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b+append = (><)+{-# INLINE append #-}++-- | Left view deconstruction data structure.+data ViewL m a b where+  TOne  :: (a -> m b) -> ViewL m a b+  (:|)  :: (a -> m x) -> FTCQueue m x b -> ViewL m a b++-- | Left view deconstruction. [average O(1)]+tviewl :: FTCQueue m a b -> ViewL m a b+tviewl (Leaf r)     = TOne r+tviewl (Node t1 t2) = go t1 t2+  where+    go :: FTCQueue m a x -> FTCQueue m x b -> ViewL m a b+    go (Leaf r)       tr = r :| tr+    go (Node tl1 tl2) tr = go tl1 (Node tl2 tr)

@@ -0,0 +1,78 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module:       Data.OpenUnion+-- Description:  Open unions (type-indexed co-products) for extensible effects.+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- Open unions (type-indexed co-products, i.e. type-indexed sums) for+-- extensible effects All operations are constant-time.+module Data.OpenUnion+  ( -- * Open Union+    Union++    -- * Open Union Operations+  , Weakens(..)+  , (:++:)+  , decomp+  , weaken+  , extract++    -- * Open Union Membership Constraints+  , Member(..)+  , Members+  , LastMember+  ) where++import Data.Kind (Constraint)++import Data.OpenUnion.Internal+  ( Member(inj, prj)+  , Union+  , Weakens(weakens)+  , (:++:)+  , decomp+  , extract+  , weaken+  )++-- | A shorthand constraint that represents a combination of multiple 'Member'+-- constraints. That is, the following 'Members' constraint:+--+-- @+-- 'Members' '[Foo, Bar, Baz] effs+-- @+--+-- …is equivalent to the following set of 'Member' constraints:+--+-- @+-- ('Member' Foo effs, 'Member' Bar effs, 'Member' baz effs)+-- @+--+-- Note that, since each effect is translated into a separate 'Member'+-- constraint, the order of the effects does /not/ matter.+type family Members effs effs' :: Constraint where+  Members (eff ': effs) effs' = (Member eff effs', Members effs effs')+  Members '[] effs' = ()++type family Last effs where+  Last (eff ': '[]) = eff+  Last (_ ': effs) = Last effs++-- | Like 'Member', @'LastMember' eff effs@ is a constraint that requires that+-- @eff@ is in the type-level list @effs@. However, /unlike/ 'Member',+-- 'LastMember' requires @m@ be the __final__ effect in @effs@.+--+-- Generally, this is not especially useful, since it is preferable for+-- computations to be agnostic to the order of effects, but it is quite useful+-- in combination with 'Control.Monad.Freer.sendM' or+-- 'Control.Monad.Base.liftBase' to embed ordinary monadic effects within an+-- 'Control.Monad.Freer.Eff' computation.+class (Member m effs, m ~ Last effs) => LastMember m effs | effs -> m+instance (Member m effs, m ~ Last effs) => LastMember m effs

@@ -0,0 +1,205 @@+{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module:       Data.OpenUnion.Internal+-- Description:  Open unions (type-indexed co-products) for extensible effects.+--+-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King+-- License:      BSD3+-- Maintainer:   Alexis King <lexi.lambda@gmail.com>+-- Stability:    experimental+-- Portability:  GHC specific language extensions.+--+-- These are internal definitions and should be used with caution. There are no+-- guarantees that the API of this module will be preserved between minor+-- versions of this package.+--+-- Open unions (type-indexed co-products, i.e. type-indexed sums) for+-- extensible effects All operations are constant-time.+--+-- Based on+-- <http://okmij.org/ftp/Haskell/extensible/OpenUnion51.hs OpenUnion51.hs>.+--+-- Type-list @r :: [* -> *]@ of open union components is a small Universe.+-- Therefore, we can use a @Typeable@-like evidence in that universe. In our+-- case a simple index of an element in the type-list is sufficient+-- substitution for @Typeable@.+module Data.OpenUnion.Internal where++import GHC.TypeLits (TypeError, ErrorMessage(..))+import Unsafe.Coerce (unsafeCoerce)++-- | Open union is a strong sum (existential with an evidence).+data Union (r :: [* -> *]) a where+  Union :: {-# UNPACK #-} !Word -> t a -> Union r a++-- | Takes a request of type @t :: * -> *@, and injects it into the 'Union'.+--+-- Summand is assigning a specified 'Word' value, which is a position in the+-- type-list @(t ': r) :: * -> *@.+--+-- __This function is unsafe.__+--+-- /O(1)/+unsafeInj :: Word -> t a -> Union r a+unsafeInj = Union+{-# INLINE unsafeInj #-}++-- | Project a value of type @'Union' (t ': r) :: * -> *@ into a possible+-- summand of the type @t :: * -> *@. 'Nothing' means that @t :: * -> *@ is not+-- the value stored in the @'Union' (t ': r) :: * -> *@.+--+-- It is assumed that summand is stored in the 'Union' when the 'Word' value is+-- the same value as is stored in the 'Union'.+--+-- __This function is unsafe.__+--+-- /O(1)/+unsafePrj :: Word -> Union r a -> Maybe (t a)+unsafePrj n (Union n' x)+  | n == n'   = Just (unsafeCoerce x)+  | otherwise = Nothing+{-# INLINE unsafePrj #-}++-- | Represents position of element @t :: * -> *@ in a type list+-- @r :: [* -> *]@.+newtype P t r w = P {unP :: Word}++-- | Find an index of an element @t :: * -> *@ in a type list @r :: [* -> *]@.+-- The element must exist. The @w :: [* -> *]@ type represents the entire list,+-- prior to recursion, and it is used to produce better type errors.+--+-- This is essentially a compile-time computation without run-time overhead.+class FindElem (t :: * -> *) (r :: [* -> *]) (w :: [* -> *]) where+  -- | Position of the element @t :: * -> *@ in a type list @r :: [* -> *]@.+  --+  -- Position is computed during compilation, i.e. there is no run-time+  -- overhead.+  --+  -- /O(1)/+  elemNo :: P t r w++-- | Base case; element is at the current position in the list.+instance FindElem t (t ': r) w where+  elemNo = P 0++-- | Recursion; element is not at the current position, but is somewhere in the+-- list.+instance {-# OVERLAPPABLE #-} FindElem t r w => FindElem t (t' ': r) w where+  elemNo = P $ 1 + unP (elemNo :: P t r w)++-- | If we reach an empty list, that’s a failure, since it means the type isn’t+-- in the list. For GHC >=8, we can render a custom type error that explicitly+-- states what went wrong.+instance TypeError ('Text "‘" ':<>: 'ShowType t+                    ':<>: 'Text "’ is not a member of the type-level list"+                    ':$$: 'Text "  ‘" ':<>: 'ShowType w ':<>: 'Text "’"+                    ':$$: 'Text "In the constraint ("+                    ':<>: 'ShowType (Member t w) ':<>: 'Text ")")+    => FindElem t '[] w where+  elemNo = error "impossible"++-- | A constraint that requires that a particular effect, @eff@, is a member of+-- the type-level list @effs@. This is used to parameterize an+-- 'Control.Monad.Freer.Eff' computation over an arbitrary list of effects, so+-- long as @eff@ is /somewhere/ in the list.+--+-- For example, a computation that only needs access to a cell of mutable state+-- containing an 'Integer' would likely use the following type:+--+-- @+-- 'Member' ('Control.Monad.Freer.State.State' 'Integer') effs => 'Control.Monad.Freer.Eff' effs ()+-- @+class FindElem eff effs effs => Member (eff :: * -> *) effs where+  -- This type class is used for two following purposes:+  --+  -- * As a @Constraint@ it guarantees that @t :: * -> *@ is a member of a+  --   type-list @r :: [* -> *]@.+  --+  -- * Provides a way how to inject\/project @t :: * -> *@ into\/from a 'Union',+  --   respectively.+  --+  -- Following law has to hold:+  --+  -- @+  -- 'prj' . 'inj' === 'Just'+  -- @++  -- | Takes a request of type @t :: * -> *@, and injects it into the+  -- 'Union'.+  --+  -- /O(1)/+  inj :: eff a -> Union effs a++  -- | Project a value of type @'Union' (t ': r) :: * -> *@ into a possible+  -- summand of the type @t :: * -> *@. 'Nothing' means that @t :: * -> *@ is+  -- not the value stored in the @'Union' (t ': r) :: * -> *@.+  --+  -- /O(1)/+  prj :: Union effs a -> Maybe (eff a)++instance FindElem t r r => Member t r where+  inj = unsafeInj $ unP (elemNo :: P t r r)+  {-# INLINE inj #-}++  prj = unsafePrj $ unP (elemNo :: P t r r)+  {-# INLINE prj #-}++-- | Orthogonal decomposition of a @'Union' (t ': r) :: * -> *@. 'Right' value+-- is returned if the @'Union' (t ': r) :: * -> *@ contains @t :: * -> *@, and+-- 'Left' when it doesn't. Notice that 'Left' value contains+-- @Union r :: * -> *@, i.e. it can not contain @t :: * -> *@.+--+-- /O(1)/+decomp :: Union (t ': r) a -> Either (Union r a) (t a)+decomp (Union 0 a) = Right $ unsafeCoerce a+decomp (Union n a) = Left  $ Union (n - 1) a+{-# INLINE [2] decomp #-}++-- | Specialized version of 'decomp' for efficiency.+--+-- /O(1)/+--+-- TODO: Check that it actually adds on efficiency.+decomp0 :: Union '[t] a -> Either (Union '[] a) (t a)+decomp0 (Union _ a) = Right $ unsafeCoerce a+{-# INLINE decomp0 #-}+{-# RULES "decomp/singleton"  decomp = decomp0 #-}++-- | Specialised version of 'prj'\/'decomp' that works on an+-- @'Union' '[t] :: * -> *@ which contains only one specific summand. Hence the+-- absence of 'Maybe', and 'Either'.+--+-- /O(1)/+extract :: Union '[t] a -> t a+extract (Union _ a) = unsafeCoerce a+{-# INLINE extract #-}++-- | Inject whole @'Union' r@ into a weaker @'Union' (any ': r)@ that has one+-- more summand.+--+-- /O(1)/+weaken :: Union r a -> Union (any ': r) a+weaken (Union n a) = Union (n + 1) a+{-# INLINE weaken #-}++infixr 5 :++:+type family xs :++: ys where+  '[] :++: ys = ys+  (x ': xs) :++: ys = x ': (xs :++: ys)++class Weakens q where+  weakens :: Union r a -> Union (q :++: r) a++instance Weakens '[] where+  weakens = id+  {-# INLINE weakens #-}++instance Weakens xs => Weakens (x ': xs) where+  weakens u = weaken (weakens @xs u)+  {-# INLINEABLE weakens #-}

@@ -0,0 +1,41 @@+module Main (main) where++import Test.Tasty (TestTree, testGroup, defaultMain)+import Test.Tasty.QuickCheck (testProperty)++import Control.Monad.Freer (run)++import qualified Tests.Coroutine (tests)+import qualified Tests.Exception (tests)+import qualified Tests.Fresh (tests)+import qualified Tests.NonDet (tests)+import qualified Tests.Reader (tests)+import qualified Tests.State (tests)+import qualified Tests.Loop (tests)++--------------------------------------------------------------------------------+                           -- Pure Tests --+--------------------------------------------------------------------------------+addInEff :: Int -> Int -> Int+addInEff x y = run $ (+) <$> pure x <*> pure y++pureTests :: TestTree+pureTests = testGroup "Pure Eff tests"+  [ testProperty "Pure run just works: (+)"+      $ \x y -> addInEff x y == x + y+  ]++--------------------------------------------------------------------------------+                             -- Runner --+--------------------------------------------------------------------------------+main :: IO ()+main = defaultMain $ testGroup "Tests"+  [ pureTests+  , Tests.Coroutine.tests+  , Tests.Exception.tests+  , Tests.Fresh.tests+  , Tests.NonDet.tests+  , Tests.Reader.tests+  , Tests.State.tests+  , Tests.Loop.tests+  ]

@@ -0,0 +1,51 @@+-- This is necessary to work around a weird infinite loop bug in GHC 8.0.x. I+-- have no idea what causes it, but disabling these extensions in this module+-- avoids the problem.+{-# LANGUAGE NoGADTs #-}+{-# LANGUAGE NoMonoLocalBinds #-}++module Tests.Coroutine (tests) where++import Control.Monad (unless)++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import Control.Monad.Freer (Eff, Members, run)+import Control.Monad.Freer.Coroutine+  ( Status(Continue, Done)+  , Yield+  , runC+  , yield+  )+import Control.Monad.Freer.State (State, modify, runState)++tests :: TestTree+tests = testGroup "Coroutine Eff tests"+    [ testProperty "Counting consecutive pairs of odds"+        $ \list -> runTestCoroutine list == countOddDuoPrefix list+    ]++-- | Counts number of consecutive pairs of odd elements at beginning of a list.+countOddDuoPrefix :: [Int] -> Int+countOddDuoPrefix list = count list 0+  where+    count (i1:i2:is) n = if even i1 && even i2 then n else count is (n + 1)+    count _          n = n++runTestCoroutine :: [Int] -> Int+runTestCoroutine list = snd . run $ runState 0 effTestCoroutine+  where+    testCoroutine :: Members '[Yield () Int, State Int] r => Eff r ()+    testCoroutine = do+      -- Yield for two elements and hope they're both odd.+      b <- (&&)+          <$> yield () (even :: Int -> Bool)+          <*> yield () (even :: Int -> Bool)+      unless b $ modify (+ (1 :: Int)) >> testCoroutine++    effTestCoroutine = runC testCoroutine >>= handleStatus list+      where+        handleStatus _      (Done ())       = pure ()+        handleStatus (i:is) (Continue () k) = k i >>= handleStatus is+        handleStatus []     _               = pure ()

@@ -0,0 +1,89 @@+module Tests.Exception (tests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck (testProperty)++import Control.Monad.Freer (Eff, Member, Members, run)+import Control.Monad.Freer.Error (Error, catchError, runError, throwError)+import Control.Monad.Freer.Reader (ask, runReader)+import Control.Monad.Freer.State (State, get, put, runState)++tests :: TestTree+tests = testGroup "Exception Eff tests"+  [ testProperty "Error takes precedence"+      $ \x y -> testExceptionTakesPriority x y == Left y+  , testCase "uncaught: runState (runError t)"+      $ ter1 @?= (Left "exc", 2)+  , testCase "uncaught: runError (runState t)"+      $ ter2 @?= Left "exc"+  , testCase "caught: runState (runError t)"+      $ ter3 @?= (Right "exc", 2)+  , testCase "caught: runError (runState t)"+      $ ter4 @?= Right ("exc", 2)+  , testCase "success: runReader (runErrBig t)"+      $ ex2rr @?= Right 5+  , testCase "uncaught: runReader (runErrBig t)"+      $ ex2rr1 @?= Left (TooBig 7)+  , testCase "uncaught: runErrBig (runReader t)"+      $ ex2rr2 @?= Left (TooBig 7)+  ]++testExceptionTakesPriority :: Int -> Int -> Either Int Int+testExceptionTakesPriority x y = run $ runError (go x y)+  where+    go a b = (+) <$> pure a <*> throwError b++-- The following won't type: unhandled exception!+-- ex2rw = run et2+{-+    No instance for (Member (Error Int) Void)+      arising from a use of `et2'+-}++-- Exceptions and state.+incr :: Member (State Int) r => Eff r ()+incr = get >>= put . (+ (1 :: Int))++tes1 :: (Members '[State Int, Error String] r) => Eff r b+tes1 = incr >> throwError "exc"++ter1 :: (Either String Int, Int)+ter1 = run $ runState (1 :: Int) (runError tes1)++ter2 :: Either String (String, Int)+ter2 = run $ runError (runState (1 :: Int) tes1)++teCatch :: Member (Error String) r => Eff r a -> Eff r String+teCatch m = (m >> pure "done") `catchError` \e -> pure (e :: String)++ter3 :: (Either String String, Int)+ter3 = run $ runState (1 :: Int) (runError (teCatch tes1))++ter4 :: Either String (String, Int)+ter4 = run $ runError (runState (1 :: Int) (teCatch tes1))++-- | The example from the paper.+newtype TooBig = TooBig Int+  deriving (Eq, Show)++ex2 :: Member (Error TooBig) r => Eff r Int -> Eff r Int+ex2 m = do+  v <- m+  if v > 5+    then throwError (TooBig v)+    else pure v++-- | Specialization to tell the type of the exception.+runErrBig :: Eff (Error TooBig ': r) a -> Eff r (Either TooBig a)+runErrBig = runError++ex2rr :: Either TooBig Int+ex2rr = run $ runReader (5 :: Int) (runErrBig (ex2 ask))++ex2rr1 :: Either TooBig Int+ex2rr1 = run $ runReader (7 :: Int) (runErrBig (ex2 ask))++-- | Different order of handlers (layers).+ex2rr2 :: Either TooBig Int+ex2rr2 = run $ runErrBig (runReader (7 :: Int) (ex2 ask))

@@ -0,0 +1,24 @@+module Tests.Fresh (tests) where++import Control.Monad (replicateM)++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)+import Test.Tasty.QuickCheck ((==>), testProperty)++import Control.Monad.Freer (Eff, run)+import Control.Monad.Freer.Fresh (fresh, runFresh)++tests :: TestTree+tests = testGroup "Fresh tests"+  [ testCase "Start at 0, refresh twice, yields 1"+      $ testFresh 10 @?= 9+  , testProperty "Freshening n times yields (n-1)"+      $ \n -> n > 0 ==> testFresh n == (n-1)+  ]++makeFresh :: Int -> Eff r Int+makeFresh n = fst <$> runFresh 0 (last <$> replicateM n fresh)++testFresh :: Int -> Int+testFresh = run . makeFresh

@@ -0,0 +1,38 @@+module Tests.Loop (tests) where++import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.QSemN (newQSemN, signalQSemN, waitQSemN)+import Control.Monad (forever)+import Data.Function (fix)++import Test.Tasty (TestTree, localOption, mkTimeout, testGroup)+import Test.Tasty.HUnit (testCase)++import Control.Monad.Freer (Eff, Member, runM, send)++tests :: TestTree+tests = localOption timeout $ testGroup "Loop tests"+    [ testCase "fix loop" $ testLoop fixLoop+    , testCase "tail loop" $ testLoop tailLoop+    , testCase "forever loop" $ testLoop foreverLoop+    ]+  where+    timeout = mkTimeout 1000000++testLoop :: (IO () -> Eff '[IO] ()) -> IO ()+testLoop loop = do+  s <- newQSemN 0+  t <- forkIO . runM . loop $ signalQSemN s 1+  waitQSemN s 5+  killThread t++fixLoop :: Member IO r => IO () -> Eff r ()+fixLoop action = fix $ \fxLoop -> do+  send action+  fxLoop++tailLoop :: Member IO r => IO () -> Eff r ()+tailLoop action = let loop = send action *> loop in loop++foreverLoop :: Member IO r => IO () -> Eff r ()+foreverLoop action = forever $ send action

@@ -0,0 +1,41 @@+module Tests.NonDet (tests) where++import Control.Applicative ((<|>))+import Control.Monad (guard, msum, mzero)+import Data.List ((\\))++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import Control.Monad.Freer (Eff, Member, run)+import Control.Monad.Freer.NonDet (NonDet, makeChoiceA, msplit)++tests :: TestTree+tests = testGroup "NonDet tests"+  [ testProperty "Primes in 2..n generated by ifte"+      $ \n' -> let n = abs n' in testIfte [2 .. n] == primesTo n+  ]++-- https://wiki.haskell.org/Prime_numbers+primesTo :: Int -> [Int]+primesTo m = sieve [2 .. m]+  where+    -- Function (\\) is set-difference for unordered lists.+    sieve (x:xs) = x : sieve (xs \\ [x, (x + x) .. m])+    sieve []     = []++ifte :: Member NonDet r => Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b+ifte t th el = msplit t >>= maybe el (\(a,m) -> th a <|> (m >>= th))++generatePrimes :: Member NonDet r => [Int] -> Eff r Int+generatePrimes xs = do+    n <- gen+    ifte+        (gen >>= \d -> guard $ d < n && n `mod` d == 0)+        (const mzero)+        (pure n)+  where+    gen = msum (pure <$> xs)++testIfte :: [Int] -> [Int]+testIfte = run . makeChoiceA . generatePrimes

@@ -0,0 +1,50 @@+module Tests.Reader (tests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import Control.Monad.Freer (run)+import Control.Monad.Freer.Reader (ask, local, runReader)++tests :: TestTree+tests = testGroup "Reader tests"+  [ testProperty "Reader passes along environment: n + x"+      $ \n x -> testReader n x == n + x+  , testProperty "Multiple readers work"+      $ \i n -> testMultiReader i n == (i + 2) + fromIntegral (n + 1)+  , testProperty "Local injects into env"+      $ \env inc -> testLocal env inc == 2 * (env + 1) + inc+  ]++--------------------------------------------------------------------------------+                            -- Examples --+--------------------------------------------------------------------------------+testReader :: Int -> Int -> Int+testReader n x = run . runReader n $ (+) <$> ask <*> pure x++{-+t1rr' = run t1+    No instance for (Member (Reader Int) Void)+      arising from a use of `t1'+-}++testMultiReader :: Integer -> Int -> Integer+testMultiReader i j = run . runReader i $ runReader j t2+  where+    t2 = do+      v1 <- ask+      v2 <- ask+      pure $ fromIntegral (v1 + (1 :: Int)) + (v2 + (2 :: Integer))++-- The opposite order of layers+{- If we mess up, we get an error+t2rrr1' = run $ runReader (runReader t2 (20 :: Float)) (10 :: Float)+    No instance for (Member (Reader Int) [])+      arising from a use of `t2'+-}++testLocal :: Int -> Int -> Int+testLocal env inc = run $ runReader env t3+  where+    t3 = (+) <$> t1 <*> local (+ inc) t1+    t1 = (+) <$> ask <*> pure (1 :: Int)

@@ -0,0 +1,51 @@+module Tests.State (tests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import Control.Monad.Freer (run)+import Control.Monad.Freer.State (evalState, execState, get, put, runState)++tests :: TestTree+tests = testGroup "State tests"+  [ testProperty "get after put n yields (n, n)"+      $ \n -> testPutGet n 0 == (n, n)+  , testProperty "Final put determines stored state"+      $ \p1 p2 start -> testPutGetPutGetPlus p1 p2 start == (p1 + p2, p2)+  , testProperty "If only getting, start state determines outcome"+      $ \start -> testGetStart start == (start, start)+  , testProperty "testEvalState: evalState discards final state"+      $ \n -> testEvalState n == n+  , testProperty "testExecState: execState returns final state"+      $ \n -> testExecState n == n+  ]++testPutGet :: Int -> Int -> (Int, Int)+testPutGet n start = run $ runState start go+  where+    go = put n >> get++testPutGetPutGetPlus :: Int -> Int -> Int -> (Int, Int)+testPutGetPutGetPlus p1 p2 start = run $ runState start go+  where+    go = do+      put p1+      x <- get+      put p2+      y <- get+      pure (x + y)++testGetStart :: Int -> (Int, Int)+testGetStart = run . flip runState get++testEvalState :: Int -> Int+testEvalState = run . flip evalState go+  where+    go = do+      x <- get+      -- Destroy the previous state.+      put (0 :: Int)+      pure x++testExecState :: Int -> Int+testExecState n = run $ execState 0 (put n)