Merge branch 'master' into 'master'

Miscellany

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

See merge request !11
This commit is contained in:
Allele Dev 2016-11-25 06:38:37 +00:00
commit 3b6172714d
9 changed files with 133 additions and 87 deletions

View File

@ -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 --

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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) >>=))

View File

@ -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

View File

@ -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 ())

View File

@ -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

View File

@ -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