├── Setup.hs ├── run ├── Data ├── FastTCQueue.hs ├── TConsList.hs ├── TSnocList.hs ├── CTQueue.hs ├── Interface │ ├── Sequence.hs │ └── TSequence.hs └── RTQueue.hs ├── Base.hs ├── Freer.hs ├── Computation.hs ├── Church.hs ├── Codensity.hs ├── LICENSE ├── stack.yaml ├── Free.hs ├── freemonad-benchmark.cabal ├── Main.hs ├── NoRemorse.hs └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ghc -O2 Bench.hs 4 | ./Bench -o bench.html 5 | -------------------------------------------------------------------------------- /Data/FastTCQueue.hs: -------------------------------------------------------------------------------- 1 | module Data.FastTCQueue(module Data.Interface.TSequence, FastTCQueue) where 2 | 3 | import Data.Interface.TSequence 4 | import Data.RTQueue 5 | import Data.CTQueue 6 | 7 | type FastTCQueue = CTQueue RTQueue 8 | -------------------------------------------------------------------------------- /Data/TConsList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Data.TConsList where 4 | 5 | import Data.Interface.TSequence 6 | 7 | data TConsList c x y where 8 | CNil :: TConsList c x x 9 | Cons :: c x y -> TConsList c y z -> TConsList c x z 10 | 11 | instance TSequence TConsList where 12 | tempty = CNil 13 | tsingleton c = Cons c CNil 14 | (<|) = Cons 15 | tviewl CNil = TEmptyL 16 | tviewl (Cons h t) = h :| t 17 | -------------------------------------------------------------------------------- /Data/TSnocList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Data.TSnocList where 4 | 5 | 6 | import Data.Interface.TSequence 7 | 8 | data TSnocList c x y where 9 | SNil :: TSnocList c x x 10 | Snoc :: TSnocList c x y -> c y z -> TSnocList c x z 11 | 12 | instance TSequence TSnocList where 13 | tempty = SNil 14 | tsingleton c = Snoc SNil c 15 | (|>) = Snoc 16 | tviewr SNil = TEmptyR 17 | tviewr (Snoc p l) = p :|< l 18 | -------------------------------------------------------------------------------- /Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, FunctionalDependencies, FlexibleContexts #-} 2 | module Base where 3 | 4 | data F a = F { unF :: Int -> (Int, a) } 5 | deriving Functor 6 | 7 | get :: MonadFree F free => free Int 8 | get = wrap . F $ \s -> (s, return s) 9 | 10 | put :: MonadFree F free => Int -> free () 11 | put s = wrap . F $ \_ -> (s, return ()) 12 | 13 | class Monad m => MonadFree f m | m -> f where 14 | wrap :: f (m a) -> m a 15 | -------------------------------------------------------------------------------- /Freer.hs: -------------------------------------------------------------------------------- 1 | -- http://okmij.org/ftp/Haskell/extensible/more.pdf 2 | {-# OPTIONS_GHC -Wall #-} 3 | {-# LANGUAGE ExistentialQuantification, RankNTypes #-} 4 | 5 | module Freer where 6 | import Base 7 | import Control.Monad 8 | 9 | data Free f a 10 | = Pure a 11 | | forall b . Impure (f b) (b -> Free f a) 12 | 13 | instance Functor (Free f) where 14 | fmap = liftM 15 | instance Applicative (Free f) where 16 | pure = return 17 | (<*>) = ap 18 | instance Monad (Free f) where 19 | return = Pure 20 | Pure x >>= k = k x 21 | Impure a k1 >>= k = Impure a (k1 >=> k) 22 | 23 | fold :: (forall b . f b -> b) -> Free f a -> a 24 | fold _ (Pure x) = x 25 | fold f (Impure a k) = fold f (k (f a)) 26 | 27 | instance Functor f => MonadFree f (Free f) where 28 | wrap a = Impure a id 29 | 30 | run :: Free F a -> Int -> (Int, a) 31 | run (Pure x) s = (s, x) 32 | run (Impure (F a) k) s = 33 | case a s of 34 | (s', x) -> run (k x) s' 35 | -------------------------------------------------------------------------------- /Computation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes #-} 2 | module Computation where 3 | 4 | import Base 5 | import Control.Monad 6 | import qualified Control.Monad.State.Strict as MTL 7 | 8 | computation 9 | :: (Monad m, MonadFree F m) 10 | => Int 11 | -> m () 12 | computation n = forM_ [1..n] $ \_ -> do 13 | s <- get 14 | put $! s + 1 15 | 16 | mtlComputation :: Int -> MTL.State Int () 17 | mtlComputation n = forM_ [1..n] $ \_ -> do 18 | s <- MTL.get 19 | MTL.put $! s + 1 20 | 21 | computation2 22 | :: (Monad m, MonadFree F m) 23 | => Int 24 | -> m () 25 | computation2 n = 26 | if n == 0 27 | then return () 28 | else do 29 | computation2 (n-1) 30 | s <- get 31 | put $! s + 1 32 | 33 | mtlComputation2 :: Int -> MTL.State Int () 34 | mtlComputation2 n = 35 | if n == 0 36 | then return () 37 | else do 38 | mtlComputation2 (n-1) 39 | s <- MTL.get 40 | MTL.put $! s + 1 41 | -------------------------------------------------------------------------------- /Church.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses #-} 2 | module Church where 3 | 4 | import Control.Applicative 5 | import Control.Monad 6 | import Base 7 | 8 | newtype ChurchFree f a = ChurchFree { runChurchFree :: forall w. (a -> w) -> (f w -> w) -> w } 9 | 10 | instance Functor (ChurchFree f) where 11 | fmap = liftM 12 | {-# INLINE fmap #-} 13 | 14 | instance Applicative (ChurchFree f) where 15 | pure = return 16 | (<*>) = ap 17 | 18 | instance Monad (ChurchFree f) where 19 | return x = ChurchFree $ \ret _ -> ret x 20 | {-# INLINE return #-} 21 | 22 | m >>= f = ChurchFree $ \ret emb -> runChurchFree m (\v -> runChurchFree (f v) ret emb) emb 23 | {-# INLINE (>>=) #-} 24 | 25 | instance Functor f => MonadFree f (ChurchFree f) where 26 | wrap a = ChurchFree $ \ret w -> w (fmap (\x -> runChurchFree x ret w) a) 27 | 28 | run :: ChurchFree F a -> Int -> (Int, a) 29 | run a = 30 | runChurchFree a 31 | (\r s -> (s, r)) 32 | (\t s -> case (unF t s) of (s', k) -> k s') 33 | -------------------------------------------------------------------------------- /Codensity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses #-} 2 | module Codensity where 3 | 4 | import Control.Applicative 5 | import Control.Monad 6 | import Base 7 | import qualified Free 8 | 9 | newtype Codensity f a = Codensity { 10 | runCodensity :: forall b. (a -> f b) -> f b 11 | } 12 | 13 | instance Functor (Codensity f) where 14 | fmap f m = Codensity (\k -> runCodensity m (k. f)) 15 | 16 | instance Applicative (Codensity f) where 17 | pure = return 18 | (<*>) = ap 19 | 20 | instance Monad (Codensity f) where 21 | return a = Codensity (\k -> k a) 22 | c >>= f = Codensity (\k -> runCodensity c (\a -> runCodensity (f a) k)) 23 | 24 | toCodensity :: Monad m => m a -> Codensity m a 25 | toCodensity m = Codensity (m >>=) 26 | 27 | fromCodensity :: Monad m => Codensity m a -> m a 28 | fromCodensity c = runCodensity c return 29 | 30 | instance Functor f => MonadFree f (Codensity (Free.Free f)) where 31 | wrap t = Codensity $ \h -> wrap (fmap (\(Codensity p) -> p h) t) 32 | 33 | run :: Codensity (Free.Free F) a -> Int -> (Int, a) 34 | run = Free.run . fromCodensity 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Roman Cheplyaka 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.7 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 0.1.4.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | -------------------------------------------------------------------------------- /Data/CTQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Data.CTQueue where 4 | 5 | 6 | import Data.Interface.TSequence 7 | 8 | -- Author : Atze van der Ploeg 9 | -- A purely functional catenable queue representation with 10 | -- that turns takes a purely functional queue and turns in it into 11 | -- a catenable queue, i.e. with the same complexity for (><) as for (|>) 12 | -- Based on Purely functional data structures by Chris Okasaki 13 | -- section 7.2: Catenable lists 14 | 15 | data CTQueue q c x y where 16 | C0 :: CTQueue q c x x 17 | CN :: c x y -> !(q (CTQueue q c) y z) -> CTQueue q c x z 18 | 19 | instance TSequence q => TSequence (CTQueue q) where 20 | tempty = C0 21 | tsingleton a = CN a tempty 22 | C0 >< ys = ys 23 | xs >< C0 = xs 24 | (CN x q) >< ys = CN x (q |> ys) 25 | 26 | tviewl C0 = TEmptyL 27 | tviewl (CN h t) = h :| linkAll t 28 | where 29 | linkAll :: TSequence q => q (CTQueue q c) a b -> CTQueue q c a b 30 | linkAll v = case tviewl v of 31 | TEmptyL -> C0 32 | CN x q :| t -> CN x (q `snoc` linkAll t) 33 | snoc q C0 = q 34 | snoc q r = q |> r 35 | -------------------------------------------------------------------------------- /Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 2 | module Free where 3 | 4 | import Base 5 | import Control.Applicative 6 | 7 | data Free f a = Pure a | Free (f (Free f a)) 8 | 9 | instance Functor f => Functor (Free f) where 10 | fmap f = go where 11 | go (Pure a) = Pure (f a) 12 | go (Free fa) = Free (go <$> fa) 13 | {-# INLINE fmap #-} 14 | 15 | instance Functor f => Applicative (Free f) where 16 | pure = Pure 17 | {-# INLINE pure #-} 18 | Pure a <*> Pure b = Pure $ a b 19 | Pure a <*> Free mb = Free $ fmap a <$> mb 20 | Free ma <*> b = Free $ (<*> b) <$> ma 21 | 22 | instance Functor f => Monad (Free f) where 23 | return = Pure 24 | {-# INLINE return #-} 25 | Pure a >>= f = f a 26 | Free m >>= f = Free ((>>= f) <$> m) 27 | 28 | instance Functor f => MonadFree f (Free f) where wrap = Free 29 | 30 | run :: Free F a -> Int -> (Int, a) 31 | run (Pure x) s = (s, x) 32 | run (Free (F a)) s = 33 | case a s of 34 | (s', a') -> run a' s' 35 | 36 | runLazily :: Free F a -> Int -> (Int, a) 37 | runLazily (Pure x) s = (s, x) 38 | runLazily (Free (F a)) s = 39 | case a s of 40 | ~(s', a') -> run a' s' 41 | -------------------------------------------------------------------------------- /Data/Interface/Sequence.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs,FlexibleInstances,UndecidableInstances #-} 2 | 3 | module Data.Interface.Sequence where 4 | 5 | import Data.Monoid 6 | import Data.Foldable 7 | import Data.Traversable 8 | import Control.Applicative hiding (empty) 9 | import Prelude hiding (foldr,foldl) 10 | 11 | class Sequence s where 12 | empty :: s a 13 | singleton :: a -> s a 14 | (.><) :: s a -> s a -> s a 15 | viewl :: s a -> ViewL s a 16 | viewr :: s a -> ViewR s a 17 | (.|>) :: s a -> a -> s a 18 | (.<|) :: a -> s a -> s a 19 | 20 | l .|> r = l .>< singleton r 21 | l .<| r = singleton l .>< r 22 | l .>< r = case viewl l of 23 | EmptyL -> r 24 | h :< t -> h .<| (t .>< r) 25 | 26 | viewl q = case viewr q of 27 | EmptyR -> EmptyL 28 | p :> l -> case viewl p of 29 | EmptyL -> l :< empty 30 | h :< t -> h :< (t .|> l) 31 | 32 | viewr q = case viewl q of 33 | EmptyL -> EmptyR 34 | h :< t -> case viewr t of 35 | EmptyR -> empty :> h 36 | p :> l -> (h .<| p) :> l 37 | 38 | data ViewL s a where 39 | EmptyL :: ViewL s a 40 | (:<) :: a -> s a -> ViewL s a 41 | 42 | data ViewR s a where 43 | EmptyR :: ViewR s a 44 | (:>) :: s a -> a -> ViewR s a 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /freemonad-benchmark.cabal: -------------------------------------------------------------------------------- 1 | -- Initial freemonad-benchmark.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: freemonad-benchmark 5 | version: 1 6 | synopsis: Free monads benchmark 7 | -- description: 8 | homepage: https://github.com/feuerbach/freemonad-benchmark 9 | license: MIT 10 | license-file: LICENSE 11 | author: Roman Cheplyaka 12 | maintainer: roma@ro-che.info 13 | -- copyright: 14 | category: Control 15 | build-type: Simple 16 | -- extra-source-files: 17 | cabal-version: >=1.10 18 | 19 | executable freemonad-benchmark 20 | main-is: Main.hs 21 | build-depends: base, criterion, mtl 22 | default-language: Haskell2010 23 | default-extensions: 24 | MultiParamTypeClasses 25 | FlexibleInstances 26 | FunctionalDependencies 27 | ghc-options: -O2 28 | other-modules: 29 | Base 30 | Church 31 | Codensity 32 | Computation 33 | Data.CTQueue 34 | Data.FastTCQueue 35 | Data.Interface.Sequence 36 | Data.Interface.TSequence 37 | Data.RTQueue 38 | Data.TConsList 39 | Data.TSnocList 40 | Free 41 | Freer 42 | NoRemorse 43 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes #-} 2 | module Main (main) where 3 | 4 | import Base 5 | import Computation 6 | import qualified Free 7 | import qualified Church 8 | import qualified Codensity 9 | import qualified NoRemorse 10 | import qualified Freer 11 | import Control.Monad 12 | import qualified Control.Monad.State.Strict as MTL 13 | 14 | import Criterion (bench, nf, bgroup, Benchmark) 15 | import Criterion.Main (defaultMain) 16 | 17 | 18 | n = 50 19 | 20 | benchmarks 21 | :: (forall m . (Monad m, MonadFree F m) => Int -> m ()) 22 | -> (Int -> MTL.State Int ()) 23 | -> Int 24 | -> [Benchmark] 25 | benchmarks computation mtlComputation n = 26 | [ bench "Free" $ nf (flip Free.run 0 . computation) n 27 | , bench "Free/lazy" $ nf (flip Free.runLazily 0 . computation) n 28 | , bench "Chruch" $ nf (flip Church.run 0 . computation) n 29 | , bench "Codensity" $ nf (flip Codensity.run 0 . computation) n 30 | , bench "NoRemorse" $ nf (flip NoRemorse.run 0 . computation) n 31 | , bench "Freer" $ nf (flip Freer.run 0 . computation) n 32 | , bench "MTL" $ nf (flip MTL.runState 0 . mtlComputation) n 33 | ] 34 | 35 | main :: IO () 36 | main = defaultMain 37 | [ bgroup "Right-assoc" $ benchmarks computation mtlComputation n 38 | , bgroup "Left-assoc" $ benchmarks computation2 mtlComputation2 n 39 | ] 40 | -------------------------------------------------------------------------------- /Data/RTQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, ViewPatterns, TypeOperators #-} 2 | 3 | module Data.RTQueue where 4 | 5 | {- Queue with worst case O(1) operations! 6 | Based on Okasaki Simple and Efficient Purely Functional Queues and Deques 7 | Journal of Functional Programming 8 | -} 9 | 10 | import Data.TConsList 11 | import Data.TSnocList 12 | import Data.Interface.TSequence 13 | 14 | revAppend l r = rotate l r CNil 15 | -- precondtion : |a| = |f| - (|r| - 1) 16 | -- postcondition: |a| = |f| - |r| 17 | rotate :: TConsList tc a b -> TSnocList tc b c -> TConsList tc c d -> TConsList tc a d 18 | rotate CNil (SNil `Snoc` y) r = y `Cons` r 19 | rotate (x `Cons` f) (r `Snoc` y) a = x `Cons` rotate f r (y `Cons` a) 20 | rotate f a r = error "Invariant |a| = |f| - (|r| - 1) broken" 21 | 22 | data RTQueue tc a b where 23 | RQ :: !(TConsList tc a b) -> !(TSnocList tc b c) -> !(TConsList tc x b) -> RTQueue tc a c 24 | 25 | queue :: TConsList tc a b -> TSnocList tc b c -> TConsList tc x b -> RTQueue tc a c 26 | queue f r CNil = let f' = revAppend f r 27 | in RQ f' SNil f' 28 | queue f r (h `Cons` t) = RQ f r t 29 | 30 | instance TSequence RTQueue where 31 | tempty = RQ CNil SNil CNil 32 | tsingleton x = let c = tsingleton x in queue c SNil c 33 | (RQ f r a) |> x = queue f (r `Snoc` x) a 34 | 35 | tviewl (RQ CNil SNil CNil) = TEmptyL 36 | tviewl (RQ (h `Cons` t) f a) = h :| queue t f a 37 | 38 | -------------------------------------------------------------------------------- /NoRemorse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, GADTs, 2 | FlexibleInstances, MultiParamTypeClasses 3 | #-} 4 | 5 | module NoRemorse where 6 | 7 | import Data.Interface.TSequence 8 | import Data.FastTCQueue 9 | import Control.Monad 10 | import Base 11 | type TCQueue = FastTCQueue 12 | 13 | newtype FC f a b = FC (a -> FreeMonad f b) 14 | type FMExp f a b = TCQueue (FC f) a b 15 | data FreeMonad f a = 16 | forall x. FM (FreeMonadView f x) (FMExp f x a) 17 | data FreeMonadView f a = Pure a 18 | | Impure (f (FreeMonad f a)) 19 | fromView x = FM x tempty 20 | 21 | toView :: Functor f => FreeMonad f a -> FreeMonadView f a 22 | toView (FM h t) = case h of 23 | Pure x -> 24 | case tviewl t of 25 | TEmptyL -> Pure x 26 | FC hc :| tc -> toView (hc x >>>= tc) 27 | Impure f -> Impure (fmap (>>>= t) f) 28 | where (>>>=) :: FreeMonad f a -> FMExp f a b -> FreeMonad f b 29 | (FM h t) >>>= r = FM h (t >< r) 30 | 31 | instance Functor (FreeMonad f) where 32 | fmap = liftM 33 | instance Applicative (FreeMonad f) where 34 | pure = return 35 | (<*>) = ap 36 | instance Monad (FreeMonad f) where 37 | return = fromView . Pure 38 | (FM m r) >>= f = FM m (r >< tsingleton (FC f)) 39 | 40 | instance MonadFree f (FreeMonad f) where 41 | wrap a = fromView (Impure a) 42 | 43 | run :: FreeMonad F a -> Int -> (Int, a) 44 | run a s = 45 | case toView a of 46 | Pure x -> (s, x) 47 | Impure (F a) -> 48 | case a s of 49 | (s', a') -> run a' s' 50 | -------------------------------------------------------------------------------- /Data/Interface/TSequence.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs,TypeSynonymInstances,FlexibleInstances #-} 2 | 3 | module Data.Interface.TSequence(TSequence(..), TViewL(..), TViewR(..)) where 4 | 5 | import Data.Interface.Sequence 6 | import Control.Category 7 | import Prelude hiding ((.),id) 8 | infixr 5 <| 9 | infixl 5 |> 10 | infix 5 >< 11 | class TSequence s where 12 | -- minimal complete def: tempty, tsingleton, (tviewl or tviewr) and (><) or (|>) or (<|) 13 | tempty :: s c x x 14 | tsingleton :: c x y -> s c x y 15 | (><) :: s c x y -> s c y z -> s c x z 16 | tviewl :: s c x y -> TViewL s c x y 17 | tviewr :: s c x y -> TViewR s c x y 18 | (|>) :: s c x y -> c y z -> s c x z 19 | (<|) :: c x y -> s c y z -> s c x z 20 | 21 | l |> r = l >< tsingleton r 22 | l <| r = tsingleton l >< r 23 | l >< r = case tviewl l of 24 | TEmptyL -> r 25 | h :| t -> h <| (t >< r) 26 | 27 | tviewl q = case tviewr q of 28 | TEmptyR -> TEmptyL 29 | p :|< l -> case tviewl p of 30 | TEmptyL -> l :| tempty 31 | h :| t -> h :| (t |> l) 32 | 33 | tviewr q = case tviewl q of 34 | TEmptyL -> TEmptyR 35 | h :| t -> case tviewr t of 36 | TEmptyR -> tempty :|< h 37 | p :|< l -> (h <| p) :|< l 38 | 39 | 40 | data TViewL s c x y where 41 | TEmptyL :: TViewL s c x x 42 | (:|) :: c x y -> s c y z -> TViewL s c x z 43 | 44 | data TViewR s c x y where 45 | TEmptyR :: TViewR s c x x 46 | (:|<) :: s c x y -> c y z -> TViewR s c x z 47 | 48 | 49 | 50 | instance TSequence s => Category (s c) where 51 | id = tempty 52 | (.) = flip (><) -- not (><): type error 53 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This repository exists for archival purposes only. I am not interested in 2 | maintaining it. **Please do not open pull requests.** 3 | 4 | * * * 5 | 6 | A benchmark comparing the performance of different free monad implementations. 7 | 8 | The benchmark simulates the state monad using various flavors of free monads, 9 | and compares them to the standard State monad from transformers. 10 | 11 | See also: [Two failed attempts at extensible effects](https://ro-che.info/articles/2014-06-14-extensible-effects-failed). 12 | 13 | Note that this is *not* a comparison of extensible effects system. Free 14 | monads *may* be used to implement an extensible effect system. 15 | Under most implementations, extensible effects introduce an even bigger overhead 16 | (dispatching upon the effect requests); this overhead is not present in this 17 | benchmark. However, if your free monad is slow (which it probably is, as this 18 | benchmark shows), any effect system based on it won't be fast. 19 | 20 | ## Running the benchmark 21 | 22 | stack build && stack exec freemonad-benchmark -- -o results.html 23 | 24 | ## Results 25 | 26 | [Criterion report](https://rawgit.com/feuerbach/freemonad-benchmark/master/results.html) 27 | 28 | ## Implementations 29 | 30 | 1. **Free** 31 | 32 | ``` haskell 33 | data Free f a = Pure a | Free (f (Free f a)) 34 | ``` 35 | 36 | 2. **Free/lazy** 37 | 38 | The same standard Free monad emulating the lazy State monad. 39 | 40 | 3. **Church** 41 | 42 | The Church-encoded free monad: 43 | 44 | ``` haskell 45 | newtype ChurchFree f a = ChurchFree 46 | { runChurchFree :: forall w. (a -> w) -> (f w -> w) -> w } 47 | ``` 48 | 49 | 4. **Codensity** 50 | 51 | The standard Free monad, codensity-transformed. See 52 | [Asymptotic Improvement of Computations over Free Monads](http://www.janis-voigtlaender.eu/papers/AsymptoticImprovementOfComputationsOverFreeMonads.pdf). 53 | 54 | 5. **NoRemorse** 55 | 56 | A free monad from [Reflection without Remorse](http://okmij.org/ftp/Haskell/zseq.pdf). 57 | 58 | 6. **Freer** 59 | 60 | The Freer monad from [Freer Monads, More Extensible 61 | Effects](http://okmij.org/ftp/Haskell/extensible/more.pdf), aka the 62 | [operational]() monad. 63 | 64 | ## Workloads 65 | 66 | For every implementation, there are two tests, for left- and right-associated 67 | chains of binds. Some free monads (e.g. the standard one) suffer from quadratic 68 | complexity on left-associated chains of binds. 69 | --------------------------------------------------------------------------------