module Control.Biegunka.Script.Token
(
StreamT
, MonadStream(..)
, Infinite(..), Token
, runStreamT, mapStreamT
, tokens, noTokens, fromList
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Free (Free)
import Control.Monad.Reader (ReaderT(..), MonadReader(..))
import Control.Monad.State (StateT(..), MonadState(..))
import Control.Monad.Trans (MonadTrans(..))
import Data.Void (Void)
import Prelude hiding (head)
newtype StreamT e m a =
StreamT { unStreamT :: Infinite e -> m (Infinite e, a) }
instance Monad m => Functor (StreamT e m) where
fmap = liftM
instance Monad m => Applicative (StreamT e m) where
pure = return
(<*>) = ap
instance Monad m => Monad (StreamT e m) where
return a = StreamT (\xs -> return (xs, a))
StreamT x >>= k = StreamT $ \es -> do
(es', x') <- x es
unStreamT (k x') es'
instance MonadTrans (StreamT e) where
lift ma = StreamT $ \es -> do
a <- ma
return (es, a)
runStreamT :: Monad m => Infinite e -> StreamT e m a -> m a
runStreamT es sema = liftM snd (unStreamT sema es)
mapStreamT :: (m (Infinite e, a) -> n (Infinite e, b)) -> StreamT e m a -> StreamT e n b
mapStreamT f (StreamT g) = StreamT (f . g)
infixr 5 :<
data Infinite a = a :< Infinite a
deriving (Show, Eq, Ord, Functor)
head :: Infinite a -> a
head (a :< _) = a
fromList :: [a] -> Infinite a
fromList = foldr (:<) (error "Control.Biegunka.Script.Token.fromList: supplied list is not infinite")
newtype Token = Token Integer
deriving (Show, Eq, Ord, Enum)
tokens :: Infinite Token
tokens = fromList [Token 0 ..]
noTokens :: Infinite Void
noTokens = error "Control.Biegunka.Script.Token.noTokens: evaluated"
type family IsToken a :: Bool
type instance IsToken Token = True
type instance IsToken Void = False
class Monad m => MonadStream e m | m -> e where
next :: m e
peek :: m e
instance (IsToken e ~ True, Monad m) => MonadStream e (StreamT e m) where
next = StreamT $ \(e :< es) -> return (es, e)
peek = StreamT $ \es -> return (es, head es)
instance (Monad m, MonadStream e m) => MonadStream e (ReaderT r m) where
next = lift next
peek = lift peek
instance (Monad m, MonadStream e m) => MonadStream e (StateT s m) where
next = lift next
peek = lift peek
instance (Functor m, MonadStream e m) => MonadStream e (Free m) where
next = lift next
peek = lift peek
instance (Monad m, MonadReader r m) => MonadReader r (StreamT e m) where
ask = lift ask
local = mapStreamT . local
reader = lift . reader
instance (Monad m, MonadState s m) => MonadState s (StreamT e m) where
get = lift get
put = lift . put