packages feed

freer-effects (empty) → 0.3.0.0

raw patch · 40 files changed

+2968/−0 lines, 40 filesdep +QuickCheckdep +basedep +criterionsetup-changed

Dependencies added: QuickCheck, base, criterion, free, freer-effects, hlint, mtl, tasty, tasty-hunit, tasty-quickcheck

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Core.hs view
@@ -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+    ]+  ]
+ changelog.md view
@@ -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+  <http://okmij.org/ftp/Haskell/extensible/OpenUnion51.hs> 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
+ examples/src/Capitalize.hs view
@@ -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))
+ examples/src/Common.hs view
@@ -0,0 +1,6 @@+module Common where++import Control.Applicative++add :: Applicative f => f Int -> f Int -> f Int+add = liftA2 (+)
+ examples/src/Console.hs view
@@ -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))
+ examples/src/Coroutine.hs view
@@ -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+-}++-}
+ examples/src/Cut.hs view
@@ -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]+-}
+ examples/src/Fresh.hs view
@@ -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+-}
+ examples/src/Main.hs view
@@ -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) ++ "]"
+ examples/src/NonDet.hs view
@@ -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
+ examples/src/Trace.hs view
@@ -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+-}
+ freer-effects.cabal view
@@ -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.:+  .+  * <http://okmij.org/ftp/Haskell/extensible/more.pdf Freer Monads, More Extensible Effects>+  .+  * <http://okmij.org/ftp/Haskell/zseq.pdf Reflection without Remorse>+  .+  * <http://okmij.org/ftp/Haskell/extensible/exteff.pdf Extensible Effects>+  .+  The key features are:+  .+  * An efficient effect system for Haskell - as a library!+  .+  * Reimplementations of several common Haskell monad transformers as effects.+  .+  * Core components for defining your own Effects.++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
+ src/Control/Monad/Freer.hs view
@@ -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
+ src/Control/Monad/Freer/Coroutine.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> 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)
+ src/Control/Monad/Freer/Cut.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> 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+-}
+ src/Control/Monad/Freer/Exception.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> 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
+ src/Control/Monad/Freer/Fresh.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> 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
+ src/Control/Monad/Freer/Internal.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.Internal+    (+    -- * Effect Monad+      Eff(..)+    , Arr+    , Arrs++    -- ** Open Union+    --+    -- | Open Union (type-indexed co-product) of effects.+    , module Data.OpenUnion++    -- ** Fast Type-aligned Queue+    --+    -- | Fast type-aligned queue optimized to effectful functions of type+    -- @(a -> m b)@.+    , module Data.FTCQueue++    -- ** Sending Arbitrary Effect+    , send++    -- * 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
+ src/Control/Monad/Freer/NonDet.hs view
@@ -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)
+ src/Control/Monad/Freer/Reader.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.Reader+    (+    -- * Reader Effect+      Reader(..)++    -- * Reader Operations+    , ask+    , asks+    , local++    -- * Reader Handlers+    , runReader++    -- * Example 1: Simple Reader Usage+    -- $simpleReaderExample++    -- * Example 2: Modifying Reader Content With @local@+    -- $localExample+    )+  where++import Control.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)
+ src/Control/Monad/Freer/State.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.+module Control.Monad.Freer.State+    (+    -- * State Effect+      State(..)++    -- * State Operations+    , get+    , put+    , modify++    -- * State Handlers+    , runState+    , evalState+    , execState++    -- * State Utilities+    , transactionState+    )+  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)
+ src/Control/Monad/Freer/StateRW.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> 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'')
+ src/Control/Monad/Freer/Trace.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> 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 ())
+ src/Control/Monad/Freer/Writer.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> 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 ()
+ src/Data/FTCQueue.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/FTCQueue1.hs> as a starting+-- point.+--+-- A minimal version of FTCQueue from "Reflection w/o Remorse":+--+-- * Research: <http://okmij.org/ftp/Haskell/Reflection.html>+-- * <https://hackage.haskell.org/package/type-aligned type-aligned> (FTCQueue)+module Data.FTCQueue+    ( FTCQueue+    , tsingleton+    , (|>)+    , snoc+    , (><)+    , append+    , ViewL(..)+    , tviewl+    )+  where+++-- | Non-empty tree. Deconstruction operations make it more and more+-- left-leaning+data FTCQueue m a b where+    Leaf :: (a -> m b) -> FTCQueue m a b+    Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b++-- | Build a leaf from a single operation. [O(1)]+tsingleton :: (a -> m b) -> FTCQueue m a b+tsingleton = Leaf+{-# INLINE tsingleton #-}++-- | Append an operation to the right of the tree. [O(1)]+(|>) :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b+t |> r = Node t (Leaf r)+{-# INLINE (|>) #-}++-- | An alias for '(|>)'+snoc :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b+snoc = (|>)+{-# INLINE snoc #-}++-- | Append two trees of operations. [O(1)]+(><)   :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b+t1 >< t2 = Node t1 t2+{-# INLINE (><) #-}++-- | An alias for '(><)'+append :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b+append = (><)+{-# INLINE append #-}++-- | Left view deconstruction data structure.+data ViewL m a b where+    TOne  :: (a -> m b) -> ViewL m a b+    (:|)  :: (a -> m x) -> FTCQueue m x b -> ViewL m a b++-- | Left view deconstruction. [average O(1)]+tviewl :: FTCQueue m a b -> ViewL m a b+tviewl (Leaf r)     = TOne r+tviewl (Node t1 t2) = go t1 t2+  where+    go :: FTCQueue m a x -> FTCQueue m x b -> ViewL m a b+    go (Leaf r)       tr = r :| tr+    go (Node tl1 tl2) tr = go tl1 (Node tl2 tr)
+ src/Data/OpenUnion.hs view
@@ -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 <http://okmij.org/ftp/Haskell/extensible/OpenUnion41.hs> 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 = ()
+ src/Data/OpenUnion/Internal.hs view
@@ -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+-- <http://okmij.org/ftp/Haskell/extensible/OpenUnion51.hs OpenUnion51.hs>.+--+-- Type-list @r :: [* -> *]@ of open union components is a small Universe.+-- Therefore, we can use a @Typeable@-like evidence in that universe. In our+-- case a simple index of an element in the type-list is sufficient+-- substitution for @Typeable@.+module Data.OpenUnion.Internal+  where++import 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 #-}
+ tests/Tests.hs view
@@ -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+  ]
+ tests/Tests/Common.hs view
@@ -0,0 +1,6 @@+module Tests.Common where++import Control.Applicative++add :: Applicative f => f Int -> f Int -> f Int+add = liftA2 (+)
+ tests/Tests/Coroutine.hs view
@@ -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 ()
+ tests/Tests/Exception.hs view
@@ -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))
+ tests/Tests/Fresh.hs view
@@ -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
+ tests/Tests/NonDet.hs view
@@ -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
+ tests/Tests/Reader.hs view
@@ -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)
+ tests/Tests/State.hs view
@@ -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
+ tests/Tests/StateRW.hs view
@@ -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
+ tests/hlint.hs view
@@ -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"+        ]