aio.hs

#!/usr/bin/env stack
-- stack runghc --package free

{-# LANGUAGE GADTs #-}

import Control.Applicative
import Control.Applicative.Free

data Inst a where
  GetLine :: Inst String
  PutLine :: Inst (String -> ())
  Map :: (b -> a) -> Inst b -> Inst a

instance Show (Inst a) where
  show GetLine   = "GetLine"
  show PutLine   = "PutLine"
  show (Map _ i) = "Map _ (" ++ show i ++ ")"

type AIO = Ap Inst

getLine' :: AIO String
getLine' = liftAp GetLine

putLine' :: AIO (String -> ())
putLine' = liftAp PutLine

interpret :: AIO a -> IO a
interpret (Pure x) = return x
interpret (Ap PutLine (Pure f)) = return (f (const ()))
-- x :: Ap Inst (String -> (String -> ()) -> a)
interpret (Ap PutLine (Ap GetLine x)) = do
  line <- getLine
  putStrLn line
  next <- interpret x
  return (next line (const ()))
-- other cases omitted

example :: AIO ()
example = putLine' <*> getLine'

main :: IO ()
main = do
  -- ask for line, and prints it
  interpret example
  -- Doesn't print "foo", as this Applicative IO can print only values it has read.
  interpret (putLine' <*> pure "foo")