Merge branch 'master' into 'master'

Miscellany

I can split these commits out into separate merge requests if you'd prefer.

See merge request !11

README.md

@@ -57,11 +57,10 @@ exitSuccess' = send ExitSuccess
 --------------------------------------------------------------------------------
 runTeletype :: Eff '[Teletype] w -> IO w
 runTeletype (Val x) = return x
-runTeletype (E u q) = case decomp u of
-              Right (PutStrLn msg) -> putStrLn msg  >> runTeletype (qApp q ())
-              Right GetLine        -> getLine      >>= \s -> runTeletype (qApp q s)
-              Right ExitSuccess    -> exitSuccess
-              Left  _              -> error "This cannot happen"
+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 --

examples/src/Main.hs

@@ -1,18 +1,22 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Main where
 
 import Control.Monad.Freer
 import Teletype
 
-runner :: Eff '[Teletype] ()
+runner :: (Member Teletype r) => Eff r ()
 runner = do
   x <- getLine'
+  _ <- getLine'
+  putStrLn' x
+  z <- getLine'
+  putStrLn' z
+  putStrLn' x
   putStrLn' x
-  y <- getLine'
-  putStrLn' y
 
 main :: IO ()
 main = do
-  let xs = runTeletypePure ["cat", "fish"] runner
+  let xs = runTeletypePure ["cat", "fish", "dog", "bird"] runner
   print xs
   runTeletype runner

examples/src/Teletype.hs

@@ -5,7 +5,6 @@
 module Teletype where
 
 import Control.Monad.Freer
-import Control.Monad.Freer.Internal
 import System.Exit hiding (ExitSuccess)
 
 --------------------------------------------------------------------------------
@@ -28,24 +27,27 @@ exitSuccess' = send ExitSuccess
 --------------------------------------------------------------------------------
                      -- Effectful Interpreter --
 --------------------------------------------------------------------------------
-runTeletype :: Eff '[Teletype] w -> IO w
-runTeletype (Val x) = return x
-runTeletype (E u q) = case decomp u of
-              Right (PutStrLn msg) -> putStrLn msg  >> runTeletype (qApp q ())
-              Right GetLine        -> getLine      >>= \s -> runTeletype (qApp q s)
-              Right ExitSuccess    -> exitSuccess
-              Left  _              -> error "This cannot happen"
+runTeletype :: Eff '[Teletype, IO] w -> IO w
+runTeletype req = runM (handleRelay pure go req)
+  where
+   go :: Teletype 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 --
 --------------------------------------------------------------------------------
 runTeletypePure :: [String] -> Eff '[Teletype] w -> [String]
-runTeletypePure inputs req = reverse (go inputs req [])
-  where go :: [String] -> Eff '[Teletype] w -> [String] -> [String]
-        go _      (Val _) acc = acc
-        go []     _       acc = acc
-        go (x:xs) (E u q) acc = case decomp u of
-          Right (PutStrLn msg) -> go (x:xs) (qApp q ()) (msg:acc)
-          Right GetLine        -> go xs     (qApp q x) acc
-          Right ExitSuccess    -> go xs     (Val ())   acc
-          Left _               -> go xs     (Val ())   acc
+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)

freer.cabal

@@ -48,6 +48,7 @@ library
                      , Control.Monad.Freer.Writer
                      , Data.FTCQueue
                      , Data.Open.Union
+                     , Data.Open.Union.Internal
 
   build-depends:       base >=4.7 && <5
   hs-source-dirs:      src

