Merge pull request #41 from ethul/topic/benchotron

Topic/benchotron

Author: garyb

.gitignore

@@ -1,3 +1,4 @@
+.DS_Store
 /.*
 !/.gitignore
 !/.travis.yml

README.md

@@ -4,26 +4,43 @@
 [![Build Status](https://travis-ci.org/purescript/purescript-free.svg?branch=master)](https://travis-ci.org/purescript/purescript-free)
 [![Dependency Status](https://www.versioneye.com/user/projects/55848c7336386100150003e9/badge.svg?style=flat)](https://www.versioneye.com/user/projects/55848c7336386100150003e9)
 
-Free monads, Cofree comonads, Yoneda and Coyoneda functors, and the Trampoline monad.
+Free monad, Cofree comonad, Yoneda and Coyoneda functors, and the Trampoline monad implementations for PureScript.
+
+The Free monad implementation is represented using a sequential data structure.
+
+See the following reference for further information.
+* [Relection without Remorse](http://okmij.org/ftp/Haskell/zseq.pdf) (Ploeg and Kiselyov 2014)
 
 ## Installation
 
 ```
 bower install purescript-free
 ```
 
-## Module documentation
+## Documentation
+
+* [Control.Monad.Free](docs/Control/Monad/Free.md)
+* [Control.Comonad.Cofree](docs/Control/Comonad/Cofree.md)
+* [Data.Yoneda](docs/Data/Yoneda.md)
+* [Data.Coyoneda](docs/Data/Coyoneda.md)
+* [Control.Monad.Trampoline](docs/Control/Monad/Trampoline.md)
+
+## Benchmarks
 
-### Free/Cofree
+The following benchmarks compare the current implementation with the implementation at `v0.6.1` (purescript/purescript-free@0df59c5d459fed983131856886fc3a4b43234f1f), which used the `Gosub` technique to defer monadic binds.
 
-- [Control.Monad.Free](docs/Control/Monad/Free.md)
-- [Control.Comonad.Cofree](docs/Control/Comonad/Cofree.md)
+The benchmarks may be run as follows. Note that `pulp` must be on your path.
+
+```bash
+npm install
+
+npm run-script benchmark
+```
 
-### Yoneda/Coyoneda
+![left-bind-small](benchmark/left-bind-small.png)
 
-- [Data.Yoneda](docs/Data/Yoneda.md)
-- [Data.Coyoneda](docs/Data/Coyoneda.md)
+![left-bind-large](benchmark/left-bind-large.png)
 
-### Trampoline monad
+![right-bind-small](benchmark/right-bind-small.png)
 
-- [Control.Monad.Trampoline](docs/Control/Monad/Trampoline.md)
+![right-bind-large](benchmark/right-bind-large.png)

benchmark/Benchmark/Free0df59c5.purs

@@ -0,0 +1,186 @@
+module Benchmark.Free0df59c5
+  ( Free(..), GosubF()
+  , FreeC(..)
+  , MonadFree, wrap
+  , Natural()
+  , liftF, liftFI, liftFC, liftFCI
+  , pureF, pureFC
+  , mapF, mapFC
+  , bindF, bindFC
+  , injF, injFC
+  , runFree
+  , runFreeM
+  , runFreeC
+  , runFreeCM
+  ) where
+
+import Prelude
+
+import Data.Exists
+
+import Control.Monad.Trans
+import Control.Monad.Eff
+import Control.Monad.Rec.Class
+
+import Data.Identity
+import Data.Coyoneda
+import Data.Either
+import Data.Function
+import Data.Maybe
+import Data.Inject (Inject, inj)
+
+type Natural f g = forall a. f a -> g a
+
+newtype GosubF f a i = GosubF { a :: Unit -> Free f i, f :: i -> Free f a }
+
+gosub :: forall f a i. (Unit -> Free f i) -> (i -> Free f a) -> Free f a
+gosub a f = Gosub $ mkExists $ GosubF { a: a, f: f}
+
+-- | The free `Monad` for a `Functor`.
+-- |
+-- | The implementation defers the evaluation of monadic binds so that it
+-- | is safe to use monadic tail recursion, for example.
+data Free f a = Pure a
+              | Free (f (Free f a))
+              | Gosub (Exists (GosubF f a))
+
+-- | The free `Monad` for an arbitrary type constructor.
+type FreeC f = Free (Coyoneda f)
+
+-- | The `MonadFree` class provides the `wrap` function, which lifts
+-- | actions described by a generating functor into a monad.
+-- |
+-- | The canonical instance of `MonadFree f` is `Free f`.
+class MonadFree f m where
+  wrap :: forall a. f (m a) -> m a
+
+instance functorFree :: (Functor f) => Functor (Free f) where
+  map f (Pure a) = Pure (f a)
+  map f g = liftA1 f g
+
+instance applyFree :: (Functor f) => Apply (Free f) where
+  apply = ap
+
+instance applicativeFree :: (Functor f) => Applicative (Free f) where
+  pure = Pure
+
+instance bindFree :: (Functor f) => Bind (Free f) where
+  bind (Gosub g) k = runExists (\(GosubF v) -> gosub v.a (\x -> gosub (\unit -> v.f x) k)) g
+  bind a         k = gosub (\unit -> a) k
+
+instance monadFree :: (Functor f) => Monad (Free f)
+
+instance monadTransFree :: MonadTrans Free where
+  lift f = Free $ do
+    a <- f
+    return (Pure a)
+
+instance monadFreeFree :: (Functor f) => MonadFree f (Free f) where
+  wrap = Free
+
+instance monadRecFree :: (Functor f) => MonadRec (Free f) where
+  tailRecM f u = f u >>= \o -> case o of
+                                    Left  a -> tailRecM f a
+                                    Right b -> pure b
+
+-- | Lift an action described by the generating functor `f` into the monad `m`
+-- | (usually `Free f`).
+liftF :: forall f m a. (Functor f, Monad m, MonadFree f m) => f a -> m a
+liftF = wrap <<< map pure
+
+-- | Lift an action described by the generating type constructor `f` into
+-- | `Free g` using `Inject` to go from `f` to `g`.
+liftFI :: forall f g a. (Inject f g, Functor g) => f a -> Free g a
+liftFI fa = liftF (inj fa :: g a)
+
+-- | Lift an action described by the generating type constructor `f` into the monad
+-- | `FreeC f`.
+liftFC :: forall f a. f a -> FreeC f a
+liftFC = liftF <<< liftCoyoneda
+
+-- | Lift an action described by the generating type constructor `f` into
+-- | `FreeC g` using `Inject` to go from `f` to `g`.
+liftFCI :: forall f g a. (Inject f g) => f a -> FreeC g a
+liftFCI fa = liftFC (inj fa :: g a)
+
+-- | An implementation of `pure` for the `Free` monad.
+pureF :: forall f a. (Applicative f) => a -> Free f a
+pureF = Free <<< pure <<< Pure
+
+-- | An implementation of `pure` for the `FreeC` monad.
+pureFC :: forall f a. (Applicative f) => a -> FreeC f a
+pureFC = liftFC <<< pure
+
+-- | Use a natural transformation to change the generating functor of a `Free` monad.
+mapF :: forall f g a. (Functor f, Functor g) => Natural f g -> Free f a -> Free g a
+mapF t fa = either (\s -> Free <<< t $ mapF t <$> s) Pure (resume fa)
+
+-- | Use a natural transformation to change the generating type constructor of
+-- | a `FreeC` monad to another functor.
+mapFC :: forall f g a. (Functor g) => Natural f g -> FreeC f a -> Free g a
+mapFC t = mapF (liftCoyonedaTF t)
+
+-- | Use a natural transformation to interpret one `Free` monad as another.
+bindF :: forall f g a. (Functor f, Functor g) => Free f a -> Natural f (Free g) -> Free g a
+bindF fa t = either (\m -> t m >>= \fa' -> bindF fa' t) Pure (resume fa)
+
+-- | Use a natural transformation to interpret a `FreeC` monad as a different
+-- | `Free` monad.
+bindFC :: forall f g a. (Functor g) => FreeC f a -> Natural f (Free g) -> Free g a
+bindFC fa t = bindF fa (liftCoyonedaTF t)
+
+-- | Embed computations in one `Free` monad as computations in the `Free` monad for
+-- | a coproduct type constructor.
+-- |
+-- | This construction allows us to write computations which are polymorphic in the
+-- | particular `Free` monad we use, allowing us to extend the functionality of
+-- | our monad later.
+injF :: forall f g a. (Functor f, Functor g, Inject f g) => Free f a -> Free g a
+injF = mapF inj
+
+-- | Embed computations in one `FreeC` monad as computations in the `FreeC` monad for
+-- | a coproduct type constructor.
+-- |
+-- | This construction allows us to write computations which are polymorphic in the
+-- | particular `Free` monad we use, allowing us to extend the functionality of
+-- | our monad later.
+injFC :: forall f g a. (Inject f g) => FreeC f a -> FreeC g a
+injFC = mapF (liftCoyonedaT inj)
+
+resume :: forall f a. (Functor f) => Free f a -> Either (f (Free f a)) a
+resume f = case f of
+  Pure x -> Right x
+  Free x -> Left x
+  g -> case resumeGosub g of
+    Left l -> Left l
+    Right r -> resume r
+  where
+  resumeGosub :: Free f a -> Either (f (Free f a)) (Free f a)
+  resumeGosub (Gosub g) =
+    runExists (\(GosubF v) -> case v.a unit of
+                                   Pure a -> Right (v.f a)
+                                   Free t -> Left ((\h -> h >>= v.f) <$> t)
+                                   Gosub h -> runExists (\(GosubF w) -> Right (w.a unit >>= (\z -> w.f z >>= v.f))) h) g
+
+-- | `runFree` runs a computation of type `Free f a`, using a function which unwraps a single layer of
+-- | the functor `f` at a time.
+runFree :: forall f a. (Functor f) => (f (Free f a) -> Free f a) -> Free f a -> a
+runFree fn = runIdentity <<< runFreeM (Identity <<< fn)
+
+-- | `runFreeM` runs a compuation of type `Free f a` in any `Monad` which supports tail recursion.
+-- | See the `MonadRec` type class for more details.
+runFreeM :: forall f m a. (Functor f, MonadRec m) => (f (Free f a) -> m (Free f a)) -> Free f a -> m a
+runFreeM fn = tailRecM \f ->
+  case resume f of
+    Left fs -> Left <$> fn fs
+    Right a -> return (Right a)
+
+-- | `runFreeC` is the equivalent of `runFree` for type constructors transformed with `Coyoneda`,
+-- | hence we have no requirement that `f` be a `Functor`.
+runFreeC :: forall f a. (forall a. f a -> a) -> FreeC f a -> a
+runFreeC nat = runIdentity <<< runFreeCM (Identity <<< nat)
+
+-- | `runFreeCM` is the equivalent of `runFreeM` for type constructors transformed with `Coyoneda`,
+-- | hence we have no requirement that `f` be a `Functor`.
+runFreeCM :: forall f m a. (MonadRec m) => Natural f m -> FreeC f a -> m a
+runFreeCM nat = runFreeM (liftCoyonedaTF nat)

benchmark/Benchmark/Main.purs

@@ -0,0 +1,135 @@
+module Benchmark.Main (main) where
+
+import Prelude
+
+import Control.Monad.Eff
+import Control.Monad.Free
+import Control.Monad.Trampoline
+
+import Data.Array
+import Data.Foldable
+
+import Benchotron.Core
+import Benchotron.UI.Console
+
+import Test.QuickCheck.Gen (vectorOf)
+
+import qualified Benchmark.Trampoline0df59c5 as T
+
+leftBindSmallBenchmark :: Benchmark
+leftBindSmallBenchmark = mkBenchmark
+  { slug: "left-bind-small"
+  , title: "Left associated binds (small - " ++ show inputsPerSize ++ " inputs per size)"
+  , sizes: [1, 2, 3, 4, 5, 10, 20, 30, 40, 50, 100, 250, 500, 1000]
+  , sizeInterpretation: "Number of binds"
+  , inputsPerSize: inputsPerSize
+  , gen: \n -> vectorOf n (pure 0.0)
+  , functions: [ benchFn "Free" (runTrampoline <<< binds)
+               , benchFn "Free v0.6.1" (T.runTrampoline <<< bindsT)
+               ]
+  }
+  where
+  inputsPerSize :: Int
+  inputsPerSize = 100
+
+  binds :: Array Number -> Trampoline Number
+  binds as = foldl (\b a -> b >>= const (gen a)) (gen 0.0) as
+
+  gen :: forall a. a -> Trampoline a
+  gen = suspend <<< done
+
+  bindsT :: Array Number -> T.Trampoline Number
+  bindsT as = foldl (\b a -> b >>= const (genT a)) (genT 0.0) as
+
+  genT :: forall a. a -> T.Trampoline a
+  genT = T.suspend <<< T.done
+
+rightBindSmallBenchmark :: Benchmark
+rightBindSmallBenchmark = mkBenchmark
+  { slug: "right-bind-small"
+  , title: "Right associated binds (small - " ++ show inputsPerSize ++ " inputs per size)"
+  , sizes: [1, 2, 3, 4, 5, 10, 20, 30, 40, 50, 100, 250, 500, 1000]
+  , sizeInterpretation: "Number of binds"
+  , inputsPerSize: inputsPerSize
+  , gen: \n -> vectorOf n (pure 0.0)
+  , functions: [ benchFn "Free" (runTrampoline <<< binds)
+               , benchFn "Free v0.6.1" (T.runTrampoline <<< bindsT)
+               ]
+  }
+  where
+  inputsPerSize :: Int
+  inputsPerSize = 100
+
+  binds :: Array Number -> Trampoline Number
+  binds as = foldl (\b a -> gen a >>= const b) (gen 0.0) as
+
+  gen :: forall a. a -> Trampoline a
+  gen = suspend <<< done
+
+  bindsT :: Array Number -> T.Trampoline Number
+  bindsT as = foldl (\b a -> genT a >>= const b) (genT 0.0) as
+
+  genT :: forall a. a -> T.Trampoline a
+  genT = T.suspend <<< T.done
+
+leftBindLargeBenchmark :: Benchmark
+leftBindLargeBenchmark = mkBenchmark
+  { slug: "left-bind-large"
+  , title: "Left associated binds (large - " ++ show inputsPerSize ++ " input per size)"
+  , sizes: [1, 5, 10, 15, 20, 25, 30 ] <#> (* 100000)
+  , sizeInterpretation: "Number of binds"
+  , inputsPerSize: inputsPerSize
+  , gen: \n -> vectorOf n (pure 0.0)
+  , functions: [ benchFn "Free" (runTrampoline <<< binds)
+               , benchFn "Free v0.6.1" (T.runTrampoline <<< bindsT)
+               ]
+  }
+  where
+  inputsPerSize :: Int
+  inputsPerSize = 1
+
+  binds :: Array Number -> Trampoline Number
+  binds as = foldl (\b a -> b >>= const (gen a)) (gen 0.0) as
+
+  gen :: forall a. a -> Trampoline a
+  gen = suspend <<< done
+
+  bindsT :: Array Number -> T.Trampoline Number
+  bindsT as = foldl (\b a -> b >>= const (genT a)) (genT 0.0) as
+
+  genT :: forall a. a -> T.Trampoline a
+  genT = T.suspend <<< T.done
+
+rightBindLargeBenchmark :: Benchmark
+rightBindLargeBenchmark = mkBenchmark
+  { slug: "right-bind-large"
+  , title: "Right associated binds (large - " ++ show inputsPerSize ++ " input per size)"
+  , sizes: [1, 5, 10, 15, 20, 25, 30 ] <#> (* 100000)
+  , sizeInterpretation: "Number of binds"
+  , inputsPerSize: inputsPerSize
+  , gen: \n -> vectorOf n (pure 0.0)
+  , functions: [ benchFn "Free" (runTrampoline <<< binds)
+               , benchFn "Free v0.6.1" (T.runTrampoline <<< bindsT)
+               ]
+  }
+  where
+  inputsPerSize :: Int
+  inputsPerSize = 1
+
+  binds :: Array Number -> Trampoline Number
+  binds as = foldl (\b a -> gen a >>= const b) (gen 0.0) as
+
+  gen :: forall a. a -> Trampoline a
+  gen = suspend <<< done
+
+  bindsT :: Array Number -> T.Trampoline Number
+  bindsT as = foldl (\b a -> genT a >>= const b) (genT 0.0) as
+
+  genT :: forall a. a -> T.Trampoline a
+  genT = T.suspend <<< T.done
+
+main = runSuite [ leftBindSmallBenchmark
+                , rightBindSmallBenchmark
+                , leftBindLargeBenchmark
+                , rightBindLargeBenchmark
+                ]