diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 1.0.0.0 + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Core.hs b/bench/Core.hs new file mode 100644 --- /dev/null +++ b/bench/Core.hs @@ -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 + ] + ] diff --git a/examples/src/Capitalize.hs b/examples/src/Capitalize.hs new file mode 100644 --- /dev/null +++ b/examples/src/Capitalize.hs @@ -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) diff --git a/examples/src/Console.hs b/examples/src/Console.hs new file mode 100644 --- /dev/null +++ b/examples/src/Console.hs @@ -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 () diff --git a/examples/src/Coroutine.hs b/examples/src/Coroutine.hs new file mode 100644 --- /dev/null +++ b/examples/src/Coroutine.hs @@ -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 +-} + +-} diff --git a/examples/src/Fresh.hs b/examples/src/Fresh.hs new file mode 100644 --- /dev/null +++ b/examples/src/Fresh.hs @@ -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' diff --git a/examples/src/Main.hs b/examples/src/Main.hs new file mode 100644 --- /dev/null +++ b/examples/src/Main.hs @@ -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) ++ "]" diff --git a/examples/src/Trace.hs b/examples/src/Trace.hs new file mode 100644 --- /dev/null +++ b/examples/src/Trace.hs @@ -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 +-} diff --git a/freer-simple.cabal b/freer-simple.cabal new file mode 100644 --- /dev/null +++ b/freer-simple.cabal @@ -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 + ), which is + based on the work of Oleg Kiselyov et al.: + . + * + * + * + . + 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 +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 diff --git a/src/Control/Monad/Freer.hs b/src/Control/Monad/Freer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer.hs @@ -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 +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 #-} diff --git a/src/Control/Monad/Freer/Coroutine.hs b/src/Control/Monad/Freer/Coroutine.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Coroutine.hs @@ -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 +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- An effect to compose functions with the ability to yield. +-- +-- Using 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 diff --git a/src/Control/Monad/Freer/Error.hs b/src/Control/Monad/Freer/Error.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Error.hs @@ -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 +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- Composable handler for Error effects. Communicates success\/failure via an +-- 'Either' type. +-- +-- Using 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 diff --git a/src/Control/Monad/Freer/Fresh.hs b/src/Control/Monad/Freer/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Fresh.hs @@ -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 +-- 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 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 diff --git a/src/Control/Monad/Freer/Internal.hs b/src/Control/Monad/Freer/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Internal.hs @@ -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 +-- 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 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 diff --git a/src/Control/Monad/Freer/NonDet.hs b/src/Control/Monad/Freer/NonDet.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/NonDet.hs @@ -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 +-- 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) diff --git a/src/Control/Monad/Freer/Reader.hs b/src/Control/Monad/Freer/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Reader.hs @@ -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 +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- Composable handler for 'Reader' effects. Handy for encapsulating an +-- environment with immutable state for interpreters. +-- +-- Using 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) diff --git a/src/Control/Monad/Freer/State.hs b/src/Control/Monad/Freer/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/State.hs @@ -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 +-- 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 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' #-} diff --git a/src/Control/Monad/Freer/Trace.hs b/src/Control/Monad/Freer/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Trace.hs @@ -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 +-- 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 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 ()) diff --git a/src/Control/Monad/Freer/Writer.hs b/src/Control/Monad/Freer/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Writer.hs @@ -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 +-- 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 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 () diff --git a/src/Data/FTCQueue.hs b/src/Data/FTCQueue.hs new file mode 100644 --- /dev/null +++ b/src/Data/FTCQueue.hs @@ -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 +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- * Constant-time append\/('><') and snoc\/('|>') +-- * Average constant-time 'viewL' (left-edge deconstruction). +-- +-- Using as a starting +-- point. +-- +-- A minimal version of FTCQueue from "Reflection w/o Remorse": +-- +-- * Research: +-- * (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) diff --git a/src/Data/OpenUnion.hs b/src/Data/OpenUnion.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenUnion.hs @@ -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 +-- 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 diff --git a/src/Data/OpenUnion/Internal.hs b/src/Data/OpenUnion/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenUnion/Internal.hs @@ -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 +-- 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 +-- . +-- +-- 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 #-} diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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 + ] diff --git a/tests/Tests/Coroutine.hs b/tests/Tests/Coroutine.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Coroutine.hs @@ -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 () diff --git a/tests/Tests/Exception.hs b/tests/Tests/Exception.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Exception.hs @@ -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)) diff --git a/tests/Tests/Fresh.hs b/tests/Tests/Fresh.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Fresh.hs @@ -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 diff --git a/tests/Tests/Loop.hs b/tests/Tests/Loop.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Loop.hs @@ -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 diff --git a/tests/Tests/NonDet.hs b/tests/Tests/NonDet.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/NonDet.hs @@ -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 diff --git a/tests/Tests/Reader.hs b/tests/Tests/Reader.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reader.hs @@ -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) diff --git a/tests/Tests/State.hs b/tests/Tests/State.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/State.hs @@ -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)