module Game.Antisplice.Templates where
import Language.Haskell.TH
import Text.Chatty.Templates
import Text.Chatty.Channel.Printer
import Text.Chatty.Channel.Broadcast
import Game.Antisplice.Utils.Fail
import Game.Antisplice.Utils.Run
import Game.Antisplice.Utils.Counter
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Monad.Vocab
import Game.Antisplice.Utils.Atoms
import Control.Monad.Error.Class
import Control.Monad.Trans.Class
import Control.Monad.State.Class
import Control.Monad.IO.Class
type PlayerFilterT = FilterT PlayerId
mkRoom s = [d|
instance MonadRoom m => MonadRoom ($sx m) where
getRoomState = lift getRoomState
putRoomState = lift . putRoomState
|]
where sx = strToType s
mkFail e s = [d|
instance (MonadError $ex m) => MonadError $ex ($sx m) where
throwError = lift . throwError
catchError = error "catchError not implemented for this type."
|]
where sx = strToType s
ex = strToType e
mkDungeon s = [d|
instance MonadDungeon m => MonadDungeon ($sx m) where
getDungeonState = lift getDungeonState
putDungeonState = lift . putDungeonState
instance (MonadDungeon m,ChannelPrinter PlayerId m) => Broadcaster PlayerId ($sx m) where
bprint c = lowerDungeon . bprint (lift . c)
|]
where sx = strToType s
mkCounter s = [d|
instance MonadCounter m => MonadCounter ($sx m) where
countOn = lift countOn
|]
where sx = strToType s
mkObject s = [d|
instance MonadObject m => MonadObject ($sx m) where
getObjectState = lift getObjectState
putObjectState = lift . putObjectState
|]
where sx = strToType s
mkPlayer s = [d|
instance MonadPlayer m => MonadPlayer ($sx m) where
getPlayerState = lift getPlayerState
putPlayerState = lift . putPlayerState
|]
where sx = strToType s
mkIO s = [d|
instance MonadIO m => MonadIO ($sx m) where
liftIO = lift . liftIO
|]
where sx = strToType s
mkVocab s = [d|
instance MonadVocab m => MonadVocab ($sx m) where
lookupVocab = lift . lookupVocab
insertVocab k = lift . insertVocab k
vocabKnown = lift . vocabKnown
|]
where sx = strToType s
mkAtoms s = [d|
instance MonadAtoms m => MonadAtoms ($sx m) where
newAtom = lift newAtom
putAtom k = lift . putAtom k
getAtom = lift . getAtom
dispAtom = lift . dispAtom
cloneAtom = lift . cloneAtom
|]
where sx = strToType s