module Hint.Base (
MonadInterpreter(..), RunGhc,
GhcError(..), InterpreterError(..), mayFail, catchIE,
InterpreterSession, SessionData(..), GhcErrLogger,
InterpreterState(..), fromState, onState,
InterpreterConfiguration(..),
runGhc1, runGhc2,
ModuleName, PhantomModule(..),
findModule, moduleIsLoaded,
withDynFlags,
ghcVersion,
debug, showGHC
) where
import Control.Monad.Trans
import Control.Monad.Catch as MC
import Data.IORef
import Data.Dynamic
import qualified Hint.GHC as GHC
#if MIN_VERSION_base(4,8,0)
import qualified Data.List
#endif
import Hint.Extension
ghcVersion :: Int
ghcVersion = __GLASGOW_HASKELL__
class (MonadIO m, MonadMask m) => MonadInterpreter m where
fromSession :: FromSession m a
modifySessionRef :: ModifySessionRef m a
runGhc :: RunGhc m a
type FromSession m a = (InterpreterSession -> a) -> m a
type ModifySessionRef m a = (InterpreterSession -> IORef a) -> (a -> a) -> m a
data InterpreterError = UnknownError String
| WontCompile [GhcError]
| NotAllowed String
| GhcException String
deriving (Show, Typeable)
data InterpreterState = St {
activePhantoms :: [PhantomModule],
zombiePhantoms :: [PhantomModule],
hintSupportModule :: PhantomModule,
importQualHackMod :: Maybe PhantomModule,
qualImports :: [(ModuleName, String)],
defaultExts :: [(Extension, Bool)],
configuration :: InterpreterConfiguration
}
data InterpreterConfiguration = Conf {
searchFilePath :: [FilePath],
languageExts :: [Extension],
allModsInScope :: Bool
}
type InterpreterSession = SessionData ()
instance Exception InterpreterError
#if MIN_VERSION_base(4,8,0)
where
displayException (UnknownError err) = "UnknownError: " ++ err
displayException (WontCompile es) = unlines . Data.List.nub . map errMsg $ es
displayException (NotAllowed err) = "NotAllowed: " ++ err
displayException (GhcException err) = "GhcException: " ++ err
#endif
type RunGhc m a =
#if __GLASGOW_HASKELL__ >= 800
(forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a)
#else
(forall n.(MonadIO n, MonadMask n, Functor n) => GHC.GhcT n a)
#endif
-> m a
type RunGhc1 m a b =
#if __GLASGOW_HASKELL__ >= 800
(forall n.(MonadIO n, MonadMask n) => a -> GHC.GhcT n b)
#else
(forall n.(MonadIO n, MonadMask n, Functor n) => a -> GHC.GhcT n b)
#endif
-> (a -> m b)
type RunGhc2 m a b c =
#if __GLASGOW_HASKELL__ >= 800
(forall n.(MonadIO n, MonadMask n) => a -> b -> GHC.GhcT n c)
#else
(forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> GHC.GhcT n c)
#endif
-> (a -> b -> m c)
data SessionData a = SessionData {
internalState :: IORef InterpreterState,
versionSpecific :: a,
ghcErrListRef :: IORef [GhcError],
ghcErrLogger :: GhcErrLogger
}
newtype GhcError = GhcError{errMsg :: String} deriving Show
mapGhcExceptions :: MonadInterpreter m
=> (String -> InterpreterError)
-> m a
-> m a
mapGhcExceptions buildEx action =
action
`MC.catch` (\err -> case err of
GhcException s -> throwM (buildEx s)
_ -> throwM err)
catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a
catchIE = MC.catch
type GhcErrLogger = GHC.LogAction
type ModuleName = String
runGhc1 :: MonadInterpreter m => RunGhc1 m a b
runGhc1 f a = runGhc (f a)
runGhc2 :: MonadInterpreter m => RunGhc2 m a b c
runGhc2 f a = runGhc1 (f a)
fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a
fromState f = do ref_st <- fromSession internalState
liftIO $ f `fmap` readIORef ref_st
onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m ()
onState f = modifySessionRef internalState f >> return ()
mayFail :: MonadInterpreter m => m (Maybe a) -> m a
mayFail action =
do
maybe_res <- action
es <- modifySessionRef ghcErrListRef (const [])
case (maybe_res, null es) of
(Nothing, True) -> throwM $ UnknownError "Got no error message"
(Nothing, False) -> throwM $ WontCompile (reverse es)
(Just a, _) -> return a
debug :: MonadInterpreter m => String -> m ()
debug = liftIO . putStrLn . ("!! " ++)
showGHC :: (MonadInterpreter m, GHC.Outputable a) => a -> m String
showGHC a
= do unqual <- runGhc GHC.getPrintUnqual
withDynFlags $ \df ->
return $ GHC.showSDocForUser df unqual (GHC.ppr a)
data PhantomModule = PhantomModule{pmName :: ModuleName, pmFile :: FilePath}
deriving (Eq, Show)
findModule :: MonadInterpreter m => ModuleName -> m GHC.Module
findModule mn = mapGhcExceptions NotAllowed $
runGhc2 GHC.findModule mod_name Nothing
where mod_name = GHC.mkModuleName mn
moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool
moduleIsLoaded mn = (findModule mn >> return True)
`catchIE` (\e -> case e of
NotAllowed{} -> return False
_ -> throwM e)
withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a
withDynFlags action
= do df <- runGhc GHC.getSessionDynFlags
action df