Simple.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFoldable, DeriveTraversable #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where

import Control.Applicative
import Control.Comonad
import Control.Monad
import Control.Monad.Free.Class
import Control.Monad.Free.TH
import Control.Monad.Trans
import qualified Control.Monad.Free as F
import Control.Monad.Trans.Free (iterT)
import qualified Control.Monad.Trans.Free as FT
import Control.Monad.Trans.Free.Replay
import Control.Replay.Class
import Data.Foldable (Foldable)
import Data.Traversable (Traversable)
import Data.Functor.Identity
data GameF a =
    Dialog String String a
  | Narrate String a
  | Prompt String (String -> a)
  deriving (Functor)

instance Show a => Show (GameF a) where
  showsPrec d (Dialog s t m) = showParen (d > 10) $
    showString "Dialog " . showsPrec 11 s . showString " " . showsPrec 11 t . showString " " . showsPrec 11 m
  showsPrec d (Narrate s m) = showParen (d > 10) $
    showString "Narrate " . showsPrec 11 s . showString " " . showsPrec 11 m
  showsPrec d (Prompt s _) = showParen (d > 10) $
    showString "Prompt " . showsPrec 11 s . showString " " . showString "<function>"
data InputF a = 
    Skip a
  | Choose String a
  deriving (Functor, Foldable, Traversable, Read, Show)

$(makeFree ''GameF)
$(makeFree ''InputF)

instance Comonad InputF where
  extract (Skip a) = a
  extract (Choose _ a) = a
  {-# INLINE extract #-}
  duplicate w@(Skip _) = Skip w
  duplicate w@(Choose s _) = Choose s w

instance Replay GameF InputF where
  replay k (Dialog _ _ a) (Skip b) = Skip <$> k a b
  replay k (Narrate _ a)  (Skip b) = Skip <$> k a b
  replay k (Prompt _ f)   (Choose s b) = Choose s <$> k (f s) b
  replay _ _ _ = empty
  {-# INLINE replay #-}

testG :: MonadFree GameF m => m Int
testG = do
  narrate "Set the scene!"
  forM_ [1..1000000] $ const (narrate "Junk")
  name <- prompt "And who are you?"
  narrate $ name ++ " appeared."
  return $ length name

testI :: MonadFree InputF m => m ()
testI = do
  skip
  forM_ [1..1000000] $ const skip
  skip
  skip--choose "Christian"
  --skip
  
result = replayFreeT testG testI

lastPos :: (FT.Free GameF Int, F.Free InputF ())
lastPos = runIdentity $ FT.iterT extract result