FreeT.hs

{-# LANGUAGE RankNTypes #-}

import Prelude hiding (readFile)
import qualified Prelude as P

data Free f a =
  Done a
  | More (f (Free f a))

instance Functor f => Functor (Free f) where
  fmap f (Done a) =
    Done (f a)
  fmap f (More k) =
    More (fmap (fmap f) k)

instance Functor f => Monad (Free f) where
  return =
    Done
  Done a >>= f =
    f a
  More k >>= f =
    More (fmap (>>= f) k)

-- pass in all arguments to ctor, then function Ret -> a
data Grammar a =
  PrintO String a
  | PrintE String a
  | ReadChar (Char -> a)
  | ReadFile String (String -> a)

instance Functor Grammar where
  fmap f (PrintO s a) =
    PrintO s (f a)
  fmap f (PrintE s a) =
    PrintE s (f a)
  fmap f (ReadChar k) =
    ReadChar (f . k)
  fmap f (ReadFile s k) =
    ReadFile s (f . k)

type Yay a =
  Free Grammar a

printO ::
  String
  -> Yay ()
printO s =
  More (fmap Done (PrintO s ()))

printE ::
  String
  -> Yay ()
printE s =
  More (fmap Done (PrintE s ()))

readChar ::
  Yay Char
readChar =
  More (fmap Done (ReadChar id))

readFile ::
  String
  -> Yay String
readFile s =
  More (fmap Done (ReadFile s id))

program ::
  Yay ()
program =
  do printO "hi"
     c <- readChar
     printE [c]
     f <- readFile "/etc/group"
     printO f

hom ::
  Yay a 
  -> IO a
hom (Done a) =
  return a
hom (More (PrintO s a)) =
  do putStrLn s
     hom a
hom (More (PrintE s a)) =
  do putStrLn s
     hom a
hom (More (ReadChar k)) =
  do c <- getChar
     hom (k c)
hom (More (ReadFile s k)) =
  do f <- P.readFile s
     hom (k f)

data Free' f a =
  Free' (forall x. (a -> x) -> (f (Free' f a) -> x) -> x)

thisWay ::
  Functor f =>
  Free f a
  -> Free' f a
thisWay (Done a) =
  Free' (\d _ -> d a)
thisWay (More k) =
  Free' (\_ m -> m (fmap thisWay k))

thatWay ::
  Functor f =>
  Free' f a
  -> Free f a
thatWay (Free' q) =
  q Done (More . fmap thatWay)

data FreeT t f a =
  FreeT (forall x. (a -> t x) -> (f (Free' f a) -> t x) -> t x)

data Id a = Id a
instance Functor Id where
  fmap f (Id a) =
    Id (f a)

type Free'' f a = FreeT Id f a

instance (Functor t, Functor f) => Functor (FreeT t f) where
  fmap f (FreeT q) =
    FreeT undefined

instance (Monad t, Functor f) => Monad (FreeT t f) where
  return =
    undefined
  (>>=) =
    undefined