src/Control/Monad/Freer.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE RankNTypes #-}
 {-|
 Module      : Control.Monad.Freer
 Description : Freer - an extensible effects library
@@ -13,7 +16,12 @@ module Control.Monad.Freer (
   Members,
   Eff,
   run,
+  runM,
+  runNat,
+  handleRelay,
+  handleRelayS,
   send,
+  Arr,
 
   NonDetEff(..),
   makeChoiceA,
@@ -21,3 +29,9 @@ module Control.Monad.Freer (
 ) where
 
 import Control.Monad.Freer.Internal
+
+runNat
+  :: forall m r e w.
+     (Member m r)
+  => (forall a. e a -> m a) -> Eff (e ': r) w -> Eff r w
+runNat f = handleRelay pure (\v -> (send (f v) >>=))

src/Control/Monad/Freer/Internal.hs

@@ -44,6 +44,7 @@ module Control.Monad.Freer.Internal (
 
   decomp,
   tsingleton,
+  extract,
 
   qApp,
   qComp,
@@ -137,9 +138,8 @@ run _       = error "Internal:run - This (E) should never happen"
 -- This is useful for plugging in traditional transformer stacks.
 runM :: Monad m => Eff '[m] w -> m w
 runM (Val x) = return x
-runM (E u q) = case decomp u of
-  Right mb -> mb >>= runM . qApp q
-  Left _   -> error "Internal:runM - This (Left) should never happen"
+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

src/Control/Monad/Freer/Trace.hs

@@ -38,6 +38,5 @@ trace = send . Trace
 -- | An IO handler for Trace effects
 runTrace :: Eff '[Trace] w -> IO w
 runTrace (Val x) = return x
-runTrace (E u q) = case decomp u of
-     Right (Trace s) -> putStrLn s >> runTrace (qApp q ())
-     Left _          -> error "runTrace:Left - This should never happen"
+runTrace (E u q) = case extract u of
+     Trace s -> putStrLn s >> runTrace (qApp q ())

src/Data/Open/Union.hs

@@ -31,72 +31,22 @@ starting point.
 -}
 
 module Data.Open.Union (
+  module Data.Open.Union,
   Union,
+  Member(..),
   decomp,
   weaken,
-  Member(..),
-  Members
+  extract,
+  Functor(..)
 ) where
 
 import GHC.Exts
+import Data.Open.Union.Internal
 
 --------------------------------------------------------------------------------
                            -- Interface --
 --------------------------------------------------------------------------------
-data Union (r :: [ * -> * ]) v where
-  UNow  :: t v -> Union (t ': r) v
-  UNext :: Union r v -> Union (any ': r) v
-
-{-# INLINE decomp #-}
-decomp :: Union (t ': r) v -> Either (Union r v) (t v)
-decomp (UNow x)  = Right x
-decomp (UNext v) = Left v
-
-{-# INLINE weaken #-}
-weaken :: Union r w -> Union (any ': r) w
-weaken = UNext
-
-class (Member' t r (FindElem t r)) => Member t r where
-  inj :: t v -> Union r v
-  prj :: Union r v -> Maybe (t v)
-
-instance (Member' t r (FindElem t r)) => Member t r where
-  inj = inj' (P :: P (FindElem t r))
-  prj = prj' (P :: P (FindElem t r))
-
 type family Members m r :: Constraint where
   Members (t ': c) r = (Member t r, Members c r)
   Members '[] r = ()
 
---------------------------------------------------------------------------------
-                         -- Implementation --
---------------------------------------------------------------------------------
-data Nat = S Nat | Z
-data P (n :: Nat) = P
-
--- injecting/projecting at a specified position P n
-class Member' t r (n :: Nat) where
-  inj' :: P n -> t v -> Union r v
-  prj' :: P n -> Union r v -> Maybe (t v)
-
-instance (r ~ (t ': r')) => Member' t r 'Z where
-  inj' _ = UNow
-  prj' _ (UNow x) = Just x
-  prj' _ _        = Nothing
-
-instance (r ~ (t' ': r'), Member' t r' n) => Member' t r ('S n) where
-  inj' _ = UNext . inj' (P::P n)
-  prj' _ (UNow _)  = Nothing
-  prj' _ (UNext x) = prj' (P::P n) x
-
--- Find an index of an element in a `list'
--- The element must exist
--- This closed type family disambiguates otherwise overlapping
--- instances
-type family FindElem (t :: * -> *) r :: Nat where
-  FindElem t (t ': r)    = 'Z
-  FindElem t (any ': r)  = 'S (FindElem t r)
-
-type family EQU (a :: k) (b :: k) :: Bool where
-  EQU a a = 'True
-  EQU a b = 'False

src/Data/Open/Union/Internal.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds, PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Open.Union.Internal where
+
+data Union (r :: [ * -> * ]) v where
+  UNow  :: t v -> Union (t ': r) v
+  UNext :: Union (t ': r) v -> Union (any ': t ': r) v
+
+data Nat = S Nat | Z
+data P (n :: Nat) = P
+
+-- injecting/projecting at a specified position P n
+class Member' t r (n :: Nat) where
+  inj' :: P n -> t v -> Union r v
+  prj' :: P n -> Union r v -> Maybe (t v)
+
+instance (r ~ (t ': r')) => Member' t r 'Z where
+  inj' _ = UNow
+  prj' _ (UNow x) = Just x
+  prj' _ _        = Nothing
+
+instance (r ~ (t' ': r' : rs'), Member' t (r' : rs') n) => Member' t r ('S n) where
+  inj' _ = UNext . inj' (P::P n)
+  prj' _ (UNow _)  = Nothing
+  prj' _ (UNext x) = prj' (P::P n) x
+
+-- Find an index of an element in a `list'
+-- The element must exist
+-- This closed type family disambiguates otherwise overlapping
+-- instances
+type family FindElem (t :: * -> *) r :: Nat where
+  FindElem t (t ': r)    = 'Z
+  FindElem t (any ': r)  = 'S (FindElem t r)
+
+type family EQU (a :: k) (b :: k) :: Bool where
+  EQU a a = 'True
+  EQU a b = 'False
+
+--------------------------------------------------------------------------------
+                           -- Interface --
+--------------------------------------------------------------------------------
+
+{-# INLINE decomp #-}
+decomp :: Union (t ': r) v -> Either (Union r v) (t v)
+decomp (UNow x)  = Right x
+decomp (UNext v) = Left v
+
+{-# INLINE weaken #-}
+weaken :: Union (t ': r) w -> Union (any ': t ': r) w
+weaken = UNext
+
+{-# INLINE extract #-}
+extract :: Union '[t] v -> t v
+extract (UNow x)  = x
+
+
+class (Member' t r (FindElem t r)) => Member t r where
+  inj :: t v -> Union r v
+  prj :: Union r v -> Maybe (t v)
+
+instance (Member' t r (FindElem t r)) => Member t r where
+  inj = inj' (P :: P (FindElem t r))
+  prj = prj' (P :: P (FindElem t r))
+
+instance (Functor f) => Functor (Union '[f]) where
+  fmap f = inj . fmap f . extract
+instance (Functor f1, Functor (Union (f2 ': fs))) =>
+         Functor (Union (f1 ': f2 ': fs)) where
+  fmap f = either (weaken . fmap f) (inj . fmap f) . decomp
+
+