IO algebra

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
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -F -pgmF she #-}

import Control.Applicative

data IOShape x = GetC (Char -> x)
               | PutC Char x
               | GetA ([String] -> x)
               | Stop

instance Functor IOShape where
    fmap f (GetC   k) = GetC (f . k)
    fmap f (PutC c k) = PutC c (f k)
    fmap f (GetA   k) = GetA (f . k)
    fmap _ Stop       = Stop

newtype Mu f = Roll { rock :: f (Mu f) }

data Free f a = Return a | Branch (f (Free f a))

pattern GetChar   k = Roll (GetC k)
pattern PutChar c k = Roll (PutC c k)
pattern GetArgs   k = Roll (GetA k)
pattern Done        = Roll Stop

instance Functor f => Monad (Free f) where
    return           = Return
    Return x   >>= f = f x
    Branch ffa >>= f = Branch ((>>= f) <$> ffa)

type Main = Mu IOShape

type IOE = Free IOShape

mkMain :: Main -> IO ()
mkMain (GetChar   k) = getChar >>= mkMain . k
mkMain (PutChar c k) = putChar c >> mkMain k
mkMain Done          = return ()

fill :: (a -> Main) -> IOE a -> Main
fill subst (Branch ffa) = Roll $ fmap (fill subst) ffa
fill subst (Return x)   = subst x

fill' :: IOE () -> Main
fill' = fill (const Done)

getChar' :: IOE Char
getChar' = Branch (GetC Return)

putChar' :: Char -> IOE ()
putChar' c = Branch (PutC c (Return ()))

getArgs' :: IOE [String]
getArgs' = Branch (GetA Return)