module Language.Glambda.Monad (
Glam, runGlam, prompt, quit,
GlamE, runGlamE, issueError, eitherToGlamE,
GlamM(..),
) where
import Language.Glambda.Globals
import Language.Glambda.Util
import System.Console.Haskeline
import Text.PrettyPrint.ANSI.Leijen
import Control.Monad.Trans.Maybe
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import System.IO
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
newtype Glam a = Glam { unGlam :: MaybeT (StateT Globals (InputT IO)) a }
deriving (Monad, Functor, Applicative, MonadState Globals, MonadIO)
newtype GlamE a = GlamE { unGlamE :: ExceptT Doc Glam a }
deriving (Monad, Functor, Applicative, MonadError Doc)
instance MonadReader Globals GlamE where
ask = GlamE get
local f thing_inside = GlamE $ do
old_globals <- get
put (f old_globals)
result <- unGlamE thing_inside
put old_globals
return result
class GlamM m where
printDoc :: Doc -> m ()
printLine :: Doc -> m ()
instance GlamM Glam where
printDoc = Glam . liftIO . displayIO stdout . toSimpleDoc
printLine = Glam . liftIO . displayIO stdout . toSimpleDoc . (<> hardline)
instance GlamM GlamE where
printDoc = GlamE . lift . printDoc
printLine = GlamE . lift . printLine
prompt :: String -> Glam (Maybe String)
prompt = Glam . lift . lift . getInputLine
quit :: Glam a
quit = do
printLine (text "Good-bye.")
Glam mzero
issueError :: Doc -> GlamE a
issueError = GlamE . throwError
eitherToGlamE :: Either String a -> GlamE a
eitherToGlamE (Left err) = issueError (text err)
eitherToGlamE (Right x) = return x
runGlam :: Glam () -> InputT IO ()
runGlam thing_inside
= ignore $ flip evalStateT emptyGlobals $ runMaybeT $ unGlam thing_inside
runGlamE :: GlamE a -> Glam (Either Doc a)
runGlamE thing_inside
= runExceptT $ unGlamE thing_inside