{-# LANGUAGE DeriveFunctor, FlexibleContexts, GADTs #-}

-- based on 'why free monads matter'

--import Data.Functor.Foldable
--import Control.Monad.Free
--import qualified Control.Monad.Trans.Free as CMTF 
import Control.Monad


data Toy a next =
  Output a next
  | Bell next
  | Done
  deriving Functor

-- absolutely unmanageable
toy1 :: Toy Char (Toy a (Toy Char (Toy a next)))
toy1 = Output 'A' (Bell (Output 'B' Done))

newtype Fix f = Fix { unfix :: f (Fix f) }

toy2 :: Fix (Toy Char)
toy2 = Fix (Output 'A' (Fix (Bell (Fix (Output 'B' (Fix Done))))))

-- What about subroutines?
data Free f r = Free (f (Free f r)) | Pure r
  deriving Functor

instance Functor f => Applicative (Free f) where
  pure = Pure
  (<*>) = ap
  
instance Functor f => Monad (Free f) where
  return = Pure
  (Pure r) >>= f = f r
  (Free x) >>= f = Free (fmap (>>= f) x)

liftF cmd = Free (fmap Pure cmd)

output x = liftF (Output x ())
bell = liftF (Bell ())
done = liftF Done

toy3 :: Free (Toy Char) r
toy3 = do
  output 'A'
  bell
  output 'B'
  done

subroutine :: Free (Toy Char) ()
subroutine = output 'A' >> bell

program :: Free (Toy Char) r
program = do
  subroutine
  output 'B'
  bell
  done

-- what can we do with our "quoted" DSL?
data FreeF f a b = PureF a | FreeF (f b)
  deriving Functor

project (Pure r) = PureF r
project (Free f) = FreeF f

cata :: (FreeF (Toy a) r b -> b) -> Free (Toy a) r -> b
cata f = h where h = f . fmap h . project

countBells :: FreeF (Toy a) r Int -> Int
countBells (PureF x) = 0
countBells (FreeF r) = case r of
  Done -> 0
  Bell r -> 1 + r
  Output _ r -> r

eval :: Show a => FreeF (Toy a) r (IO ()) -> IO ()
eval (PureF x) = pure () --error "improper termination"
eval (FreeF r) = case r of
  Done -> pure ()
  Bell r -> putChar '\7' >> r
  Output x r -> print x >> r