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
74
|
{-# LANGUAGE DeriveFunctor, FlexibleInstances, GADTs #-}
module Teletype.Rigid where
import Prelude hiding (getLine, putStrLn)
import qualified Prelude as IO
import qualified Control.Monad as IO
import Control.Selective
import Control.Selective.Rigid.Free
-- See Section 5.2 of the paper: https://dl.acm.org/doi/10.1145/3341694.
-- | The classic @Teletype@ base functor.
data TeletypeF a = Read (String -> a) | Write String a deriving Functor
instance Eq (TeletypeF ()) where
Read _ == Read _ = True
Write x () == Write y () = x == y
_ == _ = False
instance Show (TeletypeF a) where
show (Read _) = "Read"
show (Write s _) = "Write " ++ show s
-- | Interpret 'TeletypeF' commands as 'IO' actions.
toIO :: TeletypeF a -> IO a
toIO (Read f) = f <$> IO.getLine
toIO (Write s a) = a <$ IO.putStrLn s
-- | A Teletype program is a free selective functor on top of the base functor
-- 'TeletypeF'.
type Teletype a = Select TeletypeF a
-- | A convenient alias for reading a string.
getLine :: Teletype String
getLine = liftSelect (Read id)
-- | A convenient alias for writing a string.
putStrLn :: String -> Teletype ()
putStrLn s = liftSelect (Write s ())
-- | The ping-pong example from the introduction section of the paper
-- implemented using free selective functors.
--
-- @
-- > getEffects pingPongS
-- [Read,Write "pong"]
-- @
--
-- If can also be executed in IO:
--
-- @
-- > runSelect toIO pingPongS
-- hello
-- > runSelect toIO pingPongS
-- ping
-- pong
-- @
pingPongS :: Teletype ()
pingPongS = whenS (fmap ("ping"==) getLine) (putStrLn "pong")
------------------------------- Ping-pong example ------------------------------
-- | Monadic ping-pong, which has the desired behaviour, but cannot be
-- statically analysed.
pingPongM :: IO ()
pingPongM = IO.getLine >>= \s -> IO.when (s == "ping") (IO.putStrLn "pong")
-- | Applicative ping-pong, which always executes both effect, but can be
-- statically analysed.
pingPongA :: IO ()
pingPongA = IO.getLine *> IO.putStrLn "pong"
-- | A monadic greeting. Cannot be implemented using selective functors.
greeting :: IO ()
greeting = IO.getLine >>= \name -> IO.putStrLn ("Hello, " ++ name)
|
