module Hint.Base (
MonadInterpreter(..), RunGhc,
GhcError(..), InterpreterError(..), mayFail, catchIE,
InterpreterSession, SessionData(..),
InterpreterState(..), fromState, onState,
InterpreterConfiguration(..),
ImportList(..), ModuleQualification(..), ModuleImport(..),
ModuleName, PhantomModule(..),
findModule, moduleIsLoaded,
withDynFlags,
ghcVersion,
debug, showGHC
) where
import Control.Monad.IO.Class
import Control.Monad.Catch as MC
import Data.IORef
import Data.Dynamic
import qualified Data.List
import qualified Hint.GHC as GHC
import Hint.Extension
ghcVersion :: Int
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 (Int -> InterpreterError -> ShowS
[InterpreterError] -> ShowS
InterpreterError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InterpreterError] -> ShowS
$cshowList :: [InterpreterError] -> ShowS
show :: InterpreterError -> String
$cshow :: InterpreterError -> String
showsPrec :: Int -> InterpreterError -> ShowS
$cshowsPrec :: Int -> InterpreterError -> ShowS
Show, Typeable)
data InterpreterState = St {
InterpreterState -> [PhantomModule]
activePhantoms :: [PhantomModule],
InterpreterState -> [PhantomModule]
zombiePhantoms :: [PhantomModule],
InterpreterState -> Maybe String
phantomDirectory :: Maybe FilePath,
InterpreterState -> PhantomModule
hintSupportModule :: PhantomModule,
InterpreterState -> Maybe PhantomModule
importQualHackMod :: Maybe PhantomModule,
InterpreterState -> [ModuleImport]
qualImports :: [ModuleImport],
InterpreterState -> [(Extension, Bool)]
defaultExts :: [(Extension, Bool)],
InterpreterState -> InterpreterConfiguration
configuration :: InterpreterConfiguration
}
data ImportList = NoImportList | ImportList [String] | HidingList [String]
deriving (ImportList -> ImportList -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportList -> ImportList -> Bool
$c/= :: ImportList -> ImportList -> Bool
== :: ImportList -> ImportList -> Bool
$c== :: ImportList -> ImportList -> Bool
Eq, Int -> ImportList -> ShowS
[ImportList] -> ShowS
ImportList -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImportList] -> ShowS
$cshowList :: [ImportList] -> ShowS
show :: ImportList -> String
$cshow :: ImportList -> String
showsPrec :: Int -> ImportList -> ShowS
$cshowsPrec :: Int -> ImportList -> ShowS
Show)
data ModuleQualification = NotQualified | ImportAs String | QualifiedAs (Maybe String)
deriving (ModuleQualification -> ModuleQualification -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleQualification -> ModuleQualification -> Bool
$c/= :: ModuleQualification -> ModuleQualification -> Bool
== :: ModuleQualification -> ModuleQualification -> Bool
$c== :: ModuleQualification -> ModuleQualification -> Bool
Eq, Int -> ModuleQualification -> ShowS
[ModuleQualification] -> ShowS
ModuleQualification -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleQualification] -> ShowS
$cshowList :: [ModuleQualification] -> ShowS
show :: ModuleQualification -> String
$cshow :: ModuleQualification -> String
showsPrec :: Int -> ModuleQualification -> ShowS
$cshowsPrec :: Int -> ModuleQualification -> ShowS
Show)
data ModuleImport = ModuleImport { ModuleImport -> String
modName :: String
, ModuleImport -> ModuleQualification
modQual :: ModuleQualification
, ModuleImport -> ImportList
modImp :: ImportList
} deriving (Int -> ModuleImport -> ShowS
[ModuleImport] -> ShowS
ModuleImport -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleImport] -> ShowS
$cshowList :: [ModuleImport] -> ShowS
show :: ModuleImport -> String
$cshow :: ModuleImport -> String
showsPrec :: Int -> ModuleImport -> ShowS
$cshowsPrec :: Int -> ModuleImport -> ShowS
Show)
data InterpreterConfiguration = Conf {
InterpreterConfiguration -> [String]
searchFilePath :: [FilePath],
InterpreterConfiguration -> [Extension]
languageExts :: [Extension],
InterpreterConfiguration -> Bool
allModsInScope :: Bool
}
type InterpreterSession = SessionData ()
instance Exception InterpreterError
where
displayException :: InterpreterError -> String
displayException (UnknownError String
err) = String
"UnknownError: " forall a. [a] -> [a] -> [a]
++ String
err
displayException (WontCompile [GhcError]
es) = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
Data.List.nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map GhcError -> String
errMsg forall a b. (a -> b) -> a -> b
$ [GhcError]
es
displayException (NotAllowed String
err) = String
"NotAllowed: " forall a. [a] -> [a] -> [a]
++ String
err
displayException (GhcException String
err) = String
"GhcException: " forall a. [a] -> [a] -> [a]
++ String
err
type RunGhc m a =
(forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a)
-> m a
data SessionData a = SessionData {
forall a. SessionData a -> IORef InterpreterState
internalState :: IORef InterpreterState,
forall a. SessionData a -> a
versionSpecific :: a,
forall a. SessionData a -> IORef [GhcError]
ghcErrListRef :: IORef [GhcError],
forall a. SessionData a -> Logger
ghcLogger :: GHC.Logger
}
newtype GhcError = GhcError{GhcError -> String
errMsg :: String} deriving Int -> GhcError -> ShowS
[GhcError] -> ShowS
GhcError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhcError] -> ShowS
$cshowList :: [GhcError] -> ShowS
show :: GhcError -> String
$cshow :: GhcError -> String
showsPrec :: Int -> GhcError -> ShowS
$cshowsPrec :: Int -> GhcError -> ShowS
Show
mapGhcExceptions :: MonadInterpreter m
=> (String -> InterpreterError)
-> m a
-> m a
mapGhcExceptions :: forall (m :: * -> *) a.
MonadInterpreter m =>
(String -> InterpreterError) -> m a -> m a
mapGhcExceptions String -> InterpreterError
buildEx m a
action =
m a
action
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`MC.catch` (\InterpreterError
err -> case InterpreterError
err of
GhcException String
s -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> InterpreterError
buildEx String
s)
InterpreterError
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
err)
catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a
catchIE :: forall (m :: * -> *) a.
MonadInterpreter m =>
m a -> (InterpreterError -> m a) -> m a
catchIE = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MC.catch
type ModuleName = String
fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a
fromState :: forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> a
f = do
IORef InterpreterState
ref_st <- forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession forall a. SessionData a -> IORef InterpreterState
internalState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ InterpreterState -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef InterpreterState
ref_st
onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m ()
onState :: forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState InterpreterState -> InterpreterState
f = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadInterpreter m => ModifySessionRef m a
modifySessionRef forall a. SessionData a -> IORef InterpreterState
internalState InterpreterState -> InterpreterState
f
mayFail :: MonadInterpreter m => m (Maybe a) -> m a
mayFail :: forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail m (Maybe a)
action =
do
Maybe a
maybe_res <- m (Maybe a)
action
[GhcError]
es <- forall (m :: * -> *) a. MonadInterpreter m => ModifySessionRef m a
modifySessionRef forall a. SessionData a -> IORef [GhcError]
ghcErrListRef (forall a b. a -> b -> a
const [])
case (Maybe a
maybe_res, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhcError]
es) of
(Maybe a
Nothing, Bool
True) -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
UnknownError String
"Got no error message"
(Maybe a
Nothing, Bool
False) -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [GhcError] -> InterpreterError
WontCompile (forall a. [a] -> [a]
reverse [GhcError]
es)
(Just a
a, Bool
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
debug :: MonadInterpreter m => String -> m ()
debug :: forall (m :: * -> *). MonadInterpreter m => String -> m ()
debug = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"!! " forall a. [a] -> [a] -> [a]
++)
showGHC :: (MonadInterpreter m, GHC.Outputable a) => a -> m String
showGHC :: forall (m :: * -> *) a.
(MonadInterpreter m, Outputable a) =>
a -> m String
showGHC a
a
= do PrintUnqualified
unqual <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m PrintUnqualified
GHC.getPrintUnqual
forall (m :: * -> *) a.
MonadInterpreter m =>
(DynFlags -> m a) -> m a
withDynFlags forall a b. (a -> b) -> a -> b
$ \DynFlags
df ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String
GHC.showSDocForUser DynFlags
df UnitState
GHC.emptyUnitState PrintUnqualified
unqual (forall a. Outputable a => a -> SDoc
GHC.ppr a
a)
data PhantomModule = PhantomModule{PhantomModule -> String
pmName :: ModuleName, PhantomModule -> String
pmFile :: FilePath}
deriving (PhantomModule -> PhantomModule -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PhantomModule -> PhantomModule -> Bool
$c/= :: PhantomModule -> PhantomModule -> Bool
== :: PhantomModule -> PhantomModule -> Bool
$c== :: PhantomModule -> PhantomModule -> Bool
Eq, Int -> PhantomModule -> ShowS
[PhantomModule] -> ShowS
PhantomModule -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PhantomModule] -> ShowS
$cshowList :: [PhantomModule] -> ShowS
show :: PhantomModule -> String
$cshow :: PhantomModule -> String
showsPrec :: Int -> PhantomModule -> ShowS
$cshowsPrec :: Int -> PhantomModule -> ShowS
Show)
findModule :: MonadInterpreter m => ModuleName -> m GHC.Module
findModule :: forall (m :: * -> *). MonadInterpreter m => String -> m Module
findModule String
mn = forall (m :: * -> *) a.
MonadInterpreter m =>
(String -> InterpreterError) -> m a -> m a
mapGhcExceptions String -> InterpreterError
NotAllowed forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
mod_name forall a. Maybe a
Nothing
where mod_name :: ModuleName
mod_name = String -> ModuleName
GHC.mkModuleName String
mn
moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool
moduleIsLoaded :: forall (m :: * -> *). MonadInterpreter m => String -> m Bool
moduleIsLoaded String
mn = (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). MonadInterpreter m => String -> m Module
findModule String
mn)
forall (m :: * -> *) a.
MonadInterpreter m =>
m a -> (InterpreterError -> m a) -> m a
`catchIE` (\InterpreterError
e -> case InterpreterError
e of
NotAllowed{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
WontCompile{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
InterpreterError
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
e)
withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a
withDynFlags :: forall (m :: * -> *) a.
MonadInterpreter m =>
(DynFlags -> m a) -> m a
withDynFlags DynFlags -> m a
action = do
DynFlags
df <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
DynFlags -> m a
action DynFlags
df