/
Teletype.hs
73 lines (54 loc) · 2.42 KB
/
Teletype.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Teletype where
import Prelude hiding (read)
import Control.Effect
import Control.Effect.Carrier
import Control.Effect.State
import Control.Effect.Sum
import Control.Effect.Writer
import Control.Monad.IO.Class
import Data.Coerce
import Test.Hspec
import Test.Hspec.QuickCheck
spec :: Spec
spec = describe "teletype" $ do
prop "reads" $
\ line -> run (runTeletypeRet [line] read) `shouldBe` ([], ([], line))
prop "writes" $
\ input output -> run (runTeletypeRet input (write output)) `shouldBe` ([output], (input, ()))
prop "writes multiple things" $
\ input output1 output2 -> run (runTeletypeRet input (write output1 >> write output2)) `shouldBe` ([output1, output2], (input, ()))
data Teletype (m :: * -> *) k
= Read (String -> k)
| Write String k
deriving (Functor)
instance HFunctor Teletype where
hmap _ = coerce
{-# INLINE hmap #-}
instance Effect Teletype where
handle state handler (Read k) = Read (handler . (<$ state) . k)
handle state handler (Write s k) = Write s (handler (k <$ state))
read :: (Member Teletype sig, Carrier sig m) => m String
read = send (Read pure)
write :: (Member Teletype sig, Carrier sig m) => String -> m ()
write s = send (Write s (pure ()))
runTeletypeIO :: TeletypeIOC m a -> m a
runTeletypeIO = runTeletypeIOC
newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance (MonadIO m, Carrier sig m) => Carrier (Teletype :+: sig) (TeletypeIOC m) where
eff (L (Read k)) = liftIO getLine >>= k
eff (L (Write s k)) = liftIO (putStrLn s) >> k
eff (R other) = TeletypeIOC (eff (handleCoercible other))
runTeletypeRet :: [String] -> TeletypeRetC m a -> m ([String], ([String], a))
runTeletypeRet i = runWriter . runState i . runTeletypeRetC
newtype TeletypeRetC m a = TeletypeRetC { runTeletypeRetC :: StateC [String] (WriterC [String] m) a }
deriving (Applicative, Functor, Monad)
instance (Carrier sig m, Effect sig) => Carrier (Teletype :+: sig) (TeletypeRetC m) where
eff (L (Read k)) = do
i <- TeletypeRetC get
case i of
[] -> k ""
h:t -> TeletypeRetC (put t) *> k h
eff (L (Write s k)) = TeletypeRetC (tell [s]) *> k
eff (R other) = TeletypeRetC (eff (R (R (handleCoercible other))))