module Game.Antisplice.Monad.Vocab where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Chatty.TST
import Data.Chatty.Hetero
data Token = Unintellegible String
| Verb String
| Prep String
| Noun String
| Adj String
| Ordn Int String
| Fixe String
| Skilln String
| Nounc [String] (Maybe Int) String
deriving Eq
instance Show Token where
show (Unintellegible s) = "[?] " ++ s
show (Verb s) = "[verb] " ++ s
show (Prep s) = "[prep] " ++ s
show (Noun s) = "[noun] " ++ s
show (Adj s) = "[adj] " ++ s
show (Ordn i s) = "[#" ++ show i ++ "] " ++ s
show (Fixe s) = "[fix] " ++ s
show (Skilln s) = "[skill] " ++ s
show (Nounc [] Nothing s) = "[noun+] "++s
show (Nounc as Nothing s) = "[noun+] "++unwords as++" "++s
show (Nounc [] (Just i) s) = "[noun #"++show i++"] "++s
show (Nounc as (Just i) s) = "[noun #"++show i++"] "++unwords as++" "++s
instance Tuplify Token Token where
tuplify = id
newtype VocabT m a = Vocab { runVocabT :: TST Token -> m (a,TST Token) }
instance Functor m => Functor (VocabT m) where
fmap f a = Vocab $ \s -> fmap (first f) $ runVocabT a s
instance (Functor m, Monad m) => Applicative (VocabT m) where
(<*>) = ap
pure = return
instance Monad m => Monad (VocabT m) where
return a = Vocab $ \s -> return (a,s)
m >>= f = Vocab $ \s -> do (a,s') <- runVocabT m s; runVocabT (f a) s'
instance MonadTrans VocabT where
lift m = Vocab $ \s -> do a <- m; return (a,s)
instance MonadIO m => MonadIO (VocabT m) where
liftIO = lift . liftIO
class Monad m => MonadVocab m where
lookupVocab :: String -> m Token
insertVocab :: String -> (String -> Token) -> m ()
vocabKnown :: String -> m Bool
instance Monad m => MonadVocab (VocabT m) where
lookupVocab k = Vocab $ \s -> case tstLookup k s of
Just t -> return (t,s)
Nothing -> return (Unintellegible k,s)
insertVocab k tc = Vocab $ \s -> return ((),tstInsert k (tc k) s)
vocabKnown k = Vocab $ \s -> return (tstContains k s,s)