free from scratch.hs

{-# LANGUAGE KindSignatures #-}
module Lib where

data Console k =
  Done k |
  PrintLine String (Console k) |
  ReadLine (String -> Console k)

instance Functor Console where
  fmap f (Done a)             = Done (f a)
  fmap f (PrintLine str next) = PrintLine str (fmap f next)
  fmap f (ReadLine rf)        = ReadLine (\line -> fmap f (rf line))

-- fmap:  (a -> b) -> f a -> f b

-- <*>: f (a -> b) -> f a -> f b


instance Applicative Console where
  pure a = Done a
  (<*>) func (Done a)             = fmap (\f -> f a) func
  (<*>) func (PrintLine str next) = PrintLine str (func <*> next)
  (<*>) func (ReadLine rf)        = ReadLine (\line -> func <*> rf line)

instance Monad Console where
  (Done k) >>= f = f k
  (PrintLine str next) >>= f = PrintLine str (next >>= f)
  (ReadLine rf) >>= f = ReadLine (\l -> (rf l) >>= f)

helloWorld :: Console ()
helloWorld = PrintLine "Hello World" (Done ())

helloWorldTwice :: Console ()
helloWorldTwice = PrintLine "Hello" (PrintLine "World" (Done ()))

helloWorldTwice' :: Console ()
helloWorldTwice' = do
  PrintLine "Hello" (Done ())
  PrintLine "World" (Done ())

ask :: String -> Console String
ask question = PrintLine question (ReadLine (\line -> (PrintLine ("I got " ++ line) (Done line))))

-- ask' :: String -> Console String
-- ask' question = do
  -- PrintLine question (Done ())
  -- line <- ReadLine (\l -> Done l)
  -- return line

interpreter :: Console k -> IO k
interpreter (PrintLine str next) = (putStrLn str) *> interpreter next
interpreter (ReadLine func)      = getLine >>= (interpreter . func)
interpreter (Done k)             = return k

data Free (f:: * -> *) (k :: *) =
  Pure k |
  Impure (f (Free f k))

instance Functor (Free f) where
  fmap = undefined

instance Applicative (Free f) where
  pure = undefined
  (<*>) = undefined

instance Functor f => Monad (Free f) where
  -- (>>=) :: (Free f a) -> (a -> Free f b) -> Free f b
  free >>= func = undefined

data Console' k =
  PrintLine' String k |
  ReadLine' (String -> k)

instance Functor Console' where
  fmap = undefined

printLine :: String -> Free Console' ()
printLine line = Impure (PrintLine' line (Pure ()))

readLine ::  Free Console' String
readLine =  Impure (ReadLine' (\line -> (Pure line)))

helloTwiceFree :: Free Console' ()
helloTwiceFree = do
  printLine "Hello"
  printLine "World"