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. + +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,147 @@ +# Freer Effects: Extensible Effects with Freer Monads + +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)](http://www.haskell.org) +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)](https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29) + +[![Hackage](http://img.shields.io/hackage/v/freer-effects.svg)](https://hackage.haskell.org/package/freer-effects) +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/freer-effects.svg)](http://packdeps.haskellers.com/reverse/freer-effects) +[![Build](https://travis-ci.org/IxpertaSolutions/freer-effects.svg?branch=master)](https://travis-ci.org/IxpertaSolutions/freer-effects) + + +# Description + +Library `freer-effects` is an implementation of 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 are: + +* An efficient effect system for Haskell as a library. +* Implementations for several common Haskell monads as effects: + * `Reader` + * `Writer` + * `State` + * `StateRW`: State in terms of Reader/Writer. + * `Trace` + * `Exception` +* Core components for defining your own Effects. + + +# Example: Console DSL + +Here's what using Freer looks like: + +```haskell +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +module Console where + +import Control.Monad.Freer +import Control.Monad.Freer.Internal +import System.Exit hiding (ExitSuccess) + +-------------------------------------------------------------------------------- + -- 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 -- +-------------------------------------------------------------------------------- +runConsole :: Eff '[Console] w -> IO w +runConsole (Val x) = return x +runConsole (E u q) = + case extract u of + PutStrLn msg -> putStrLn msg >> runConsole (qApp q ()) + GetLine -> getLine >>= \s -> runConsole (qApp q s) + ExitSuccess -> exitSuccess + +-------------------------------------------------------------------------------- + -- Pure Interpreter -- +-------------------------------------------------------------------------------- +runConsolePure :: [String] -> Eff '[Console] w -> [String] +runConsolePure inputs req = + reverse . snd $ run (handleRelayS (inputs, []) (\s _ -> pure s) go req) + where + go :: ([String], [String]) + -> Console v + -> (([String], [String]) -> Arr '[] v ([String], [String])) + -> Eff '[] ([String], [String]) + go (is, os) (PutStrLn msg) q = q (is, msg : os) () + go (i:is, os) GetLine q = q (is, os) i + go ([], _ ) GetLine _ = error "Not enough lines" + go (_, os) ExitSuccess _ = pure ([], os) +``` + + +# 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 + +For more information about `stack` tool can be found in its +[documentation](https://haskellstack.org/). + + +# Licensing + +This project is distrubted under a BSD3 license. See the included +LICENSE file for more details. + + +# Acknowledgements + +Package `freer-effects` started as a fork of +[freer](http://hackage.haskell.org/package/freer) authored by Allele Dev. + +This package would not be possible without the paper and the reference +implementation. 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,174 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Main where + +import Prelude ((-)) + +import Control.Applicative (pure) +import Control.Monad ((>>=), (>>), replicateM_) +import Data.Either (Either(Left, Right)) +import Data.Function ((.), ($), id) +import Data.Functor (Functor) +import Data.Int (Int) +import Data.Maybe (Maybe) +import Data.Ord ((<=)) +import Data.String (String) +import System.IO (IO) + +#if MIN_VERSION_mtl(2,2,1) +import qualified Control.Monad.Except as MTL +#else +import qualified Control.Monad.Error as MTL +#endif +import qualified Control.Monad.State as MTL +import qualified Control.Monad.Free as Free + +import Criterion +import Criterion.Main + +import Control.Monad.Freer (Member, Eff, run, send) +import Control.Monad.Freer.Internal (Eff(E, Val), decomp, qApp, tsingleton) +import Control.Monad.Freer.Exception (runError, throwError) +import Control.Monad.Freer.State (get, put, runState) +import Control.Monad.Freer.StateRW (ask, tell, runStateR) + +-------------------------------------------------------------------------------- + -- State Benchmarks -- +-------------------------------------------------------------------------------- + +oneGet :: Int -> (Int, Int) +oneGet = run . runState get + +oneGetMTL :: Int -> (Int, Int) +oneGetMTL = MTL.runState MTL.get + +countDown :: Int -> (Int,Int) +countDown start = run (runState go start) + where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go) + +countDownRW :: Int -> (Int,Int) +countDownRW start = run (runStateR go start) + where go = ask >>= (\n -> if n <= 0 then pure n else tell (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) + +-------------------------------------------------------------------------------- + -- Exception + State -- +-------------------------------------------------------------------------------- +countDownExc :: Int -> Either String (Int,Int) +countDownExc start = run $ runError (runState go start) + 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) + +-------------------------------------------------------------------------------- + -- 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 + ], + bgroup "Countdown Bench" [ + bench "freer.State" $ whnf countDown 10000 + , bench "freer.StateRW" $ whnf countDownRW 10000 + , bench "mtl.State" $ whnf countDownMTL 10000 + ], + bgroup "Countdown+Except Bench" [ + bench "freer.ExcState" $ whnf countDownExc 10000 + , bench "mtl.ExceptState" $ whnf countDownExcMTL 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/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,89 @@ +# Change Log + +All notable changes to this project will be documented in this file. + +## [0.3.0.0] (March 06, 2017) + +* Package renamed to `freer-effects` to distinguish it from original `freer`. + [#4](https://github.com/IxpertaSolutions/freer-effects/issues/4) +* Fix `Could not deduce: effs ~ (r : rs)` that may occur when using + a `Member` contraint (a regression introduced in 0.2.4.0) + [freer!12](https://gitlab.com/queertypes/freer/merge_requests/12) +* Add `runNatS` convenience function + [freer!13](https://gitlab.com/queertypes/freer/merge_requests/13) +* Add `evalState` and `execState` convenience functions + [freer!14](https://gitlab.com/queertypes/freer/merge_requests/14) +* Data constructors of `Yield`, `CutFalse`, `Fresh`, `State` and `Trace` + are now exposed in addition to `Exc`, `Reader` and `Writer` +* Generalised type signature of `asks`. + [#7](https://github.com/IxpertaSolutions/freer-effects/issues/7) +* Renamed modules `Data.Open.Union.*` to `Data.OpenUnion.*`. + [#8](https://github.com/IxpertaSolutions/freer-effects/issues/8) +* `NonDetEff` separated into its own module and renamed to `NonDet`. + [#11](https://github.com/IxpertaSolutions/freer-effects/issues/11) +* Reimplement `Union` using + as a basis. + [#14](https://github.com/IxpertaSolutions/freer-effects/issues/14) +* Renamed `Teletype` example DSL to `Console`. + +## [0.2.4.1] (November 25, 2016) + +* Restore GHC (7.8, 7.10) compatibility + +## 0.2.4.0 (November 25, 2016) + +* Internal reorg + * In particular, hide implementation details in Union.Internal + * Rewrite interpreters in terms of `extract` instead of `decomp` +* Add `runNat` convenience function + +## 0.2.3.0 (June 25, 2016) + +* Add GHC 8 support + +## 0.2.2.2 (Sep. 14, 2015) + +* Use local `data Nat` for `Data.Open.Union` + * Using GHC.TypeLits lead to overlapping instances + +## 0.2.2.1 (Sep. 14, 2015) + +* Document ALL THE THINGS + +## 0.2.2.0 (Sep. 13, 2015) + +* Add bench suite + +## 0.2.1.0 (Sep. 13, 2015) + +* Add test suite + +## 0.2.0.2 (Sep. 12, 2015) + +* Clean up language extensions per file +* Add Teletype DSL to the README + +## 0.2.0.1 (Sep. 12, 2015) + +* Add Teletype DSL example +* Expose `send` in public interface + +## 0.2.0.0 (Sep. 12, 2015) + +* Implement NonDetEff +* Separate Cut/Coroutine out from Internals + * Partial implementation: won't compile yet +* Extract remaining examples from Internal comments + +## 0.1.1.0 (Sep. 12, 2015) + +* Warnings clean up +* Examples separated from primary implementation +* Initial project documentation added + +## 0.1.0.0 (Sep. 12, 2015) + +* Initial release + +[0.3.0.0]: https://github.com/IxpertaSolutions/freer/compare/0.2.4.1...0.3.0.0 +[0.2.4.1]: https://github.com/IxpertaSolutions/freer/compare/0.2.4.0...0.2.4.1 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,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +module Capitalize where + +import Data.Char (toUpper) + +import Control.Monad.Freer +import Control.Monad.Freer.Internal + +data Capitalize v where + Capitalize :: String -> Capitalize String + +capitalize :: Member Capitalize r => String -> Eff r String +capitalize = send . Capitalize + +runCapitalizeM :: Eff (Capitalize ': r) w -> Eff r w +runCapitalizeM (Val x) = return x +runCapitalizeM (E u q) = case decomp u of + Right (Capitalize s) -> runCapitalizeM (qApp q (map toUpper s)) + Left u' -> E u' (tsingleton (runCapitalizeM . qApp q)) diff --git a/examples/src/Common.hs b/examples/src/Common.hs new file mode 100644 --- /dev/null +++ b/examples/src/Common.hs @@ -0,0 +1,6 @@ +module Common where + +import Control.Applicative + +add :: Applicative f => f Int -> f Int -> f Int +add = liftA2 (+) 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,92 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} +module Console where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure) +#endif +import System.Exit hiding (ExitSuccess) + +import Control.Monad.Freer +import Control.Monad.Freer.Internal + +------------------------------------------------------------------------------- + -- 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] w -> IO w +runConsole req = runM (handleRelay pure go req) + where + go :: Console v -> Arr '[IO] v w -> Eff '[IO] w + go (PutStrLn msg) q = send (putStrLn msg) >>= q + go GetLine q = send getLine >>= q + go ExitSuccess q = send exitSuccess >>= q + +------------------------------------------------------------------------------- + -- Pure Interpreter Simple -- +------------------------------------------------------------------------------- +runConsolePure :: [String] -> Eff '[Console] w -> [String] +runConsolePure inputs req = + reverse . snd $ run (handleRelayS (inputs, []) (\s _ -> pure s) go req) + where + go :: ([String], [String]) + -> Console v + -> (([String], [String]) -> Arr '[] v ([String], [String])) + -> Eff '[] ([String], [String]) + go (is, os) (PutStrLn msg) q = q (is, msg : os) () + go (i:is, os) GetLine q = q (is, os) i + go ([], _) GetLine _ = error "Not enough lines" + go (_, os) ExitSuccess _ = pure ([], os) + + +------------------------------------------------------------------------------- + -- Effectful Interpreter for Deeper Stack -- +------------------------------------------------------------------------------- +runConsoleM :: Member IO r => Eff (Console ': r) w -> Eff r w +runConsoleM (Val x) = return x +runConsoleM (E u q) = case decomp u of + Right (PutStrLn msg) -> send (putStrLn msg) >> runConsoleM (qApp q ()) + Right GetLine -> send getLine >>= runConsoleM . qApp q + Right ExitSuccess -> send exitSuccess + Left u' -> E u' (tsingleton (runConsoleM . qApp q)) + +------------------------------------------------------------------------------- + -- Pure Interpreter for Deeper Stack -- +------------------------------------------------------------------------------- +runConsolePureM + :: [String] + -> Eff (Console ': r) w + -> Eff r (Maybe w,([String],[String])) + -- ^ (Nothing for ExitSuccess, (unconsumed input, produced output)) +runConsolePureM inputs = f (inputs,[]) where + f + :: ([String],[String]) + -> Eff (Console ': r) w + -> Eff r (Maybe w,([String],[String])) + f st (Val x) = return (Just x, st) + f st@(is,os) (E u q) = case decomp u of + Right (PutStrLn msg) -> f (is, msg : os) (qApp q ()) + Right GetLine -> case is of + x:s -> f (s,os) (qApp q x) + [] -> error "Not enough lines" + Right ExitSuccess -> pure (Nothing, st) + Left u' -> E u' (tsingleton (f st . qApp q)) 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/Cut.hs b/examples/src/Cut.hs new file mode 100644 --- /dev/null +++ b/examples/src/Cut.hs @@ -0,0 +1,33 @@ +module Cut where + +-- import Control.Monad.Freer.Cut + + +{- +-- The signature is inferred +tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int +tcut1 = (return (1::Int) `mplus'` return 2) `mplus'` + ((cutfalse `mplus'` return 4) `mplus'` + return 5) + +tcut1r = run . makeChoice $ call tcut1 +-- [1,2] + +tcut2 = return (1::Int) `mplus'` + call (return 2 `mplus'` (cutfalse `mplus'` return 3) `mplus'` + return 4) + `mplus'` return 5 + +-- Here we see nested call. It poses no problems... +tcut2r = run . makeChoice $ call tcut2 +-- [1,2,5] + +-- More nested calls +tcut3 = call tcut1 `mplus'` call (tcut2 `mplus'` cutfalse) +tcut3r = run . makeChoice $ call tcut3 +-- [1,2,1,2,5] + +tcut4 = call tcut1 `mplus'` (tcut2 `mplus'` cutfalse) +tcut4r = run . makeChoice $ call tcut4 +-- [1,2,1,2,5] +-} 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,15 @@ +module Fresh where + +import Control.Monad.Freer.Fresh +import Control.Monad.Freer.Trace + +traceFresh :: IO () +traceFresh = runTrace $ flip runFresh' 0 $ do + n <- fresh + trace $ "Fresh " ++ show n + n' <- fresh + trace $ "Fresh " ++ show n' +{- +Fresh 0 +Fresh 1 +-} 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,61 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +module Main where + +import Control.Monad (forever, when) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import System.Environment (getArgs) + +import Control.Monad.Freer + +import Capitalize +import Console + +------------------------------------------------------------------------------- +-- 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", ""] + $ runCapitalizeM capitalizingService + +mainConsoleA :: IO () +mainConsoleA = runM (runConsoleM (runCapitalizeM capitalizingService)) +-- | | | | +-- IO () -' | | | +-- Eff '[IO] () -' | | +-- Eff '[Console, IO] () -' | +-- Eff '[Capitalize, Console, IO] () -' + +mainConsoleB :: IO () +mainConsoleB = runM (runCapitalizeM (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/NonDet.hs b/examples/src/NonDet.hs new file mode 100644 --- /dev/null +++ b/examples/src/NonDet.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleContexts #-} +module NonDet where + +import Control.Applicative +import Control.Monad +import Control.Monad.Freer + +ifte :: Member NonDet r + => Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b +ifte t th el = (t >>= th) <|> el + +testIfte :: Member NonDet r => Eff r Int +testIfte = do + n <- gen + ifte (do d <- gen + guard $ d < n && n `mod` d == 0) + (const mzero) + (return n) + where gen = msum . fmap return $ [2..30] + +testIfteRun :: [Int] +testIfteRun = run . makeChoiceA $ testIfte 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,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module Trace where + +import Control.Monad.Freer +import Control.Monad.Freer.Reader +import Control.Monad.Freer.Trace + +import Common + +-- 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 _ [] = return [] +mapMdebug f (h:t) = do + trace $ "mapMdebug: " ++ show h + h' <- f h + t' <- mapMdebug f t + return (h':t') + +tMd :: IO [Int] +tMd = runTrace $ runReader (mapMdebug f [1..5]) (10::Int) + where f x = ask `add` return x +{- +mapMdebug: 1 +mapMdebug: 2 +mapMdebug: 3 +mapMdebug: 4 +mapMdebug: 5 +[11,12,13,14,15] +-} + +-- duplicate layers +tdup :: IO () +tdup = runTrace $ runReader m (10::Int) + where + m = do + runReader tr (20::Int) + tr + tr = do + v <- ask + trace $ "Asked: " ++ show (v::Int) +{- +Asked: 20 +Asked: 10 +-} diff --git a/freer-effects.cabal b/freer-effects.cabal new file mode 100644 --- /dev/null +++ b/freer-effects.cabal @@ -0,0 +1,196 @@ +name: freer-effects +version: 0.3.0.0 +synopsis: Implementation of effect system for Haskell. +description: + Implementation of effect system for Haskell, 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. + +license: BSD3 +license-file: LICENSE +author: Allele Dev, Ixcom Core Team, and other contributors +maintainer: ixcom-core@ixperta.com +copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +homepage: https://github.com/IxpertaSolutions/freer-effects +bug-reports: https://github.com/IxpertaSolutions/freer-effects/issues +category: Control + +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==8.0.2, GHC==8.0.1, GHC==7.10.3, GHC==7.8.4 + +extra-source-files: + README.md + changelog.md + +source-repository head + type: git + location: https://github.com/IxpertaSolutions/freer-effects.git + branch: master + +source-repository this + type: git + location: https://github.com/IxpertaSolutions/freer-effects.git + tag: 0.3.0.0 + +flag pedantic + description: Pass additional warning flags and -Werror to GHC. + default: False + manual: True + +flag test-hlint + description: Enable test suite that checks sources using HLint. + default: True + manual: True + +library + hs-source-dirs: src + exposed-modules: + Control.Monad.Freer + , Control.Monad.Freer.Coroutine + , Control.Monad.Freer.Cut + , Control.Monad.Freer.Exception + , Control.Monad.Freer.Fresh + , Control.Monad.Freer.Internal + , Control.Monad.Freer.NonDet + , Control.Monad.Freer.Reader + , Control.Monad.Freer.State + , Control.Monad.Freer.StateRW + , Control.Monad.Freer.Trace + , Control.Monad.Freer.Writer + , Data.FTCQueue + , Data.OpenUnion + , Data.OpenUnion.Internal + + default-language: Haskell2010 + + build-depends: base >=4.7 && <5 + + ghc-options: + -Wall + -fwarn-tabs + -fwarn-implicit-prelude + -fwarn-missing-import-lists + + if impl(ghc >=7.10) + cpp-options: -DDEPRECATED_LANGUAGE_OVERLAPPING_INSTANCES + + if impl(ghc >=8) + -- Flag -Wredundant-constraints is available only on GHC >=8. + ghc-options: -Wredundant-constraints + + if flag(pedantic) + ghc-options: + -Werror + +executable freer-examples + hs-source-dirs: examples/src + main-is: Main.hs + other-modules: + Capitalize + , Common + , Console + , Coroutine + , Cut + , Fresh + , NonDet + , Trace + + default-language: Haskell2010 + + build-depends: base, freer-effects + + ghc-options: -Wall + + if flag(pedantic) + ghc-options: -Werror + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tests.hs + other-modules: + Tests.Common + , Tests.Coroutine + , Tests.Exception + , Tests.Fresh + , Tests.NonDet + , Tests.Reader + , Tests.State + , Tests.StateRW + + default-language: Haskell2010 + + build-depends: + base + , freer-effects + , tasty + , tasty-hunit + , tasty-quickcheck + , QuickCheck + + ghc-options: -Wall + + if flag(pedantic) + ghc-options: -Werror + +test-suite hlint + hs-source-dirs: tests + type: exitcode-stdio-1.0 + main-is: hlint.hs + default-language: Haskell2010 + + if flag(test-hlint) + buildable: True + build-depends: + base >=4.8 && <5.0 + , hlint ==1.9.* + else + buildable: False + + ghc-options: + -Wall + -fwarn-tabs + -fwarn-implicit-prelude + -fwarn-missing-import-lists + -threaded + -with-rtsopts=-N + + if impl(ghc >=8) + -- Flag -Wredundant-constraints is available only on GHC >=8. + ghc-options: -Wredundant-constraints + + if flag(pedantic) + ghc-options: -Werror + +benchmark core + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Core.hs + + default-language: Haskell2010 + + build-depends: + base + , criterion + , free + , freer-effects + , mtl + + ghc-options: -Wall -O2 + + if flag(pedantic) + ghc-options: -Werror 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,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer +-- Description: Freer - an extensible effects library +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +module Control.Monad.Freer + ( + -- * Effect Monad + Eff + + -- ** Effect Constraints + , Member + , Members + + -- ** Sending Arbitrary Effect + , send + + -- * Handling Effects + , Arr + , run + , runM + + -- ** Building Effect Handlers + , runNat + , runNatS + , handleRelay + , handleRelayS + ) + where + +import Control.Applicative (pure) +import Control.Monad ((>>=)) +import Data.Function (($), (.), const) +import Data.Tuple (uncurry) + +import Control.Monad.Freer.Internal + ( Arr + , Eff + , Member + , Members + , handleRelay + , handleRelayS + , run + , runM + , send + ) + + +-- | Variant of 'handleRelay' simplified for the common case. +runNat + :: Member m effs + => (forall a. eff a -> m a) + -> Eff (eff ': effs) b + -> Eff effs b +runNat f = handleRelay pure $ \e -> (send (f e) >>=) + +-- | Variant of 'handleRelayS' simplified for the common case. +runNatS + :: Member m effs + => s + -> (forall a. s -> eff a -> m (s, a)) + -> Eff (eff ': effs) b + -> Eff effs b +runNatS s0 f = + handleRelayS s0 (const pure) $ \s e -> (send (f s e) >>=) . uncurry 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,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.Coroutine +-- Description: Composable coroutine effects layer. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: broken +-- 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(..) + , yield + , Status(..) + , runC + ) + where + +import Control.Monad (return) +import Data.Function (($), (.)) +import Data.Functor (Functor) + +import Control.Monad.Freer.Internal (Arr, Eff, Member, handleRelay, 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 + = Done + -- ^ Coroutine is done. + | Continue a (b -> Eff effs (Status effs a b)) + -- ^ Reporting a value of the type @a@, and resuming with the value of type + -- @b@. + +-- | Launch a coroutine and report its status. +runC :: Eff (Yield a b ': effs) w -> Eff effs (Status effs a b) +runC = handleRelay (\_ -> return Done) handler + where + handler + :: Yield a b c + -> Arr effs c (Status effs a b) + -> Eff effs (Status effs a b) + handler (Yield a k) arr = return $ Continue a (arr . k) diff --git a/src/Control/Monad/Freer/Cut.hs b/src/Control/Monad/Freer/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Cut.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.Cut +-- Description: An implementation of logical Cut. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: broken +-- Portability: GHC specific language extensions. +-- +-- Composable handler for logical Cut effects. Implemented in terms of 'Exc' +-- effect. +-- +-- Using as a starting point. +module Control.Monad.Freer.Cut + ( CutFalse(..) + , cutFalse +-- , call + ) + where + +-- import Control.Monad +import Control.Monad.Freer.Exception (Exc, throwError) +import Control.Monad.Freer.Internal (Eff, Member) + + +data CutFalse = CutFalse +-- data Choose a b = Choose [a] b + +-- | Implementation of logical Cut using Exc effects. +cutFalse :: Member (Exc CutFalse) r => Eff r a +cutFalse = throwError CutFalse + +{- +call :: Member (Exc CutFalse) r => Eff (Exc CutFalse ': r) a -> Eff r a +call m = loop [] m where + loop jq (Val x) = return x `mplus` next jq -- (C2) + loop jq (E u q) = case decomp u of + Right (Exc CutFalse) -> mzero -- drop jq (F2) + Left u -> check jq u + + check jq u | Just (Choose [] _) <- prj u = next jq -- (C1) + check jq u | Just (Choose [x] k) <- prj u = loop jq (k x) -- (C3), optim + check jq u | Just (Choose lst k) <- prj u = next $ map k lst ++ jq -- (C3) + check jq u = send (\k -> fmap k u) >>= loop jq -- (C4) + + next [] = mzero + next (h:t) = loop t h +-} diff --git a/src/Control/Monad/Freer/Exception.hs b/src/Control/Monad/Freer/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Exception.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.Exception +-- Description: An Exception effect and handler. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- Composable handler for Exception effects. Communicates success\/failure +-- via an 'Either' type. +-- +-- Using as a starting point. +module Control.Monad.Freer.Exception + ( Exc(..) + , throwError + , runError + , catchError + ) + where + +import Control.Applicative (pure) +import Data.Either (Either(Left, Right)) +import Data.Function ((.)) + +import Control.Monad.Freer.Internal (Eff, Member, handleRelay, interpose, send) + + +-------------------------------------------------------------------------------- + -- Exceptions -- +-------------------------------------------------------------------------------- + +-- | Exceptions of the type @e :: *@ with no resumption. +newtype Exc e a = Exc e + +-- | Throws an error carrying information of type @e :: *@. +throwError :: Member (Exc e) effs => e -> Eff effs a +throwError e = send (Exc 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 :: Eff (Exc e ': effs) a -> Eff effs (Either e a) +runError = handleRelay (pure . Right) (\(Exc e) _k -> pure (Left e)) + +-- | A catcher for Exceptions. Handlers are allowed to rethrow exceptions. +catchError + :: Member (Exc e) effs + => Eff effs a + -> (e -> Eff effs a) + -> Eff effs a +catchError m handle = interpose pure (\(Exc e) _k -> 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,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.Fresh +-- Description: Generation of fresh integers as an effect. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: broken +-- 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' + ) + where + +import Prelude (($!), (+)) + +import Control.Applicative (pure) +import Data.Int (Int) + +import Control.Monad.Freer.Internal (Eff, Member, handleRelayS, send) + + +-------------------------------------------------------------------------------- + -- Fresh -- +-------------------------------------------------------------------------------- + +-- | Fresh effect model. +data Fresh a 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. +runFresh' :: Eff (Fresh ': effs) a -> Int -> Eff effs a +runFresh' m s = + handleRelayS s (\_s a -> pure a) (\s' Fresh k -> (k $! s' + 1) s') m 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,250 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- 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 #-} + +-- Due to re-export of Data.FTCQueue, and Data.OpenUnion. +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module: Control.Monad.Freer.Internal +-- Description: Mechanisms to make effects work. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- Internal machinery for this effects library. This includes: +-- +-- * 'Eff' data type, for expressing effects. +-- * 'NonDet' data type, for nondeterministic effects. +-- * Functions for facilitating the construction of effects and their handlers. +-- +-- Using 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 + + -- * Handling Effects + , run + , runM + + -- ** Building Effect Handlers + , handleRelay + , handleRelayS + , interpose + + -- *** Low-level Functions for Building Effect Handlers + , qApp + , qComp + + -- ** Nondeterminism Effect + , NonDet(..) + ) + where + +import Prelude (error) -- Function error is used for imposible cases. + +import Control.Applicative + ( Alternative((<|>), empty) + , Applicative((<*>), pure) + ) +import Control.Monad + ( Monad((>>=), return) + , MonadPlus(mplus, mzero) + ) +import Data.Bool (Bool) +import Data.Either (Either(Left, Right)) +import Data.Function (($), (.)) +import Data.Functor (Functor(fmap)) +import Data.Maybe (Maybe(Just)) + +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 a way to use effects in Haskell, in such a way that +-- different types of effects can be interleaved, and so that the produced code +-- is efficient. +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 <*> Val x = E u (q |> (Val . ($ x))) + E u q <*> m = E u (q |> (`fmap` m)) + {-# INLINE (<*>) #-} + +instance Monad (Eff effs) where + -- Future versions of GHC will consider any other definition as error. + return = pure + {-# INLINE return #-} + + Val x >>= k = k x + E u q >>= k = E u (q |> k) + {-# INLINE (>>=) #-} + +-- | Send a request and wait for a reply. +send :: Member eff effs => eff a -> Eff effs a +send t = E (inj t) (tsingleton Val) + +-------------------------------------------------------------------------------- + -- Base Effect Runner -- +-------------------------------------------------------------------------------- + +-- | Runs a set of Effects. Requires that all effects are consumed. +-- Typically composed as follows: +-- +-- @ +-- 'run' . runEff1 eff1Arg . runEff2 eff2Arg1 eff2Arg2 $ someProgram +-- @ +run :: Eff '[] a -> a +run (Val x) = x +run _ = error "Internal:run - This (E) should never happen" + +-- | Runs a set of Effects. Requires that all effects are consumed, except for +-- a single effect known to be a monad. The value returned is a computation in +-- that monad. This is useful 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. + +-- | 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 + +-- | 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 + +-- | 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 + +-------------------------------------------------------------------------------- + -- 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,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.NonDet +-- Description: Non deterministic effects +-- Copyright: 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- Composable handler for 'NonDet' effects. +module Control.Monad.Freer.NonDet + ( NonDet(..) + , makeChoiceA + , msplit + ) + where + +import Control.Applicative (Alternative, (<|>), empty, pure) +import Control.Monad (liftM2, msum, return) +import Data.Bool (Bool(False, True)) +import Data.Function (($), (.)) +import Data.Maybe (Maybe(Just, Nothing)) + +import Control.Monad.Freer.Internal + ( Eff(E, Val) + , Member + , NonDet(MPlus, MZero) + , handleRelay + , prj + , qApp + , qComp + , tsingleton + ) + + +-- | A handler for nondeterminstic effects. +makeChoiceA + :: Alternative f + => Eff (NonDet ': effs) a + -> Eff effs (f a) +makeChoiceA = handleRelay (return . pure) $ \m k -> + case m of + MZero -> return empty + MPlus -> liftM2 (<|>) (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) = return (Just (x, msum jq)) + loop jq (E u q) = case prj u of + Just MZero -> case jq of + [] -> return 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,157 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.Reader +-- Description: Reader effects, for encapsulating an environment. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- 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.Applicative (pure) +import Data.Functor ((<$>)) + +import Control.Monad.Freer.Internal + ( Arr + , Eff + , Member + , handleRelay + , interpose + , send + ) + + +-- | Represents shared immutable environment of type @(e :: *)@ which is made +-- available to effectful computation. +data Reader e a where + Reader :: Reader e e + +-- | Request a value of the environment. +ask :: Member (Reader e) effs => Eff effs e +ask = send Reader + +-- | Request a value of the environment, and apply as selector\/projection +-- function to it. +asks + :: Member (Reader e) effs + => (e -> a) + -- ^ The selector\/projection function to be applied to the environment. + -> Eff effs a +asks f = f <$> ask + +-- | Handler for 'Reader' effects. +runReader :: Eff (Reader e ': effs) a -> e -> Eff effs a +runReader m e = handleRelay pure (\Reader k -> k e) m + +-- | 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 e a effs. Member (Reader e) effs + => (e -> e) + -> Eff effs a + -> Eff effs a +local f m = do + e <- f <$> ask + let h :: Reader e v -> Arr effs v a -> Eff effs a + h Reader k = k e + interpose pure h 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 calc_isCountCorrect bindings +-- > +-- > -- 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 calculateModifiedContentLen s; +-- > let len = run $ runReader calculateContentLen s ; +-- > 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,119 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.State +-- Description: State effects, for state-carrying computations. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- Composable handler for 'State' effects. Handy for passing an updatable state +-- through a computation. +-- +-- Some computations may not require the full power of 'State' effect: +-- +-- * For a read-only state, see "Control.Monad.Freer.Reader". +-- * To accumulate a value without using it on the way, see +-- "Control.Monad.Freer.Writer". +-- +-- Using 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 + ) + where + +import Control.Monad ((>>), (>>=), return) +import Data.Either (Either(Left, Right)) +import Data.Functor ((<$>), fmap) +import Data.Maybe (Maybe(Just)) +import Data.Proxy (Proxy) +import Data.Tuple (fst, snd) + +import Control.Monad.Freer.Internal + ( Eff(E, Val) + , Member + , Union + , decomp + , prj + , qApp + , qComp + , send + , tsingleton + ) + + +-------------------------------------------------------------------------------- + -- State, strict -- +-------------------------------------------------------------------------------- + +-- | Strict 'State' effects: one can either 'Get' values or 'Put' them. +data State s a where + Get :: State s s + Put :: !s -> State s () + +-- | Retrieve the current value of the state of type @s :: *@. +get :: Member (State s) effs => Eff effs s +get = send Get + +-- | Set the current state to a specified value of type @s :: *@. +put :: 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 :: Member (State s) effs => (s -> s) -> Eff effs () +modify f = fmap f get >>= put + +-- | Handler for 'State' effects. +runState :: Eff (State s ': effs) a -> s -> Eff effs (a, s) +runState (Val x) s = return (x, s) +runState (E u q) s = case decomp u of + Right Get -> runState (qApp q s) s + Right (Put s') -> runState (qApp q ()) s' + Left u' -> E u' (tsingleton (\x -> runState (qApp q x) s)) + +-- | Run a 'State' effect, returning only the final state. +execState :: Eff (State s ': effs) a -> s -> Eff effs s +execState st s = snd <$> runState st s + +-- | Run a State effect, discarding the final state. +evalState :: Eff (State s ': effs) a -> s -> Eff effs a +evalState st s = fst <$> runState st s + +-- | An encapsulated State handler, for transactional semantics. The global +-- state is updated only if the 'transactionState' finished successfully. +transactionState + :: forall s effs a + . Member (State s) effs + => Proxy s + -> Eff effs a + -> Eff effs a +transactionState _ m = do s <- get; loop s m + where + loop :: s -> Eff effs a -> Eff effs a + loop s (Val x) = put s >> return x + loop s (E (u :: Union r b) q) = case prj u :: Maybe (State s b) of + Just Get -> loop s (qApp q s) + Just (Put s') -> loop s'(qApp q ()) + _ -> E u (tsingleton k) where k = qComp q (loop s) diff --git a/src/Control/Monad/Freer/StateRW.hs b/src/Control/Monad/Freer/StateRW.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/StateRW.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.StateRW +-- Description: State effects in terms of Reader and Writer. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- Composable handler for 'State' effects in terms of 'Reader' and 'Writer' +-- effects. This module is more a tutorial on how to compose handlers. It is +-- slightly slower than a dedicated 'State' handler. +-- +-- Using as a starting point. +module Control.Monad.Freer.StateRW + ( runStateR + , Reader + , Writer + , tell + , ask + ) + where + +import Control.Monad (return) +import Data.Either (Either(Left, Right)) + +import Control.Monad.Freer.Reader (Reader(Reader), ask) +import Control.Monad.Freer.Writer (Writer(Writer), tell) +import Control.Monad.Freer.Internal (Eff(E, Val), decomp, qComp, tsingleton) + + +-- | State handler, using 'Reader' and 'Writer' effects. +runStateR :: Eff (Writer s ': Reader s ': effs) a -> s -> Eff effs (a, s) +runStateR m s = loop s m + where + loop :: s -> Eff (Writer s ': Reader s ': effs) a -> Eff effs (a, s) + loop s' (Val x) = return (x, s') + loop s' (E u q) = case decomp u of + Right (Writer o) -> k o () + Left u' -> case decomp u' of + Right Reader -> k s' s' + Left u'' -> E u'' (tsingleton (k s')) + where + k s'' = qComp q (loop s'') 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,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.Trace +-- Description: Composable Trace effects. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- Composable handler for 'Trace' effects. Trace allows one to debug the +-- operation of sequences of effects by outputing to the console. +-- +-- Using as a starting point. +module Control.Monad.Freer.Trace + ( Trace(..) + , trace + , runTrace + ) + where + +import Control.Monad ((>>), return) +import Data.Function ((.)) +import Data.String (String) +import System.IO (IO, putStrLn) + +import Control.Monad.Freer.Internal (Eff(E, Val), 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,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module: Control.Monad.Freer.Writer +-- Description: Composable Writer effects. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- 'Writer' effects, for writing\/appending values (line count, list of +-- messages, etc.) to an output. Current value of 'Writer' effect output is not +-- accessible to the computation. +-- +-- Using as a starting point. +module Control.Monad.Freer.Writer + ( Writer(..) + , tell + , runWriter + ) + where + +import Control.Applicative (pure) +import Control.Arrow (second) +import Data.Function (($)) +import Data.Functor ((<$>)) +import Data.Monoid (Monoid, (<>), mempty) + +import Control.Monad.Freer.Internal (Eff, Member, handleRelay, send) + + +-- | Writer effects - send outputs to an effect environment. +data Writer w a where + Writer :: w -> Writer w () + +-- | Send a change to the attached environment. +tell :: Member (Writer w) effs => w -> Eff effs () +tell w = send $ Writer w + +-- | Simple handler for 'Writer' effects. +runWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs (a, w) +runWriter = handleRelay (\a -> pure (a, mempty)) $ \(Writer 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,78 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: Data.FTCQueue +-- Description: Fast type-aligned queue optimized to effectful functions. +-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- 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,67 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# 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. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- This implementation relies on _closed_ type families added to GHC 7.8. It +-- has NO overlapping instances and NO @Typeable@. Alas, the absence of +-- @Typeable@ means the projections and injections generally take linear time. +-- The code illustrate how to use closed type families to disambiguate +-- otherwise overlapping instances. +-- +-- The data constructors of 'Union' are not exported. Essentially, the nested +-- 'Either' data type. +-- +-- Using as a starting +-- point. +module Data.OpenUnion + ( + -- * Open Union + Union + + -- * Open Union Operations + , decomp + , weaken + , extract + + -- * Open Union Membership Constraints + , Member(..) + , Members + ) + where + +#if MIN_VERSION_base(4,9,0) +import Data.Kind (Constraint) +#else +import GHC.Exts (Constraint) +#endif + +import Data.OpenUnion.Internal + ( Member(inj, prj) + , Union + , decomp + , extract + , weaken + ) + + +type family Members m r :: Constraint where + Members (t ': c) r = (Member t r, Members c r) + Members '[] r = () 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,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- GHC >=7.10 deprecated OverlappingInstances in favour of instance by instance +-- annotation using OVERLAPPABLE and OVERLAPPING pragmas. +#ifdef DEPRECATED_LANGUAGE_OVERLAPPING_INSTANCES +#define PRAGMA_OVERLAPPABLE {-# OVERLAPPABLE #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define PRAGMA_OVERLAPPABLE +#endif + +-- | +-- 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. +-- License: BSD3 +-- Maintainer: ixcom-core@ixperta.com +-- Stability: experimental +-- Portability: GHC specific language extensions. +-- +-- These are internal definitions and should be used with caution. There are no +-- guarantees that the API of this module will be preserved between minor +-- versions of this package. +-- +-- Open unions (type-indexed co-products, i.e. type-indexed sums) for +-- extensible effects All operations are constant-time. +-- +-- Based on +-- . +-- +-- 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 Prelude ((+), (-)) + +import Data.Bool (otherwise) +import Data.Either (Either(Left, Right)) +import Data.Eq ((==)) +import Data.Function (($)) +import Data.Maybe (Maybe(Just, Nothing)) +import Data.Word (Word) +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 = P {unP :: Word} + +-- | Find an index of an element @t :: * -> *@ in a type list @r :: [* -> *]@. +-- The element must exist. +-- +-- This is essentially a compile-time computation without run-time overhead. +class FindElem (t :: * -> *) (r :: [* -> *]) 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 + +-- | Base case; element is at the current position in the list. +instance FindElem t (t ': r) where + elemNo = P 0 + +-- | Recursion; element is not at the current position, but is somewhere in the +-- list. +instance PRAGMA_OVERLAPPABLE FindElem t r => FindElem t (t' ': r) where + elemNo = P $ 1 + unP (elemNo :: P t r) + +-- | 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' +-- @ +class FindElem t r => Member (t :: * -> *) r where + -- | Takes a request of type @t :: * -> *@, and injects it into the + -- 'Union'. + -- + -- /O(1)/ + inj :: t a -> Union r 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 r a -> Maybe (t a) + +instance FindElem t r => Member t r where + inj = unsafeInj $ unP (elemNo :: P t r) + {-# INLINE inj #-} + + prj = unsafePrj $ unP (elemNo :: P t 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 #-} diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +module Main where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Control.Monad.Freer + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Tests.Coroutine +import Tests.Exception +import Tests.Fresh +import Tests.NonDet +import Tests.Reader +import Tests.State +import Tests.StateRW + +import qualified Data.List + +-------------------------------------------------------------------------------- + -- 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) + ] + +-------------------------------------------------------------------------------- + -- Coroutine Tests -- +-------------------------------------------------------------------------------- + +-- | 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 + +coroutineTests :: TestTree +coroutineTests = testGroup "Coroutine Eff tests" + [ testProperty "Counting consecutive pairs of odds" + (\list -> runTestCoroutine list == countOddDuoPrefix list) + ] + +-------------------------------------------------------------------------------- + -- Exception Tests -- +-------------------------------------------------------------------------------- +exceptionTests :: TestTree +exceptionTests = testGroup "Exception Eff tests" + [ testProperty "Exc 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) + ] + +-------------------------------------------------------------------------------- + -- Fresh Effect Tests -- +-------------------------------------------------------------------------------- +freshTests :: TestTree +freshTests = 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)) + ] + +-------------------------------------------------------------------------------- + -- Nondeterministic Effect Tests -- +-------------------------------------------------------------------------------- +-- https://wiki.haskell.org/Prime_numbers +primesTo :: Int -> [Int] +primesTo m = sieve [2..m] {- (\\) is set-difference for unordered lists -} + where + sieve (x:xs) = x : sieve (xs Data.List.\\ [x,x+x..m]) + sieve [] = [] + +nonDetTests :: TestTree +nonDetTests = testGroup "NonDet tests" + [ testProperty "Primes in 2..n generated by ifte" + (\n' -> let n = abs n' in testIfte [2..n] == primesTo n) + ] + +-------------------------------------------------------------------------------- + -- Reader Effect Tests -- +-------------------------------------------------------------------------------- +readerTests :: TestTree +readerTests = 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) + ] + +-------------------------------------------------------------------------------- + -- State[RW] Effect Tests -- +-------------------------------------------------------------------------------- +stateTests :: TestTree +stateTests = 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 "testPutGet: State == StateRW" $ + \n -> testPutGet n 0 == testPutGetRW n 0 + , testProperty "testPutGetPutGetPlus: State == StateRW" $ + \p1 p2 start -> testPutGetPutGetPlus p1 p2 start == testPutGetPutGetPlusRW p1 p2 start + , testProperty "testGetStart: State == StateRW" $ + \n -> testGetStart n == testGetStartRW n + , testProperty "testEvalState: evalState discards final state" $ + \n -> testEvalState n == n + , testProperty "testExecState: execState returns final state" $ + \n -> testExecState n == n + ] + +-------------------------------------------------------------------------------- + -- Runner -- +-------------------------------------------------------------------------------- +main :: IO () +main = defaultMain $ testGroup "Tests" + [ pureTests + , coroutineTests + , exceptionTests + , freshTests + , nonDetTests + , readerTests + , stateTests + ] diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Common.hs @@ -0,0 +1,6 @@ +module Tests.Common where + +import Control.Applicative + +add :: Applicative f => f Int -> f Int -> f Int +add = liftA2 (+) 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,35 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +module Tests.Coroutine ( + runTestCoroutine +) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Control.Monad +import Control.Monad.Freer +import Control.Monad.Freer.Coroutine +import Control.Monad.Freer.State + +runTestCoroutine :: [Int] -> Int +runTestCoroutine list = snd $ run $ runState effTestCoroutine 0 + 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 -> Int) >> testCoroutine) + + effTestCoroutine = do + status <- runC testCoroutine + handleStatus list status + where + handleStatus _ Done = return () + handleStatus (i:is) (Continue () k) = k i >>= handleStatus is + handleStatus [] _ = return () 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,85 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} + +module Tests.Exception ( + TooBig(..), + + testExceptionTakesPriority, + + ter1, + ter2, + ter3, + ter4, + + ex2rr, + ex2rr1, + ex2rr2, +) where + +import Control.Monad.Freer +import Control.Monad.Freer.Exception +import Control.Monad.Freer.Reader +import Control.Monad.Freer.State + +import Tests.Common + +testExceptionTakesPriority :: Int -> Int -> Either Int Int +testExceptionTakesPriority x y = run $ runError (go x y) + where go a b = return a `add` throwError b + +-- The following won't type: unhandled exception! +-- ex2rw = run et2 +{- + No instance for (Member (Exc 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, Exc String] r) => Eff r b +tes1 = do + incr + throwError "exc" + +ter1 :: (Either String Int, Int) +ter1 = run $ runState (runError tes1) (1::Int) + +ter2 :: Either String (String, Int) +ter2 = run $ runError (runState tes1 (1::Int)) + +teCatch :: Member (Exc String) r => Eff r a -> Eff r String +teCatch m = catchError (m >> return "done") (\e -> return (e::String)) + +ter3 :: (Either String String, Int) +ter3 = run $ runState (runError (teCatch tes1)) (1::Int) + +ter4 :: Either String (String, Int) +ter4 = run $ runError (runState (teCatch tes1) (1::Int)) + +-- The example from the paper +newtype TooBig = TooBig Int deriving (Eq, Show) + +ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int +ex2 m = do + v <- m + if v > 5 then throwError (TooBig v) + else return v + +-- specialization to tell the type of the exception +runErrBig :: Eff (Exc TooBig ': r) a -> Eff r (Either TooBig a) +runErrBig = runError + +ex2rr :: Either TooBig Int +ex2rr = run go + where go = runReader (runErrBig (ex2 ask)) (5::Int) + +ex2rr1 :: Either TooBig Int +ex2rr1 = run $ runReader (runErrBig (ex2 ask)) (7::Int) + +-- Different order of handlers (layers) +ex2rr2 :: Either TooBig Int +ex2rr2 = run $ runErrBig (runReader (ex2 ask) (7::Int)) 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,11 @@ +module Tests.Fresh where + +import Control.Monad +import Control.Monad.Freer +import Control.Monad.Freer.Fresh + +makeFresh :: Int -> Eff r Int +makeFresh n = runFresh' (fmap last (replicateM n fresh)) 0 + +testFresh :: Int -> Int +testFresh = run . makeFresh 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,23 @@ +{-# LANGUAGE FlexibleContexts #-} +module Tests.NonDet where + +import Control.Applicative +import Control.Monad +import Control.Monad.Freer +import Control.Monad.Freer.NonDet + +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 (do d <- gen + guard $ d < n && n `mod` d == 0) + (const mzero) + (return n) + where gen = msum (fmap return 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,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +module Tests.Reader ( + testReader, + testMultiReader, + testLocal +) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Control.Monad.Freer +import Control.Monad.Freer.Reader + +import Tests.Common + +-------------------------------------------------------------------------------- + -- Examples -- +-------------------------------------------------------------------------------- +testReader :: Int -> Int -> Int +testReader n x = run . flip runReader n $ ask `add` pure x + +{- +t1rr' = run t1 + No instance for (Member (Reader Int) Void) + arising from a use of `t1' +-} + +testMultiReader :: Integer -> Int -> Integer +testMultiReader i n = run . flip runReader i . flip runReader n $ t2 + where t2 = do + v1 <- ask + v2 <- ask + return $ 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 t3 env + where t3 = t1 `add` local (+ inc) t1 + t1 = ask `add` return (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,39 @@ +{-# LANGUAGE FlexibleContexts #-} +module Tests.State ( + testPutGet, + testPutGetPutGetPlus, + testGetStart, + testEvalState, + testExecState +) where + +import Control.Monad.Freer +import Control.Monad.Freer.State + +testPutGet :: Int -> Int -> (Int,Int) +testPutGet n start = run (runState go start) + where go = put n >> get + +testPutGetPutGetPlus :: Int -> Int -> Int -> (Int,Int) +testPutGetPutGetPlus p1 p2 start = run (runState go start) + where go = do + put p1 + x <- get + put p2 + y <- get + return (x+y) + +testGetStart :: Int -> (Int,Int) +testGetStart = run . runState get + +testEvalState :: Int -> Int +testEvalState = run . evalState go + where + go = do + x <- get + -- destroy the previous state + put (0 :: Int) + return x + +testExecState :: Int -> Int +testExecState n = run $ execState (put n) 0 diff --git a/tests/Tests/StateRW.hs b/tests/Tests/StateRW.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/StateRW.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} +module Tests.StateRW ( + testPutGetRW, + testPutGetPutGetPlusRW, + testGetStartRW +) where + +import Control.Monad.Freer +import Control.Monad.Freer.StateRW + +testPutGetRW :: Int -> Int -> (Int,Int) +testPutGetRW n start = run (runStateR go start) + where go = tell n >> ask + +testPutGetPutGetPlusRW :: Int -> Int -> Int -> (Int,Int) +testPutGetPutGetPlusRW p1 p2 start = run (runStateR go start) + where go = do + tell p1 + x <- ask + tell p2 + y <- ask + return (x+y) + +testGetStartRW :: Int -> (Int,Int) +testGetStartRW = run . runStateR go + where go = ask diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: Main +-- Description: HLint tests executor +-- Copyright: (c) 2015-2016, Ixperta Solutions s.r.o. +-- License: BSD3 +-- +-- Stability: stable +-- Portability: portable +-- +-- HLint tests executor. +module Main (main) + where + +import Control.Monad (unless) +import Data.Function (($)) +import Data.List (null) +import Data.Monoid ((<>)) +import System.IO (IO, putStrLn) +import System.Exit (exitFailure) + +import Language.Haskell.HLint (hlint) + + +main :: IO () +main = do + putStrLn "" -- less confusing output, test-framework does this too + hints <- hlint $ hlintOpts <> ["."] + unless (null hints) exitFailure + where + hlintOpts = + [ "-XNoPatternSynonyms" + ]