module HERMIT.Shell.Types where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.State
import Control.Monad.Error
import Data.Dynamic
import qualified Data.Map as M
import HERMIT.Context
import HERMIT.Kure
import HERMIT.External
import qualified HERMIT.GHC as GHC
import HERMIT.Kernel.Scoped
import HERMIT.Parser
import HERMIT.PrettyPrinter.Common
import System.IO
data ShellCommand = KernelEffect KernelEffect
| ShellEffect ShellEffect
| QueryFun QueryFun
| MetaCommand MetaCommand
data KernelEffect :: * where
Apply :: (Injection GHC.ModGuts g, Walker HermitC g) => RewriteH g -> KernelEffect
Pathfinder :: (Injection GHC.ModGuts g, Walker HermitC g) => TranslateH g LocalPathH -> KernelEffect
Direction :: Direction -> KernelEffect
BeginScope :: KernelEffect
EndScope :: KernelEffect
Delete :: SAST -> KernelEffect
CorrectnessCritera :: (Injection GHC.ModGuts g, Walker HermitC g) => TranslateH g () -> KernelEffect
deriving Typeable
instance Extern KernelEffect where
type Box KernelEffect = KernelEffect
box i = i
unbox i = i
data ShellEffect :: * where
CLSModify :: (CommandLineState -> IO CommandLineState) -> ShellEffect
deriving Typeable
data QueryFun :: * where
QueryString :: (Injection GHC.ModGuts g, Walker HermitC g)
=> TranslateH g String -> QueryFun
QueryDocH :: (PrettyC -> PrettyH CoreTC -> TranslateH CoreTC DocH) -> QueryFun
Display :: QueryFun
Inquiry :: (CommandLineState -> IO String) -> QueryFun
deriving Typeable
message :: String -> QueryFun
message str = Inquiry (const $ return str)
instance Extern QueryFun where
type Box QueryFun = QueryFun
box i = i
unbox i = i
type RewriteName = String
data MetaCommand
= Resume
| Abort
| Continue
| Diff SAST SAST
| Dump String String Int
| LoadFile ScriptName FilePath
| SaveFile FilePath
| ScriptToRewrite RewriteName ScriptName
| DefineScript ScriptName String
| RunScript ScriptName
| SaveScript FilePath ScriptName
| SeqMeta [MetaCommand]
deriving Typeable
loadAndRun :: FilePath -> MetaCommand
loadAndRun fp = SeqMeta [LoadFile fp fp, RunScript fp]
instance Extern MetaCommand where
type Box MetaCommand = MetaCommand
box i = i
unbox i = i
data VersionCmd = Back
| Step
| Goto Int
| GotoTag String
| AddTag String
deriving Show
instance Extern ShellEffect where
type Box ShellEffect = ShellEffect
box i = i
unbox i = i
data CLException = CLAbort
| CLResume SAST
| CLContinue CommandLineState
| CLError String
instance Error CLException where
strMsg = CLError
newtype CLM m a = CLM { unCLM :: ErrorT CLException (StateT CommandLineState m) a }
deriving (Functor, Applicative, MonadIO, MonadError CLException, MonadState CommandLineState)
instance Monad m => Monad (CLM m) where
return = CLM . return
(CLM m) >>= k = CLM (m >>= unCLM . k)
fail = CLM . throwError . CLError
abort :: Monad m => CLM m ()
abort = throwError CLAbort
resume :: Monad m => SAST -> CLM m ()
resume = throwError . CLResume
continue :: Monad m => CommandLineState -> CLM m ()
continue = throwError . CLContinue
instance MonadTrans CLM where
lift = CLM . lift . lift
instance Monad m => MonadCatch (CLM m) where
catchM m f = do
st <- get
(r,st') <- lift $ runCLM st m
case r of
Left err -> case err of
CLError msg -> f msg
other -> throwError other
Right v -> put st' >> return v
runCLM :: CommandLineState -> CLM m a -> m (Either CLException a, CommandLineState)
runCLM s = flip runStateT s . runErrorT . unCLM
iokm2clm' :: MonadIO m => String -> (a -> CLM m b) -> IO (KureM a) -> CLM m b
iokm2clm' msg ret m = liftIO m >>= runKureM ret (throwError . CLError . (msg ++))
iokm2clm :: MonadIO m => String -> IO (KureM a) -> CLM m a
iokm2clm msg = iokm2clm' msg return
iokm2clm'' :: MonadIO m => IO (KureM a) -> CLM m a
iokm2clm'' = iokm2clm ""
data VersionStore = VersionStore
{ vs_graph :: [(SAST,ExprH,SAST)]
, vs_tags :: [(String,SAST)]
}
newSAST :: ExprH -> SAST -> CommandLineState -> CommandLineState
newSAST expr sast st = st { cl_cursor = sast
, cl_version = (cl_version st) { vs_graph = (cl_cursor st, expr, sast) : vs_graph (cl_version st) }
}
data CommandLineState = CommandLineState
{ cl_cursor :: SAST
, cl_pretty :: PrettyH CoreTC
, cl_pretty_opts :: PrettyOptions
, cl_render :: Handle -> PrettyOptions -> Either String DocH -> IO ()
, cl_height :: Int
, cl_nav :: Bool
, cl_running_script :: Bool
, cl_tick :: TVar (M.Map String Int)
, cl_corelint :: Bool
, cl_diffonly :: Bool
, cl_failhard :: Bool
, cl_window :: PathH
, cl_dict :: Dictionary
, cl_scripts :: [(ScriptName,Script)]
, cl_kernel :: ScopedKernel
, cl_initSAST :: SAST
, cl_version :: VersionStore
}
type ScriptName = String