hint 0.9.0.4 → 0.9.0.5
raw patch · 17 files changed
+432/−139 lines, 17 filesdep ~ghcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc
API changes (from Hackage documentation)
Files
- AUTHORS +2/−0
- CHANGELOG.md +4/−0
- README.md +9/−7
- hint.cabal +3/−2
- src/Control/Monad/Ghc.hs +8/−0
- src/Hint/Annotations.hs +11/−4
- src/Hint/Base.hs +5/−22
- src/Hint/Configuration.hs +8/−6
- src/Hint/Context.hs +18/−18
- src/Hint/Conversions.hs +2/−1
- src/Hint/Eval.hs +3/−3
- src/Hint/GHC.hs +321/−38
- src/Hint/InterpreterT.hs +19/−22
- src/Hint/Parsers.hs +7/−7
- src/Hint/Reflection.hs +3/−3
- src/Hint/Typecheck.hs +3/−3
- unit-tests/run-unit-tests.hs +6/−3
AUTHORS view
@@ -2,8 +2,10 @@ Austin Seipp Bertram Felgenhauer+Brandon Chinn Bryan O'Sullivan Carl Howells+Christiaan Baaij Conrad Parker Corentin Dupont Daniel Gorin <jcpetruzza@gmail.com>
CHANGELOG.md view
@@ -1,3 +1,7 @@+### 0.9.0.5++* Support GHC 9.2.1+ ### 0.9.0.4 * Support GHC 9.0.1
README.md view
@@ -22,9 +22,11 @@ {-# LANGUAGE LambdaCase, ScopedTypeVariables, TypeApplications #-} import Control.Exception (throwIO)+ import Control.Monad (when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Writer (execWriterT, tell) import Data.Foldable (for_)+ import Data.List (isPrefixOf) import Data.Typeable (Typeable) import qualified Language.Haskell.Interpreter as Hint @@ -32,23 +34,23 @@ -- Interpret expressions into values: -- -- >>> eval @[Int] "[1,2] ++ [3]"- -- [1,2,3]+ -- Right [1,2,3] -- -- Send values from your compiled program to your interpreted program by -- interpreting a function: --- -- >>> f <- eval @(Int -> [Int]) "\\x -> [1..x]"+ -- >>> Right f <- eval @(Int -> [Int]) "\\x -> [1..x]" -- >>> f 5 -- [1,2,3,4,5] eval :: forall t. Typeable t- => String -> IO t- eval s = runInterpreter $ do+ => String -> IO (Either Hint.InterpreterError t)+ eval s = Hint.runInterpreter $ do Hint.setImports ["Prelude"] Hint.interpret s (Hint.as :: t) -- | -- >>> :{- -- do contents <- browse "Prelude"+ -- do Right contents <- browse "Prelude" -- for_ contents $ \(identifier, tp) -> do -- when ("put" `isPrefixOf` identifier) $ do -- putStrLn $ identifier ++ " :: " ++ tp@@ -56,8 +58,8 @@ -- putChar :: Char -> IO () -- putStr :: String -> IO () -- putStrLn :: String -> IO ()- browse :: Hint.ModuleName -> IO [(String, String)]- browse moduleName = runInterpreter $ do+ browse :: Hint.ModuleName -> IO (Either Hint.InterpreterError [(String, String)])+ browse moduleName = Hint.runInterpreter $ do Hint.setImports ["Prelude", "Data.Typeable", moduleName] exports <- Hint.getModuleExports moduleName execWriterT $ do
hint.cabal view
@@ -1,5 +1,5 @@ name: hint-version: 0.9.0.4+version: 0.9.0.5 description: This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell@@ -60,7 +60,8 @@ library default-language: Haskell2010 build-depends: base == 4.*,- ghc >= 8.4 && < 9.2,+ containers,+ ghc >= 8.4 && < 9.3, ghc-paths, ghc-boot, transformers,
src/Control/Monad/Ghc.hs view
@@ -14,6 +14,9 @@ import Data.IORef import qualified GHC+#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Utils.Logger as GHC+#endif #if MIN_VERSION_ghc(9,0,0) import qualified GHC.Utils.Monad as GHC import qualified GHC.Utils.Exception as GHC@@ -91,6 +94,11 @@ instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (GhcT m) where gcatch = catch gmask = mask+#endif++#if MIN_VERSION_ghc(9,2,0)+instance MonadIO m => GHC.HasLogger (GhcT m) where+ getLogger = GhcT GHC.getLogger #endif instance (Functor m, MonadIO m, MonadCatch m, MonadMask m) => GHC.GhcMonad (GhcT m) where
src/Hint/Annotations.hs view
@@ -9,13 +9,20 @@ import Hint.Base import qualified Hint.GHC as GHC -#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,2,0)+import GHC (ms_mod)+import GHC.Driver.Env (hsc_mod_graph)+#elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Types (hsc_mod_graph, ms_mod)+#else+import HscTypes (hsc_mod_graph, ms_mod)+#endif++#if MIN_VERSION_ghc(9,0,0) import GHC.Types.Annotations import GHC.Utils.Monad (concatMapM) #else import Annotations-import HscTypes (hsc_mod_graph, ms_mod) import MonadUtils (concatMapM) #endif @@ -29,8 +36,8 @@ -- Get the annotations associated with a particular function. getValAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] getValAnnotations _ s = do- names <- runGhc1 GHC.parseName s+ names <- runGhc $ GHC.parseName s concatMapM (anns . NamedTarget) names anns :: (MonadInterpreter m, Data a) => AnnTarget GHC.Name -> m [a]-anns = runGhc1 (GHC.findGlobalAnns deserializeWithData)+anns target = runGhc $ GHC.findGlobalAnns deserializeWithData target
src/Hint/Base.hs view
@@ -3,13 +3,11 @@ GhcError(..), InterpreterError(..), mayFail, catchIE, - InterpreterSession, SessionData(..), GhcErrLogger,+ InterpreterSession, SessionData(..), InterpreterState(..), fromState, onState, InterpreterConfiguration(..), ImportList(..), ModuleQualification(..), ModuleImport(..), - runGhc1, runGhc2,- ModuleName, PhantomModule(..), findModule, moduleIsLoaded, withDynFlags,@@ -99,19 +97,11 @@ (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a) -> m a -type RunGhc1 m a b =- (forall n.(MonadIO n, MonadMask n) => a -> GHC.GhcT n b)- -> (a -> m b)--type RunGhc2 m a b c =- (forall n.(MonadIO n, MonadMask n) => a -> b -> GHC.GhcT n c)- -> (a -> b -> m c)- data SessionData a = SessionData { internalState :: IORef InterpreterState, versionSpecific :: a, ghcErrListRef :: IORef [GhcError],- ghcErrLogger :: GhcErrLogger+ ghcLogger :: GHC.Logger } -- When intercepting errors reported by GHC, we only get a ErrUtils.Message@@ -135,17 +125,9 @@ catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a catchIE = MC.catch -type GhcErrLogger = GHC.LogAction- -- | Module names are _not_ filepaths. 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)- -- ================ Handling the interpreter state ================= fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a@@ -179,7 +161,8 @@ showGHC a = do unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df ->- return $ GHC.showSDocForUser df unqual (GHC.ppr a)+ -- TODO: get unit state from somewhere?+ return $ GHC.showSDocForUser df GHC.emptyUnitState unqual (GHC.ppr a) -- ================ Misc =================================== @@ -189,7 +172,7 @@ findModule :: MonadInterpreter m => ModuleName -> m GHC.Module findModule mn = mapGhcExceptions NotAllowed $- runGhc2 GHC.findModule mod_name Nothing+ runGhc $ GHC.findModule mod_name Nothing where mod_name = GHC.mkModuleName mn moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool
src/Hint/Configuration.hs view
@@ -29,12 +29,13 @@ setGhcOptions :: MonadInterpreter m => [String] -> m () setGhcOptions opts = do old_flags <- runGhc GHC.getSessionDynFlags- (new_flags,not_parsed) <- runGhc2 parseDynamicFlags old_flags opts+ logger <- fromSession ghcLogger+ (new_flags,not_parsed) <- runGhc $ parseDynamicFlags logger old_flags opts unless (null not_parsed) $ throwM $ UnknownError $ concat ["flags: ", unwords $ map quote not_parsed, "not recognized"]- _ <- runGhc1 GHC.setSessionDynFlags new_flags+ _ <- runGhc $ GHC.setSessionDynFlags new_flags return () setGhcOption :: MonadInterpreter m => String -> m ()@@ -137,13 +138,14 @@ configureDynFlags :: GHC.DynFlags -> GHC.DynFlags configureDynFlags dflags =- (if GHC.dynamicGhc then GHC.addWay' GHC.WayDyn else id)+ (if GHC.dynamicGhc then GHC.addWay GHC.WayDyn else id)+ . GHC.setBackendToInterpreter+ $ dflags{GHC.ghcMode = GHC.CompManager,- GHC.hscTarget = GHC.HscInterpreted, GHC.ghcLink = GHC.LinkInMemory, GHC.verbosity = 0} parseDynamicFlags :: GHC.GhcMonad m- => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])-parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc+ => GHC.Logger -> GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])+parseDynamicFlags l d = fmap firstTwo . GHC.parseDynamicFlags l d . map GHC.noLoc where firstTwo (a,b,_) = (a, map GHC.unLoc b)
src/Hint/Context.hs view
@@ -127,11 +127,11 @@ -- we save the context... (old_top, old_imps) <- runGhc getContext --- runGhc1 GHC.addTarget t- res <- runGhc1 GHC.load (GHC.LoadUpTo m)+ runGhc $ GHC.addTarget t+ res <- runGhc $ GHC.load (GHC.LoadUpTo m) -- if isSucceeded res- then do runGhc2 setContext old_top old_imps+ then do runGhc $ setContext old_top old_imps return $ Just () else return Nothing) `catchIE` (\err -> case err of@@ -158,7 +158,7 @@ mod <- findModule (pmName pm) (mods, imps) <- runGhc getContext let mods' = filter (mod /=) mods- runGhc2 setContext mods' imps+ runGhc $ setContext mods' imps -- let isNotPhantom :: GHC.Module -> m Bool isNotPhantom mod' = do@@ -167,12 +167,12 @@ else return True -- let file_name = pmFile pm- runGhc1 GHC.removeTarget (GHC.targetId $ fileTarget file_name)+ runGhc $ GHC.removeTarget (GHC.targetId $ fileTarget file_name) -- onState (\s -> s{activePhantoms = filter (pm /=) $ activePhantoms s}) -- if safeToRemove- then mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets+ then mayFail $ do res <- runGhc $ GHC.load GHC.LoadAllTargets return $ guard (isSucceeded res) >> Just () `finally` do liftIO $ removeFile (pmFile pm) else onState (\s -> s{zombiePhantoms = pm:zombiePhantoms s})@@ -218,10 +218,10 @@ doLoad :: MonadInterpreter m => [String] -> m () doLoad fs = mayFail $ do- targets <- mapM (\f->runGhc2 GHC.guessTarget f Nothing) fs+ targets <- mapM (\f->runGhc $ GHC.guessTarget f Nothing) fs --- runGhc1 GHC.setTargets targets- res <- runGhc1 GHC.load GHC.LoadAllTargets+ runGhc $ GHC.setTargets targets+ res <- runGhc $ GHC.load GHC.LoadAllTargets -- loading the targets removes the support module reinstallSupportModule return $ guard (isSucceeded res) >> Just ()@@ -230,7 +230,7 @@ isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool isModuleInterpreted moduleName = do mod <- findModule moduleName- runGhc1 GHC.moduleIsInterpreted mod+ runGhc $ GHC.moduleIsInterpreted mod -- | Returns the list of modules loaded with 'loadModules'. getLoadedModules :: MonadInterpreter m => m [ModuleName]@@ -245,7 +245,7 @@ getLoadedModSummaries = do modGraph <- runGhc GHC.getModuleGraph let modSummaries = GHC.mgModSummaries modGraph- filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) modSummaries+ filterM (\modl -> runGhc $ GHC.isLoaded $ GHC.ms_mod_name modl) modSummaries -- | Sets the modules whose context is used during evaluation. All bindings -- of these modules are in scope, not only those exported.@@ -263,14 +263,14 @@ active_pms <- fromState activePhantoms ms_mods <- mapM findModule (nub $ ms ++ map pmName active_pms) --- let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted+ let mod_is_interpr modl = runGhc $ GHC.moduleIsInterpreted modl not_interpreted <- filterM (fmap not . mod_is_interpr) ms_mods unless (null not_interpreted) $ throwM $ NotAllowed ("These modules are not interpreted:\n" ++ unlines (map moduleToString not_interpreted)) -- (_, old_imports) <- runGhc getContext- runGhc2 setContext ms_mods old_imports+ runGhc $ setContext ms_mods old_imports -- | Sets the modules whose exports must be in context. --@@ -323,7 +323,7 @@ pure [phantom_mod] (old_top_level, _) <- runGhc getContext let new_top_level = phantom_mods ++ old_top_level- runGhc2 setContextModules new_top_level regularMods+ runGhc $ setContextModules new_top_level regularMods -- onState (\s ->s{qualImports = phantomImports}) where@@ -351,11 +351,11 @@ cleanPhantomModules :: MonadInterpreter m => m () cleanPhantomModules = do -- Remove all modules from context- runGhc2 setContext [] []+ runGhc $ setContext [] [] -- -- Unload all previously loaded modules- runGhc1 GHC.setTargets []- _ <- runGhc1 GHC.load GHC.LoadAllTargets+ runGhc $ GHC.setTargets []+ _ <- runGhc $ GHC.load GHC.LoadAllTargets -- -- At this point, GHCi would call rts_revertCAFs and -- reset the buffering of stdin, stdout and stderr.@@ -392,7 +392,7 @@ installSupportModule = do mod <- addPhantomModule support_module onState (\st -> st{hintSupportModule = mod}) mod' <- findModule (pmName mod)- runGhc2 setContext [mod'] []+ runGhc $ setContext [mod'] [] -- where support_module m = unlines [ "module " ++ m ++ "( ",
src/Hint/Conversions.hs view
@@ -14,7 +14,8 @@ -- (i.e., do not expose internals) unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df ->- return $ GHC.showSDocForUser df unqual (GHC.pprTypeForUser t)+ -- TODO: get unit state from somewhere?+ return $ GHC.showSDocForUser df GHC.emptyUnitState unqual (GHC.pprTypeForUser t) kindToString :: MonadInterpreter m => GHC.Kind -> m String kindToString k
src/Hint/Eval.hs view
@@ -41,7 +41,7 @@ failOnParseError parseExpr expr -- let expr_typesig = concat [parens expr, " :: ", type_str]- expr_val <- mayFail $ runGhc1 compileExpr expr_typesig+ expr_val <- mayFail $ runGhc $ compileExpr expr_typesig -- return (GHC.Exts.unsafeCoerce# expr_val :: a) @@ -65,7 +65,7 @@ -- > runStmt "x <- return 42" -- > runStmt "print x" runStmt :: (MonadInterpreter m) => String -> m ()-runStmt = mayFail . runGhc1 go+runStmt s = mayFail $ runGhc $ go s where go statements = do result <- GHC.execStmt statements GHC.execOptions@@ -81,7 +81,7 @@ -- put the closing parenthesis in a different line. However, now we are -- messing with the layout rules and we don't know where @s@ is going to -- be used!--- Solution: @parens s = \"(let {foo =\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@+-- Solution: @parens s = \"(let {foo =\\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@ parens :: String -> String parens s = concat ["(let {", foo, " =\n", s, "\n", " ;} in ", foo, ")"]
src/Hint/GHC.hs view
@@ -1,74 +1,357 @@ module Hint.GHC (- Message, module X-#if MIN_VERSION_ghc(9,0,0)- , dynamicGhc-#endif+ -- * Shims+ dynamicGhc,+ Message,+ Logger,+ initLogger,+ putLogMsg,+ pushLogHook,+ modifyLogger,+ UnitState,+ emptyUnitState,+ showSDocForUser,+ ParserOpts,+ mkParserOpts,+ initParserState,+ getErrorMessages,+ pprErrorMessages,+ SDocContext,+ defaultSDocContext,+ showGhcException,+ addWay,+ setBackendToInterpreter,+ parseDynamicFlags,+ -- * Re-exports+ module X, ) where -import GHC as X hiding (Phase, GhcT, runGhcT)+import GHC as X hiding (Phase, GhcT, parseDynamicFlags, runGhcT, showGhcException+#if MIN_VERSION_ghc(9,2,0)+ , Logger+ , modifyLogger+ , pushLogHook+#endif+ ) import Control.Monad.Ghc as X (GhcT, runGhcT) -#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Types.SourceError as X (SourceError, srcErrorMessages)++import GHC.Driver.Ppr as X (showSDoc)++import GHC.Types.SourceFile as X (HscSource(HsSrcFile))++import GHC.Utils.Logger as X (LogAction)+import GHC.Platform.Ways as X (Way (..))++import GHC.Types.TyThing.Ppr as X (pprTypeForUser)+#elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Types as X (SourceError, srcErrorMessages, GhcApiError)--- import GHC.Driver.Types as X (mgModSummaries) +import GHC.Utils.Outputable as X (showSDoc)++import GHC.Driver.Phases as X (HscSource(HsSrcFile))++import GHC.Driver.Session as X (LogAction, addWay')+import GHC.Driver.Ways as X (Way (..))++import GHC.Core.Ppr.TyThing as X (pprTypeForUser)+#else+import HscTypes as X (SourceError, srcErrorMessages, GhcApiError)++import Outputable as X (showSDoc)++import DriverPhases as X (HscSource(HsSrcFile))++import DynFlags as X (LogAction, addWay', Way(..))++import PprTyThing as X (pprTypeForUser)+#endif++#if MIN_VERSION_ghc(9,0,0) import GHC.Utils.Outputable as X (PprStyle, SDoc, Outputable(ppr),- showSDoc, showSDocForUser, showSDocUnqual, withPprStyle, defaultErrStyle, vcat) -import GHC.Utils.Error as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc,- errMsgSpan, pprErrMsgBagWithLoc)- -- we alias MsgDoc as Message below+import GHC.Utils.Error as X (mkLocMessage, errMsgSpan) -import GHC.Driver.Phases as X (Phase(Cpp), HscSource(HsSrcFile))+import GHC.Driver.Phases as X (Phase(Cpp)) import GHC.Data.StringBuffer as X (stringToStringBuffer)-import GHC.Parser.Lexer as X (P(..), ParseResult(..), mkPState,- getErrorMessages)+import GHC.Parser.Lexer as X (P(..), ParseResult(..)) import GHC.Parser as X (parseStmt, parseType) import GHC.Data.FastString as X (fsLit) -import GHC.Driver.Session as X (xFlags, xopt, LogAction, FlagSpec(..),- WarnReason(NoReason), addWay')-import GHC.Driver.Ways as X (Way (..), hostIsDynamic)+import GHC.Driver.Session as X (xFlags, xopt, FlagSpec(..), WarnReason(NoReason)) -import GHC.Core.Ppr.TyThing as X (pprTypeForUser) import GHC.Types.SrcLoc as X (combineSrcSpans, mkRealSrcLoc) import GHC.Core.ConLike as X (ConLike(RealDataCon))--dynamicGhc :: Bool-dynamicGhc = hostIsDynamic #else-import HscTypes as X (SourceError, srcErrorMessages, GhcApiError) import HscTypes as X (mgModSummaries) import Outputable as X (PprStyle, SDoc, Outputable(ppr),- showSDoc, showSDocForUser, showSDocUnqual, withPprStyle, defaultErrStyle, vcat) -import ErrUtils as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc-#if __GLASGOW_HASKELL__ >= 810- , errMsgSpan, pprErrMsgBagWithLoc-#endif- ) -- we alias MsgDoc as Message below+import ErrUtils as X (mkLocMessage, errMsgSpan) -import DriverPhases as X (Phase(Cpp), HscSource(HsSrcFile))+import DriverPhases as X (Phase(Cpp)) import StringBuffer as X (stringToStringBuffer)-import Lexer as X (P(..), ParseResult(..), mkPState-#if __GLASGOW_HASKELL__ >= 810- , getErrorMessages-#endif- )+import Lexer as X (P(..), ParseResult(..), mkPState) import Parser as X (parseStmt, parseType) import FastString as X (fsLit) -import DynFlags as X (xFlags, xopt, LogAction, FlagSpec(..),- WarnReason(NoReason), addWay', Way(..), dynamicGhc)+import DynFlags as X (xFlags, xopt, FlagSpec(..), WarnReason(NoReason)) -import PprTyThing as X (pprTypeForUser) import SrcLoc as X (combineSrcSpans, mkRealSrcLoc) import ConLike as X (ConLike(RealDataCon)) #endif -type Message = MsgDoc+{-------------------- Imports for Shims --------------------}++import Control.Monad.IO.Class (MonadIO)++#if MIN_VERSION_ghc(9,2,0)+-- dynamicGhc+import GHC.Platform.Ways (hostIsDynamic)++-- Logger+import qualified GHC.Utils.Logger as GHC (Logger, initLogger, putLogMsg, pushLogHook)+import qualified GHC.Driver.Monad as GHC (modifyLogger)++-- UnitState+import qualified GHC.Unit.State as GHC (UnitState, emptyUnitState)++-- showSDocForUser+import qualified GHC.Driver.Ppr as GHC (showSDocForUser)++-- PState+import qualified GHC.Parser.Lexer as GHC (PState, ParserOpts, mkParserOpts, initParserState)+import GHC.Data.StringBuffer (StringBuffer)+import qualified GHC.Driver.Session as DynFlags (warningFlags, extensionFlags, safeImportsOn)++-- ErrorMessages+import qualified GHC.Parser.Errors.Ppr as GHC (pprError)+import qualified GHC.Parser.Lexer as GHC (getErrorMessages)+import qualified GHC.Types.Error as GHC (ErrorMessages, errMsgDiagnostic, unDecorated)+import GHC.Data.Bag (bagToList)++-- showGhcException+import qualified GHC (showGhcException)+import qualified GHC.Utils.Outputable as GHC (SDocContext, defaultSDocContext)++-- addWay+import qualified GHC.Driver.Session as DynFlags (targetWays_)+import qualified Data.Set as Set++-- parseDynamicFlags+import qualified GHC (parseDynamicFlags)+import GHC.Driver.CmdLine (Warn)+#elif MIN_VERSION_ghc(9,0,0)+-- dynamicGhc+import GHC.Driver.Ways (hostIsDynamic)++-- Message+import qualified GHC.Utils.Error as GHC (MsgDoc)++-- Logger+import qualified GHC.Driver.Session as GHC (defaultLogAction)+import qualified GHC.Driver.Session as DynFlags (log_action)++-- showSDocForUser+import qualified GHC.Utils.Outputable as GHC (showSDocForUser)++-- PState+import qualified GHC.Parser.Lexer as GHC (PState, ParserFlags, mkParserFlags, mkPStatePure)+import GHC.Data.StringBuffer (StringBuffer)++-- ErrorMessages+import qualified GHC.Utils.Error as GHC (ErrorMessages, pprErrMsgBagWithLoc)+import qualified GHC.Parser.Lexer as GHC (getErrorMessages)++-- showGhcException+import qualified GHC (showGhcException)++-- addWay+import qualified GHC.Driver.Session as GHC (addWay')++-- parseDynamicFlags+import qualified GHC (parseDynamicFlags)+import GHC.Driver.CmdLine (Warn)+#else+-- dynamicGhc+import qualified DynFlags as GHC (dynamicGhc)++-- Message+import qualified ErrUtils as GHC (MsgDoc)++-- Logger+import qualified DynFlags as GHC (defaultLogAction)+import qualified DynFlags (log_action)++-- showSDocForUser+import qualified Outputable as GHC (showSDocForUser)++-- PState+import qualified Lexer as GHC (PState, ParserFlags, mkParserFlags, mkPStatePure)+import StringBuffer (StringBuffer)++-- ErrorMessages+import qualified ErrUtils as GHC (ErrorMessages, pprErrMsgBagWithLoc)+#if MIN_VERSION_ghc(8,10,0)+import qualified Lexer as GHC (getErrorMessages)+#else+import Bag (emptyBag)+#endif++-- showGhcException+import qualified GHC (showGhcException)++-- addWay+import qualified DynFlags as GHC (addWay')++-- parseDynamicFlags+import qualified GHC (parseDynamicFlags)+import CmdLineParser (Warn)+#endif++{-------------------- Shims --------------------}++-- dynamicGhc+dynamicGhc :: Bool+#if MIN_VERSION_ghc(9,0,0)+dynamicGhc = hostIsDynamic+#else+dynamicGhc = GHC.dynamicGhc+#endif++-- Message+#if MIN_VERSION_ghc(9,2,0)+type Message = SDoc+#else+type Message = GHC.MsgDoc+#endif++-- Logger+initLogger :: IO Logger+putLogMsg :: Logger -> LogAction+pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger+modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()+#if MIN_VERSION_ghc(9,2,0)+type Logger = GHC.Logger+initLogger = GHC.initLogger+putLogMsg = GHC.putLogMsg+pushLogHook = GHC.pushLogHook+modifyLogger = GHC.modifyLogger+#else+type Logger = LogAction+initLogger = pure GHC.defaultLogAction+putLogMsg = id+pushLogHook = id+modifyLogger f = do+ df <- getSessionDynFlags+ _ <- setSessionDynFlags df{log_action = f $ DynFlags.log_action df}+ return ()+#endif++-- UnitState+emptyUnitState :: UnitState+#if MIN_VERSION_ghc(9,2,0)+type UnitState = GHC.UnitState+emptyUnitState = GHC.emptyUnitState+#else+type UnitState = ()+emptyUnitState = ()+#endif++-- showSDocForUser+showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String+#if MIN_VERSION_ghc(9,2,0)+showSDocForUser = GHC.showSDocForUser+#else+showSDocForUser df _ = GHC.showSDocForUser df+#endif++-- PState+mkParserOpts :: DynFlags -> ParserOpts+initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> GHC.PState+#if MIN_VERSION_ghc(9,2,0)+type ParserOpts = GHC.ParserOpts+mkParserOpts =+ -- adapted from+ -- https://hackage.haskell.org/package/ghc-8.10.2/docs/src/Lexer.html#line-2437+ GHC.mkParserOpts+ <$> DynFlags.warningFlags+ <*> DynFlags.extensionFlags+ <*> DynFlags.safeImportsOn+ <*> gopt Opt_Haddock+ <*> gopt Opt_KeepRawTokenStream+ <*> const True++initParserState = GHC.initParserState+#else+type ParserOpts = GHC.ParserFlags+mkParserOpts = GHC.mkParserFlags++initParserState = GHC.mkPStatePure+#endif++-- ErrorMessages+getErrorMessages :: GHC.PState -> DynFlags -> GHC.ErrorMessages+pprErrorMessages :: GHC.ErrorMessages -> [SDoc]+#if MIN_VERSION_ghc(9,2,0)+getErrorMessages pstate _ = fmap GHC.pprError $ GHC.getErrorMessages pstate+pprErrorMessages = bagToList . fmap pprErrorMessage+ where+ pprErrorMessage = vcat . GHC.unDecorated . GHC.errMsgDiagnostic+#elif MIN_VERSION_ghc(8,10,0)+getErrorMessages = GHC.getErrorMessages+pprErrorMessages = GHC.pprErrMsgBagWithLoc+#else+getErrorMessages _ _ = emptyBag+pprErrorMessages = GHC.pprErrMsgBagWithLoc+#endif++-- SDocContext+defaultSDocContext :: SDocContext+#if MIN_VERSION_ghc(9,2,0)+type SDocContext = GHC.SDocContext+defaultSDocContext = GHC.defaultSDocContext+#else+type SDocContext = ()+defaultSDocContext = ()+#endif++-- showGhcException+showGhcException :: SDocContext -> GhcException -> ShowS+#if MIN_VERSION_ghc(9,2,0)+showGhcException = GHC.showGhcException+#else+showGhcException _ = GHC.showGhcException+#endif++-- addWay+addWay :: Way -> DynFlags -> DynFlags+#if MIN_VERSION_ghc(9,2,0)+addWay way df =+ df+ { targetWays_ = Set.insert way $ DynFlags.targetWays_ df+ }+#else+addWay = GHC.addWay'+#endif++-- setBackendToInterpreter+setBackendToInterpreter :: DynFlags -> DynFlags+#if MIN_VERSION_ghc(9,2,0)+setBackendToInterpreter df = df{backend = Interpreter}+#else+setBackendToInterpreter df = df{hscTarget = HscInterpreted}+#endif++-- parseDynamicFlags+parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn])+#if MIN_VERSION_ghc(9,2,0)+parseDynamicFlags = GHC.parseDynamicFlags+#else+parseDynamicFlags _ = GHC.parseDynamicFlags+#endif
src/Hint/InterpreterT.hs view
@@ -64,11 +64,11 @@ compilationError dynFlags = WontCompile . map (GhcError . GHC.showSDoc dynFlags)- . GHC.pprErrMsgBagWithLoc+ . GHC.pprErrorMessages . GHC.srcErrorMessages showGhcEx :: GHC.GhcException -> String-showGhcEx = flip GHC.showGhcException ""+showGhcEx = flip (GHC.showGhcException GHC.defaultSDocContext) "" -- ================= Executing the interpreter ================== @@ -76,12 +76,14 @@ => [String] -> InterpreterT m () initialize args =- do log_handler <- fromSession ghcErrLogger+ do logger <- fromSession ghcLogger+ runGhc $ GHC.modifyLogger (const logger)+ -- Set a custom log handler, to intercept error messages :S df0 <- runGhc GHC.getSessionDynFlags let df1 = configureDynFlags df0- (df2, extra) <- runGhc2 parseDynamicFlags df1 args+ (df2, extra) <- runGhc $ parseDynamicFlags logger df1 args unless (null extra) $ throwM $ UnknownError (concat [ "flags: '" , unwords extra@@ -89,7 +91,7 @@ -- Observe that, setSessionDynFlags loads info on packages -- available; calling this function once is mandatory!- _ <- runGhc1 GHC.setSessionDynFlags df2{GHC.log_action = log_handler}+ _ <- runGhc $ GHC.setSessionDynFlags df2 let extMap = [ (GHC.flagSpecName flagSpec, GHC.flagSpecFlag flagSpec) | flagSpec <- GHC.xFlags@@ -175,35 +177,30 @@ newSessionData a = do initial_state <- liftIO $ newIORef initialState ghc_err_list_ref <- liftIO $ newIORef []+ logger <- liftIO $ GHC.initLogger return SessionData { internalState = initial_state, versionSpecific = a, ghcErrListRef = ghc_err_list_ref,- ghcErrLogger = mkLogHandler ghc_err_list_ref+ ghcLogger = GHC.pushLogHook (const $ mkLogAction ghc_err_list_ref) logger } -#if MIN_VERSION_ghc(9,0,0)-mkLogHandler :: IORef [GhcError] -> GhcErrLogger-mkLogHandler r df _ _ src msg =- let renderErrMsg = GHC.showSDoc df+mkLogAction :: IORef [GhcError] -> GHC.LogAction+mkLogAction r = mkLogAction' $ \df _ _ src withStyle msg ->+ let renderErrMsg = GHC.showSDoc df . withStyle errorEntry = mkGhcError renderErrMsg src msg in modifyIORef r (errorEntry :)+ where+ mkLogAction' f =+#if MIN_VERSION_ghc(9,0,0)+ \df wr sev src msg -> f df wr sev src id msg+#else+ \df wr sev src style msg -> f df wr sev src (GHC.withPprStyle style) msg+#endif mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.Message -> GhcError mkGhcError render src_span msg = GhcError{errMsg = niceErrMsg} where niceErrMsg = render $ GHC.mkLocMessage GHC.SevError src_span msg-#else-mkLogHandler :: IORef [GhcError] -> GhcErrLogger-mkLogHandler r df _ _ src style msg =- let renderErrMsg = GHC.showSDoc df- errorEntry = mkGhcError renderErrMsg src style msg- in modifyIORef r (errorEntry :)--mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError-mkGhcError render src_span style msg = GhcError{errMsg = niceErrMsg}- where niceErrMsg = render . GHC.withPprStyle style $- GHC.mkLocMessage GHC.SevError src_span msg-#endif -- The MonadInterpreter instance
src/Hint/Parsers.hs view
@@ -24,19 +24,19 @@ -- -- ghc >= 7 panics if noSrcLoc is given let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "<hint>") 1 1- let parse_res = GHC.unP parser (GHC.mkPState dyn_fl buf srcLoc)+ let parserOpts = GHC.mkParserOpts dyn_fl+ let parse_res = GHC.unP parser (GHC.initParserState parserOpts buf srcLoc) -- case parse_res of GHC.POk{} -> return ParseOk ---#if __GLASGOW_HASKELL__ >= 810+#if MIN_VERSION_ghc(8,10,0) GHC.PFailed pst -> let errMsgs = GHC.getErrorMessages pst dyn_fl span = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) GHC.noSrcSpan errMsgs- err = GHC.vcat $ GHC.pprErrMsgBagWithLoc errMsgs+ err = GHC.vcat $ GHC.pprErrorMessages errMsgs in pure (ParseError span err) #else- GHC.PFailed _ span err- -> return (ParseError span err)+ GHC.PFailed _ span err -> return (ParseError span err) #endif failOnParseError :: MonadInterpreter m@@ -51,9 +51,9 @@ ParseError span err -> do -- parsing failed, so we report it just as all -- other errors get reported....- logger <- fromSession ghcErrLogger+ logger <- fromSession ghcLogger dflags <- runGhc GHC.getSessionDynFlags- let logger' = logger dflags+ let logger' = GHC.putLogMsg logger dflags #if !MIN_VERSION_ghc(9,0,0) errStyle = GHC.defaultErrStyle dflags #endif
src/Hint/Reflection.hs view
@@ -30,8 +30,8 @@ getModuleExports :: MonadInterpreter m => ModuleName -> m [ModuleElem] getModuleExports mn = do module_ <- findModule mn- mod_info <- mayFail $ runGhc1 GHC.getModuleInfo module_- exports <- mapM (runGhc1 GHC.lookupName) (GHC.modInfoExports mod_info)+ mod_info <- mayFail $ runGhc $ GHC.getModuleInfo module_+ exports <- mapM (\n -> runGhc $ GHC.lookupName n) (GHC.modInfoExports mod_info) dflags <- runGhc GHC.getSessionDynFlags -- return $ asModElemList dflags (catMaybes exports)@@ -52,4 +52,4 @@ alsoIn es = (`elem` map name es) getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String-getUnqualName dfs = GHC.showSDocUnqual dfs . GHC.pprParenSymName+getUnqualName dfs = GHC.showSDoc dfs . GHC.pprParenSymName
src/Hint/Typecheck.hs view
@@ -18,7 +18,7 @@ -- kind of errors failOnParseError parseExpr expr --- type_ <- mayFail (runGhc1 exprType expr)+ type_ <- mayFail (runGhc $ exprType expr) typeToString type_ -- | Tests if the expression type checks.@@ -45,7 +45,7 @@ -- kind of errors failOnParseError parseType type_expr --- (_, kind) <- mayFail $ runGhc1 typeKind type_expr+ (_, kind) <- mayFail $ runGhc $ typeKind type_expr -- kindToString kind @@ -58,7 +58,7 @@ -- kind of errors failOnParseError parseType type_expr --- (ty, _) <- mayFail $ runGhc1 typeKind type_expr+ (ty, _) <- mayFail $ runGhc $ typeKind type_expr -- typeToString ty
unit-tests/run-unit-tests.hs view
@@ -55,10 +55,13 @@ test_lang_exts :: TestCase test_lang_exts = TestCase "lang_exts" [mod_file] $ do- liftIO $ writeFile mod_file "data T where T :: T"+ liftIO $ writeFile mod_file $ unlines+ [ "data Foo = Foo { a :: Int }"+ , "f Foo{..} = a * 10"+ ] fails do_load @@? "first time, it shouldn't load" --- set [languageExtensions := [GADTs]]+ set [languageExtensions := [RecordWildCards]] succeeds do_load @@? "now, it should load" -- set [languageExtensions := []]@@ -230,7 +233,7 @@ -- is run on an older ghc version. Otherwise this test is not testing what it's -- meant to. test_multiple_instances :: TestCase-test_multiple_instances = TestCase "multiple_instances" ["mod_file"] $ liftIO $ do+test_multiple_instances = TestCase "multiple_instances" [mod_file] $ liftIO $ do writeFile mod_file "f = id" -- ensure the two threads interleave in a deterministic way