taktinc / freer

Freer: Extensible Effects with Freer Monads

freer	0.2.4.1
Maintainer	Allele Dev ([email protected])
Funding	$0 USD
Copyright	Copyright (C) 2017 Allele Dev
License	BSD3

Freer is an implementation of "Freer Monads, More Extensible Effects". Much of the implementation is a repackaging and cleaning up of the reference materials provided here.

Features

The key features of Freer are:

• An efficient effect system for Haskell as a library
• Implementations for several common Haskell monad instances:
  • Reader
  • Writer
  • State
  • StateRW: State in terms of Reader/Writer
  • Trace
  • Exception
• Core components for defining your own Effects

Example: Teletype DSL

Here's what using Freer looks like:

{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
module Teletype where

import Eff
import Eff.Internal
import System.Exit hiding (ExitSuccess)

--------------------------------------------------------------------------------
                          -- Effect Model --
--------------------------------------------------------------------------------
data Teletype s where
  PutStrLn    :: String -> Teletype ()
  GetLine     :: Teletype String
  ExitSuccess :: Teletype ()

putStrLn' :: Member Teletype r => String -> Eff r ()
putStrLn' = send . PutStrLn

getLine'  :: Member Teletype r => Eff r String
getLine' = send GetLine

exitSuccess' :: Member Teletype r => Eff r ()
exitSuccess' = send ExitSuccess

--------------------------------------------------------------------------------
                     -- Effectful Interpreter --
--------------------------------------------------------------------------------
runTeletype :: Eff '[Teletype] w -> IO w
runTeletype (Val x) = return x
runTeletype (E u q) = case extract u of
              (PutStrLn msg) -> putStrLn msg  >> runTeletype (qApp q ())
              GetLine        -> getLine      >>= \s -> runTeletype (qApp q s)
              ExitSuccess    -> exitSuccess

--------------------------------------------------------------------------------
                        -- Pure Interpreter --
--------------------------------------------------------------------------------
runTeletypePure :: [String] -> Eff '[Teletype] w -> [String]
runTeletypePure inputs req =
  reverse . snd $ run (handleRelayS (inputs, []) (\s _ -> pure s) go req)
  where
    go :: ([String], [String])
       -> Teletype 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.

Be sure to review the included code of conduct. This project adheres to the Contributor's Covenant. By participating in this project you agree to abide by its terms.

This project is not currently actively maintained.

Developer Setup

The easiest way to start contributing is to install stack. stack can install GHC/Haskell for you, and automates common developer tasks.

The key commands are:

• stack setup : install GHC
• stack build
• stack clean
• stack haddock : builds documentation
• stack test
• stack bench
• stack ghci : start a REPL instance

Licensing

This project is distrubted under a BSD3 license. See the included LICENSE file for more details.

Acknowledgements

This package would not be possible without the paper and the reference implementation. In particular:

• Data.Open.Union maps to OpenUnion41.hs
• Data.FTCQueue maps to FTCQueue1
• Eff* maps to Union1.hs

There will be deviations from the source.

freer's Issues

Un-TH-able gadt?

data A a where
  A :: A a
  B :: A (Just s)

makeFreer ''A

both of these appear to break the template haskell generation

How to implement mutually recursive effects?

I would like to implement 2 effects, say A and B, which would be calling each other. This lead me to the following code which I don't find very satisfactory:

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}

module Symbiont.TransactionEngine.Circular where

import           Data.Text    (length)
import           Eff
import           Eff.Internal
import           Protolude    hiding (length)

data A a where
  F1 :: A Text


data B a where
  G1 :: B Text

data C a where
  C1 :: C ()

c1 :: (Member C r) => Eff r ()
c1 = send C1

f1 :: (Member A r) => Eff r Text
f1 = send F1

g1 :: (Member B r) => Eff r Text
g1 = send G1

printText :: (Member IO r) => Text -> Eff r ()
printText = send @IO . putStrLn

getText ::  (Member IO r) => Eff r Text
getText = send getLine

runAB :: (Member A r, Member B r, Member IO r) => Eff r a -> Eff r a
runAB = runB . runA

runA :: forall a r . (Member A r, Member B r, Member IO r)
     => Eff r a -> Eff r a
runA = interpose pure eval
  where
    eval :: forall b v . A b -> Arr r b v -> Eff r v
    eval F1 k = (do
      t <- getText
      printText $ "f1 " <> t
      g1) >>= k


runB :: forall a r . (Member A r, Member B r, Member IO r)
     => Eff r a -> Eff r a
runB = interpose pure eval
  where
    eval :: forall b v . B b -> Arr r b v -> Eff r v
    eval G1 k = (do
      t <- getText
      printText $ "g1 " <> t
      f1) >>= k

runB' :: forall a r . (Member IO r) =>
         Eff (B ': r) a -> Eff r a
runB' = handleRelay pure eval
  where
    eval :: forall b v . B b -> Arr r b v -> Eff r v
    eval G1     k  = printText "B'" >> k "foo"


runA' :: forall a r . (Member IO r) =>
         Eff (A ': r) a -> Eff r a
runA' = handleRelay pure eval
  where
    eval :: forall b v . A b -> Arr r b v -> Eff r v
    eval F1     k  = printText "A'" >> k "foo"

runCirc :: Eff '[B, A, IO] a -> IO a
runCirc = runM . runA' . runB' . runAB

main = forever $ runCirc f1

In particular, I don't like having to define runA' and runB' nor having to use forever. It seems to me I should be able to tie the knot of a recursive implementation with runA and runB but it keeps eluding me.

Release this version at hackage

As this repository extended the original one, how about releasing it at hackage?

https://hackage.haskell.org/package/freer