1-simple-interpreter.hs

data Program next = Output String next | Done

p = Output "Hello World" (Output "Good Bye" Done)

-- an interpreter to run
run :: Program (Program (Program next)) -> IO ()
run (Output s1 (Output s2 Done)) = do
  putStrLn s1
  putStrLn s2

-- and then you can intepret it any way you want
-- for example to an array
test :: Program (Program (Program next)) -> [String]
test (Output s1 (Output s2 Done)) = [s1, s2]

main :: IO ()
main = run p
-- main = print $ test p

-- but the type is not useful
-- so try to make it better
{-
run :: Program next -> IO ()
run (Output s next) = do
  putStrLn s
  run next
run Done = return ()
-}


-- but we cannot do that be cause
{-
run (Output s1 (Output s2 Done))
-}
-- doesn't have same type of this
{-
run (Output s2 Done)
-}

-- So how? fix point come to help

2-fix-point.hs

-- what is fix point?
-- given a function f
-- when x = f x
-- then x is the fix point of x
--
-- a hard example: y combinator
yCom g = f where f = g f

genFib f 0 = 0
genFib f 1 = 1
genFib f n = f (n - 1) + f (n - 2)

fib = yCom genFib

main = print $ map fib [0..6]


-- an even harder example: fix point of functor
-- that is
-- a data type which is a fix point of functor (which is type function

3-nested-instructions.hs

data Fix f = Fx (f (Fix f))

data IS next = Output String next | Done

program :: Fix IS
program =
  (Fx (Output "Hello"
    (Fx (Output "World"
      (Fx Done)))))

runProgram :: Fix IS -> IO ()
runProgram (Fx (Output s next)) = do
  putStrLn s
  runProgram next

runProgram (Fx Done) = return ()

main = runProgram program

{-
Nice! now we can intepret program with any length of instructions
but where is the input?
-}

4-where-is-the-input.hs

data Fix f = Fx (f (Fix f))

-- in order to handle input
-- 1. we need add another instruction
-- 2. and for pass the read string to next instruction
--    we need to change `next` to `(String -> next)`

data IS next = Input (String -> next)
             | Output String next
             | Done

program :: Fix IS
program =
  (Fx (Input (\s ->
    (Fx (Output ("Hello " ++ s)
      (Fx Done))))))

runProgram :: Fix IS -> IO ()
runProgram (Fx (Input genNext)) = do
  s <- getLine
  runProgram $ genNext s

runProgram (Fx (Output s next)) = do
  putStrLn s
  runProgram next

runProgram (Fx Done) = return ()

main = runProgram program

-- cool! now we can do some user interaction
-- but the program construction is really unpleasant
-- we can make Fix IS a monad!!

5-the-monad.hs

-- because monad need a `return`
-- so we need to move the terminal node to Fix
-- and now we can rename Fix to Free
data Free f r = Free (f (Free f r)) | Pure r

data IS next = Input (String -> next)
             | Output String next

-- in order to declare the monad instance for Fix IS
-- we need to make IS a Functor

instance Functor IS where
  fmap f (Input genNext) = Input $ f . genNext
  fmap f (Output s next) = Output s $ f next

-- and then the monad
-- but to define monad instance we need functor and applicative defined
-- (this part can be skipped)

instance (Functor f) => Functor (Free f) where
  fmap f (Free x) = Free $ fmap (fmap f) x
  fmap f (Pure r) = Pure $ f r

instance (Functor f) => Applicative (Free f) where
  pure = Pure
  Pure f <*> Pure a = Pure $ f a
  Pure f <*> Free ma = Free $ fmap f <$> ma
  Free ma <*> b = Free $ (<*> b) <$> ma -- TODO figure out what is this

-- then monad
-- this is the most insteresting part

instance (Functor f) => Monad (Free f) where
  (Free x) >>= f = Free (fmap (>>= f) x)
  (Pure r) >>= f = f r

-- what does this do?
-- assume that
--
-- f :: s -> Free IS ()
--
-- and we have a free monad
--
-- fm = (Free (Input (\s -> Pure s)))
--
-- then
--
-- fm >>= f
--
--    // by free monad definition (Free part
--    = Free (fmap (>>= f) (Input (\s -> Pure s)))
--
--    // by IS Functor definition
--    = Free (Input (\s -> (Pure s >>= f)))
--
--    // by free monad definition (Pure part
--    = Free (Input (\s -> f s))
--
-- so the what the monad does is
--
-- carry the monad generator to the end of the "Free Monad List"
-- and apply the generator with the value r and got the "next" instruction




-- now we have monad so we can do this!

input = (Free (Input (\s -> Pure s)))
output s = (Free (Output s (Pure ())))

program :: Free IS ()
program = do
  s <- input
  output $ "Hello " ++ s

runProgram :: Free IS () -> IO ()
runProgram (Free (Input genNext)) = do
  s <- getLine
  runProgram $ genNext s

runProgram (Free (Output s next)) = do
  putStrLn s
  runProgram next

runProgram (Pure r) = return r

main = runProgram program

-- Now there is a free monad, but seems complicated,
-- can we simplify it?

6-simplify.hs

{-# LANGUAGE DeriveFunctor #-}

data Free f r = Free (f (Free f r)) | Pure r deriving (Functor)

data IS next = Input (String -> next)
             | Output String next
             deriving (Functor)

-- gch is so powerful to derive Functor automatically!!

instance (Functor f) => Applicative (Free f) where
  pure = Pure
  Pure f <*> Pure a = Pure $ f a
  Pure f <*> Free ma = Free $ fmap f <$> ma
  Free ma <*> b = Free $ (<*> b) <$> ma -- TODO figure out what is this

instance (Functor f) => Monad (Free f) where
  (Free x) >>= f = Free (fmap (>>= f) x)
  (Pure r) >>= f = f r

-- and reduce duplicte code

liftF i = Free (fmap Pure i)

input = liftF $ Input (\s -> s)
output s = liftF $ Output s ()

program :: Free IS ()
program = do
  s <- input
  output $ "Hello " ++ s

runProgram :: Free IS () -> IO ()
runProgram (Free (Input genNext)) = do
  s <- getLine
  runProgram $ genNext s

runProgram (Free (Output s next)) = do
  putStrLn s
  runProgram next

runProgram (Pure r) = return r

main = runProgram program

-- futhermore there is a Free Monad built by others, we can just use it!
-- so what are the benefits? pure!!!
-- let's go back to the problem of first file

7-how-to-prevent-side-effect.hs

{-# LANGUAGE DeriveFunctor #-}

data Free f r = Free (f (Free f r)) | Pure r deriving (Functor)

instance (Functor f) => Applicative (Free f) where
  pure = Pure
  Pure f <*> Pure a = Pure $ f a
  Pure f <*> Free ma = Free $ fmap f <$> ma
  Free ma <*> b = Free $ (<*> b) <$> ma -- TODO figure out what is this

instance (Functor f) => Monad (Free f) where
  (Free x) >>= f = Free (fmap (>>= f) x)
  (Pure r) >>= f = f r

data IS next = Input (String -> next)
             | Output String next
             deriving (Functor)


liftF i = Free (fmap Pure i)

input = liftF $ Input (\s -> s)
output s = liftF $ Output s ()

-- let's do some computation

readInt :: Free IS Int
readInt = read <$> input

program :: Free IS ()
program = do
  a <- readInt
  b <- readInt
  output $ show $ a + b

runProgram :: Free IS () -> IO ()
runProgram (Free (Input genNext)) = do
  s <- getLine
  runProgram $ genNext s

runProgram (Free (Output s next)) = do
  putStrLn s
  runProgram next

runProgram (Pure r) = return r

-- we can write different interpreter

testProgram :: Free IS () -> [String] -> [String]
testProgram (Free (Input genNext)) (x : xs) =
  testProgram (genNext x) xs

testProgram (Free (Output s next)) xs =
  s : testProgram next xs

testProgram (Pure r) _ = []

test1 = if testProgram program ["1", "2"] == ["3"]
          then putStrLn "PASS"
          else putStrLn "FAIL"

test2 = if testProgram program ["3", "-2"] == ["3"]
          then putStrLn "PASS"
          else putStrLn "FAIL"

main = do
  test1
  test2

-- Yeah!! That's right, we can interpret the program as a pure function!