module Text.Chatty.Expansion.History where
import Prelude hiding (id,(.))
import Control.Applicative
import Control.Arrow
import Control.Category (id,(.))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Text.Chatty.Expansion
newtype HistoryT m a = History {
runHistoryT :: [String] -> m (a,[String])
}
instance Monad m => Monad (HistoryT m) where
return a = History $ \s -> return (a,s)
(History h) >>= f = History $ \s -> do (a,s') <- h s; runHistoryT (f a) s'
instance MonadTrans HistoryT where
lift m = History $ \s -> do a <- m; return (a,s)
instance MonadIO m => MonadIO (HistoryT m) where
liftIO = lift . liftIO
instance Monad m => Functor (HistoryT m) where
fmap f a = History $ \s -> do (a',s') <- runHistoryT a s; return (f a',s')
instance Monad m => Applicative (HistoryT m) where
(<*>) = ap
pure = return
class Monad he => ChHistoryEnv he where
mcounth :: he Int
mgeth :: Int -> he String
mputh :: String -> he ()
instance Monad m => ChHistoryEnv (HistoryT m) where
mcounth = History $ runKleisli (arr length &&& id)
mgeth i
| i <= 0 = let j = i in History $ runKleisli (arr (!!j) &&& id)
| otherwise = History . runKleisli $ arr ((!!i).reverse &&& id)
mputh s = History . runKleisli $ arr (const () &&& (s:))
expandHist :: ChHistoryEnv h => String -> h String
expandHist [] = return []
expandHist ('!':ss) =
let (nm,rm) = (takeWhile isNum &&& dropWhile isNum) ss
isNum a = elem a ['0'..'9'] || (a=='-')
in case nm of
[] -> do
ss' <- expandHist ss
return ('!':ss')
_ -> do
hs <- expandHist rm
h <- mgeth $ read nm
return (h++hs)
expandHist (s:ss) = do ss' <- expandHist ss; return (s:ss')
instance ChExpand m => ChExpand (HistoryT m) where
expand = lift . expand <=< expandHist
withHistory :: Monad m => HistoryT m a -> m a
withHistory = liftM fst . flip runHistoryT []