├── .gitignore ├── .stylish-haskell.yaml ├── .travis.yml ├── LICENSE ├── Setup.hs ├── examples └── Main.hs ├── free-vl.cabal ├── src └── Control │ └── Monad │ └── Free │ ├── VanLaarhoven.hs │ └── VanLaarhovenE.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/* 2 | .stack-work/* 3 | *.o 4 | *.hi 5 | *.dyn_o 6 | *.dyn_hi 7 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Import cleanup 19 | - imports: 20 | # There are different ways we can align names and lists. 21 | # 22 | # - global: Align the import names and import list throughout the entire 23 | # file. 24 | # 25 | # - file: Like global, but don't add padding when there are no qualified 26 | # imports in the file. 27 | # 28 | # - group: Only align the imports per group (a group is formed by adjacent 29 | # import lines). 30 | # 31 | # - none: Do not perform any alignment. 32 | # 33 | # Default: global. 34 | align: global 35 | 36 | # Language pragmas 37 | - language_pragmas: 38 | # We can generate different styles of language pragma lists. 39 | # 40 | # - vertical: Vertical-spaced language pragmas, one per line. 41 | # 42 | # - compact: A more compact style. 43 | # 44 | # - compact_line: Similar to compact, but wrap each line with 45 | # `{-#LANGUAGE #-}'. 46 | # 47 | # Default: vertical. 48 | style: vertical 49 | 50 | # stylish-haskell can detect redundancy of some language pragmas. If this 51 | # is set to true, it will remove those redundant pragmas. Default: true. 52 | remove_redundant: true 53 | 54 | # Align the types in record declarations 55 | - records: {} 56 | 57 | # Replace tabs by spaces. This is disabled by default. 58 | # - tabs: 59 | # # Number of spaces to use for each tab. Default: 8, as specified by the 60 | # # Haskell report. 61 | # spaces: 8 62 | 63 | # Remove trailing whitespace 64 | - trailing_whitespace: {} 65 | 66 | # A common setting is the number of columns (parts of) code will be wrapped 67 | # to. Different steps take this into account. Default: 80. 68 | columns: 80 69 | 70 | # Sometimes, language extensions are specified in a cabal file or from the 71 | # command line instead of using language pragmas in the file. stylish-haskell 72 | # needs to be aware of these, so it can parse the file correctly. 73 | # 74 | # No language extensions are enabled by default. 75 | language_extensions: 76 | - TemplateHaskell 77 | - QuasiQuotes 78 | - CPP 79 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # GHC depends on GMP. You can add other dependencies here as well. 8 | addons: 9 | apt: 10 | packages: 11 | - libgmp-dev 12 | 13 | # The different configurations we want to test. You could also do things like 14 | # change flags or use --stack-yaml to point to a different file. 15 | env: 16 | - ARGS="" 17 | - ARGS="--resolver lts-3" 18 | - ARGS="--resolver lts" 19 | - ARGS="--resolver nightly" 20 | 21 | before_install: 22 | # Download and unpack the stack executable 23 | - mkdir -p ~/.local/bin 24 | - export PATH=$HOME/.local/bin:$PATH 25 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 26 | 27 | # This line does all of the work: installs GHC if necessary, build the library, 28 | # executables, and test suites, and runs the test suites. --no-terminal works 29 | # around some quirks in Travis's terminal implementation. 30 | script: 31 | - stack $ARGS --no-terminal --install-ghc test --haddock 32 | - stack build 33 | - stack ghc -- --make examples/Main.hs -o /dev/null 34 | - stack sdist 35 | 36 | # Caching so the next build will be fast too. 37 | cache: 38 | directories: 39 | - $HOME/.stack 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | module Main where 6 | 7 | import Control.Concurrent 8 | 9 | import Control.Monad.Free.VanLaarhovenE 10 | 11 | 12 | main :: IO () 13 | main = iterM ioInterpreter program >> putStrLn "exit!" 14 | 15 | program :: ( HasEffect effects Logging 16 | , HasEffect effects Suspend 17 | , HasEffect effects Http) 18 | => Free effects (Either Int (Response String)) 19 | program = do 20 | logMsg "hold on" 21 | suspend 1000 22 | getHttp "http://example.org" 23 | 24 | 25 | logMsg :: HasEffect effects Logging => String -> Free effects () 26 | logMsg msg = liftF $ \e -> logEff e msg 27 | 28 | 29 | suspend :: HasEffect effects Suspend => Int -> Free effects () 30 | suspend micros = liftF $ \e -> suspendEff e micros 31 | 32 | 33 | getHttp :: HasEffect effects Http => Url -> Free effects (Either Int (Response String)) 34 | getHttp url = liftF $ \e -> getHttpEff e url 35 | 36 | 37 | -- interpret logging actions in IO 38 | logIO :: Logging IO 39 | logIO = Logging { logEff = putStrLn } 40 | 41 | 42 | -- suspend in IO 43 | suspendIO :: Suspend IO 44 | suspendIO = Suspend { suspendEff = threadDelay } 45 | 46 | 47 | httpIO :: Http IO 48 | httpIO = Http { getHttpEff = error "to be implemented" 49 | , postHttpEff = error "to be implemented"} 50 | 51 | -- our effect stack 52 | type MyEffects = ( Http ': Logging ': Suspend ': '[] ) 53 | 54 | 55 | -- our interpreter 56 | ioInterpreter :: Effects MyEffects IO 57 | ioInterpreter = httpIO .:. logIO .:. suspendIO .:. EmptyE 58 | 59 | 60 | -- Http Effect 61 | data Http m = 62 | Http { getHttpEff :: Url -> m (Either Int (Response String)) 63 | , postHttpEff :: Url -> RequestBody -> m (Either Int (Response String)) 64 | } 65 | 66 | 67 | -- Logging Effect 68 | data Logging m = Logging { logEff :: String -> m () } 69 | 70 | 71 | -- suspend effect 72 | data Suspend m = Suspend { suspendEff :: Int -> m () } 73 | 74 | 75 | type Url = String 76 | type RequestBody = String 77 | data Response b =Response { responseBody :: b } 78 | -------------------------------------------------------------------------------- /free-vl.cabal: -------------------------------------------------------------------------------- 1 | name: free-vl 2 | version: 0.1.3 3 | synopsis: van Laarhoven encoded Free Monad with Extensible Effects 4 | description: 5 | The van Laarhoven encoding of Free Monads, both the original and with extensible effects. 6 | . 7 | For more information on the van Laarhoven Free Monads, including examples, 8 | please see the following blog posts: 9 | . 10 | Initial formulation by Russell O'Connor: 11 | . 12 | Adding Extensible Effects by Aaron Levin: 13 | 14 | homepage: http://github.com/aaronlevin/free-vl 15 | license: BSD3 16 | license-file: LICENSE 17 | author: Aaron Levin 18 | maintainer: Aaron Levin 19 | copyright: 2016 Aaron Levin 20 | category: Control, Monads 21 | build-type: Simple 22 | extra-source-files: 23 | test/Spec.hs 24 | examples/Main.hs 25 | cabal-version: >=1.10 26 | 27 | library 28 | hs-source-dirs: src 29 | exposed-modules: Control.Monad.Free.VanLaarhoven 30 | , Control.Monad.Free.VanLaarhovenE 31 | build-depends: base >= 4.7 && < 5 32 | default-language: Haskell2010 33 | default-extensions: CPP 34 | 35 | executable examples 36 | hs-source-dirs: examples 37 | main-is: Main.hs 38 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 39 | build-depends: base 40 | , free-vl 41 | default-language: Haskell2010 42 | 43 | test-suite free-vl-test 44 | type: exitcode-stdio-1.0 45 | hs-source-dirs: test 46 | main-is: Spec.hs 47 | build-depends: base 48 | , free-vl 49 | , tasty 50 | , tasty-hunit 51 | , containers 52 | , mtl 53 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 54 | default-language: Haskell2010 55 | 56 | source-repository head 57 | type: git 58 | location: https://github.com/aaronlevin/free-vl 59 | -------------------------------------------------------------------------------- /src/Control/Monad/Free/VanLaarhoven.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Control.Monad.Free.VanLaarhoven 6 | -- Copyright : (C) 2016 Aaron Levin 7 | -- License : BSD-style (see the file LICENSE) 8 | -- 9 | -- Maintainer : Aaron Levin 10 | -- Stability : provisional 11 | -- Portability : non-portable (rank-2 polymorphism) 12 | -- 13 | -- \"van Laarhoven encoded Free Monad\" 14 | ----------------------------------------------------------------------------- 15 | 16 | module Control.Monad.Free.VanLaarhoven 17 | ( Free(..) 18 | ) where 19 | 20 | import Control.Arrow ((&&&)) 21 | 22 | -- | The van Laarhoven-encoded Free Monad 23 | newtype Free effect a = 24 | Free { runFree :: forall m. Monad m => effect m -> m a } 25 | 26 | instance Functor (Free effect) where 27 | fmap f (Free run) = Free (fmap f . run) 28 | 29 | instance Applicative (Free effect) where 30 | pure a = Free (const (pure a)) 31 | (Free fab) <*> (Free a) = 32 | Free (\e -> fab e <*> a e) 33 | 34 | instance Monad (Free effect) where 35 | (Free run) >>= f = 36 | Free (\e -> run e >>= \a -> runFree (f a) e) 37 | -------------------------------------------------------------------------------- /src/Control/Monad/Free/VanLaarhovenE.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | #if !MIN_VERSION_base(4,8,0) 9 | {-# LANGUAGE OverlappingInstances #-} 10 | #endif 11 | 12 | ----------------------------------------------------------------------------- 13 | -- | 14 | -- Module : Control.Monad.Free.VanLaarhovenE 15 | -- Copyright : (C) 2016 Aaron Levin 16 | -- License : BSD-style (see the file LICENSE) 17 | -- 18 | -- Maintainer : Aaron Levin 19 | -- Stability : provisional 20 | -- Portability : non-portable (rank-2 polymorphism) 21 | -- 22 | -- \"van Laarhoven encoded Free Monad with extensible effects\" 23 | ----------------------------------------------------------------------------- 24 | 25 | module Control.Monad.Free.VanLaarhovenE 26 | ( (.:.) 27 | , Effects (..) 28 | , Free(..) 29 | , HasEffect(..) 30 | , iterM 31 | , liftF 32 | ) where 33 | 34 | import Control.Arrow ((&&&)) 35 | 36 | -- | a customized HList of effects. We need to carry the 'm' param around for 37 | -- type inference. 38 | data Effects a (m :: * -> *) where 39 | EmptyE :: Effects '[] m 40 | ConsE :: effect m -> Effects effects m -> Effects (effect ': effects) m 41 | 42 | -- | Helper combinator for creating values of 'Effects effects m' 43 | (.:.) :: effect m -> Effects effects m -> Effects (effect ': effects) m 44 | effect .:. effects = ConsE effect effects 45 | infixr 4 .:. 46 | 47 | -- | The van Laarhoven-encoded Free Monad with Extensible effects 48 | newtype Free effects a = 49 | Free { runFree :: forall m. Monad m => Effects effects m -> m a } 50 | 51 | instance Functor (Free effect) where 52 | fmap f (Free run) = Free (fmap f . run) 53 | 54 | instance Applicative (Free effect) where 55 | pure a = Free (const (pure a)) 56 | (Free fab) <*> (Free a) = 57 | Free (\e -> fab e <*> a e) 58 | 59 | instance Monad (Free effect) where 60 | (Free run) >>= f = 61 | Free (\e -> run e >>= \a -> runFree (f a) e) 62 | 63 | -- | A class to help us fetch effects from our effect stack. 64 | class HasEffect (effects :: [((* -> *) -> *)]) (effect :: ((* -> *) -> *)) where 65 | getEffect :: Effects effects m -> effect m 66 | 67 | -- | An instance of 'HasEffect' that handles the case where our desired effect 68 | -- type doesn't match the head of the HList. 69 | instance 70 | #if MIN_VERSION_base(4,8,0) 71 | {-# OVERLAPPABLE #-} 72 | #endif 73 | HasEffect effects effect => HasEffect (notIt ': effects) effect where 74 | getEffect (ConsE _ effects) = getEffect effects 75 | 76 | -- | An instance of 'HasEffect' that handles the case where our desired effect 77 | -- type matches the head of the list. We then return that effect. 78 | instance 79 | #if MIN_VERSION_base(4,8,0) 80 | {-# OVERLAPPABLE #-} 81 | #endif 82 | HasEffect (effect ': effects) effect where 83 | getEffect (ConsE effect _) = effect 84 | 85 | -- | A version of lift that can be used with an effect stack. 86 | liftF :: HasEffect effects effect -- constraint that ensures our effect is in the effect stack 87 | => (forall m. effect m -> m a) -- method to pull our operation from our effect 88 | -> Free effects a 89 | liftF getOp = Free (getOp . getEffect) 90 | 91 | -- | Tear down a 'Free' 'Monad' using the supplied effects value. 92 | iterM :: Monad m 93 | => Effects effects m 94 | -> Free effects a 95 | -> m a 96 | iterM phi program = runFree program phi 97 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/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.16 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 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | module Main 7 | ( main 8 | ) where 9 | 10 | import Control.Monad.Writer 11 | import Data.Sequence 12 | import Test.Tasty 13 | import Test.Tasty.HUnit 14 | 15 | import Control.Monad.Free.VanLaarhovenE 16 | 17 | main :: IO () 18 | main = defaultMain testSuite 19 | 20 | 21 | testSuite :: TestTree 22 | testSuite = testGroup "free-vl" [ 23 | testCase "example usage" $ do 24 | let res = execWriter $ iterM interpreter $ do 25 | logDebug "Hey a debug" 26 | n <- randomNumber 27 | logInfo ("Got a random number " <> show n) 28 | res @?= fromList [ (Debug, "Hey a debug") 29 | , (Info, "Got a random number 42") 30 | ] 31 | ] 32 | 33 | 34 | type MyEffects = Logging ': Random ': '[] 35 | 36 | 37 | data LogLevel = Info 38 | | Debug deriving (Show, Eq) 39 | 40 | 41 | data Logging m = Logging { 42 | logMsg :: LogLevel -> String -> m () 43 | } 44 | 45 | 46 | data Random m = Random { 47 | rng :: m Int 48 | } 49 | 50 | 51 | logDebug :: HasEffect eff Logging => String -> Free eff () 52 | logDebug msg = liftF $ \Logging {..} -> logMsg Debug msg 53 | 54 | 55 | logInfo :: HasEffect eff Logging => String -> Free eff () 56 | logInfo msg = liftF $ \Logging {..} -> logMsg Info msg 57 | 58 | 59 | randomNumber :: HasEffect eff Random => Free eff Int 60 | randomNumber = liftF $ \Random {..} -> rng 61 | 62 | 63 | interpreter :: Effects MyEffects (Writer (Seq (LogLevel, String))) 64 | interpreter = fakeLogger .:. fakeRNG .:. EmptyE 65 | 66 | 67 | fakeLogger :: Logging (Writer (Seq (LogLevel, String))) 68 | fakeLogger = Logging (\lvl msg -> tell (singleton (lvl, msg))) 69 | 70 | 71 | fakeRNG :: Monad m => Random m 72 | fakeRNG = Random (return 42) 73 | --------------------------------------------------------------------------------