diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -12,3 +12,4 @@ Bryan O'Sullivan Conrad Parker Mark Wright +Bertram Felgenhauer diff --git a/Changes b/Changes --- a/Changes +++ b/Changes @@ -1,3 +1,7 @@ +- ver 0.3.3.5 + * Works on GHC 7.4.6 + * Cleans up files for phantom modules that were left behind (thanks to Beltram Felgenhauer) + - ver 0.3.3.4 * Works on GHC 7.4.1 diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,5 +1,5 @@ name: hint -version: 0.3.3.4 +version: 0.3.3.5 description: This library defines an @Interpreter@ monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -56,7 +56,7 @@ } if !os(windows) { - build-depends: unix >= 2.2.0.0 && < 2.6 + build-depends: unix >= 2.2.0.0 } exposed-modules: Language.Haskell.Interpreter diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -156,11 +156,15 @@ GhcException s -> throwError (buildEx s) _ -> throwError err) +#if __GLASGOW_HASKELL__ < 704 type GhcErrLogger = GHC.Severity -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> IO () +#else +type GhcErrLogger = GHC.LogAction +#endif -- | Module names are _not_ filepaths. type ModuleName = String diff --git a/src/Hint/Compat.hs b/src/Hint/Compat.hs --- a/src/Hint/Compat.hs +++ b/src/Hint/Compat.hs @@ -34,8 +34,7 @@ getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.Module]) getContext = fmap (\(as,bs) -> (as,map fst bs)) GHC.getContext -#else -#if __GLASGOW_HASKELL__ < 704 +#elif __GLASGOW_HASKELL__ < 704 -- Keep setContext/getContext unmodified for use where the results of getContext -- are simply restored by setContext, in which case we don't really care about the -- particular type of b. @@ -48,7 +47,7 @@ #else setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.RdrName] -> m () setContext ms ds = - let ms' = map GHC.IIModule ms + let ms' = map modToIIMod ms ds' = map GHC.IIDecl ds is = ms' ++ ds' in GHC.setContext is @@ -61,9 +60,21 @@ GHC.InteractiveImport -> m ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) f (ns, ds) i = case i of - (GHC.IIDecl d) -> return (ns, (d:ds)) - (GHC.IIModule n) -> return ((n:ns), ds) + (GHC.IIDecl d) -> return (ns, (d:ds)) + m@(GHC.IIModule _) -> do n <- iiModToMod m; return ((n:ns), ds) + + +modToIIMod :: GHC.Module -> GHC.InteractiveImport +iiModToMod :: GHC.GhcMonad m => GHC.InteractiveImport -> m GHC.Module +#if __GLASGOW_HASKELL__ < 706 +modToIIMod = GHC.IIModule +iiModToMod (GHC.IIModule m) = return m +#else +modToIIMod = GHC.IIModule . GHC.moduleName +iiModToMod (GHC.IIModule m) = GHC.findModule m Nothing #endif +iiModToMod _ = error "iiModToMod!" + #endif mkPState = GHC.mkPState @@ -220,3 +231,20 @@ #endif +#if __GLASGOW_HASKELL__ >= 706 + -- why did they have to add a DynFlag to each showSDocXXX function.... (sigh) +showSDoc = GHC.showSDoc GHC.tracingDynFlags -- hack! +showSDocForUser = GHC.showSDocForUser GHC.tracingDynFlags -- hack! +showSDocUnqual = GHC.showSDocUnqual +#else +showSDoc = GHC.showSDoc +showSDocForUser = GHC.showSDocForUser +showSDocUnqual = const GHC.showSDocUnqual +#endif + + +#if __GLASGOW_HASKELL__ >= 706 +mkLocMessage = GHC.mkLocMessage GHC.SevError +#else +mkLocMessage = GHC.mkLocMessage +#endif diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -7,6 +7,7 @@ PhantomModule(..), ModuleText, addPhantomModule, removePhantomModule, getPhantomModules, + cleanPhantomModules, allModulesInContext, onAnEmptyContext, @@ -250,12 +251,11 @@ -- onState (\s ->s{qual_imports = quals}) --- | All imported modules are cleared from the context, and --- loaded modules are unloaded. It is similar to a @:load@ in --- GHCi, but observe that not even the Prelude will be in --- context after a reset. -reset :: MonadInterpreter m => m () -reset = +-- | 'cleanPhantomModules' works like 'reset', but skips the +-- loading of the support module that installs '_show'. Its purpose +-- is to clean up all temporary files generated for phantom modules. +cleanPhantomModules :: MonadInterpreter m => m () +cleanPhantomModules = do -- Remove all modules from context runGhc2 Compat.setContext [] [] -- @@ -277,9 +277,17 @@ import_qual_hack_mod = Nothing, qual_imports = []}) liftIO $ mapM_ (removeFile . pm_file) (old_active ++ old_zombie) - -- - -- Now, install a support module - installSupportModule + +-- | All imported modules are cleared from the context, and +-- loaded modules are unloaded. It is similar to a @:load@ in +-- GHCi, but observe that not even the Prelude will be in +-- context after a reset. +reset :: MonadInterpreter m => m () +reset = do -- clean up context + cleanPhantomModules + -- + -- Now, install a support module + installSupportModule -- Load a phantom module with all the symbols from the prelude we need installSupportModule :: MonadInterpreter m => m () diff --git a/src/Hint/Conversions.hs b/src/Hint/Conversions.hs --- a/src/Hint/Conversions.hs +++ b/src/Hint/Conversions.hs @@ -35,7 +35,7 @@ fromGhcRep t = do -- Unqualify necessary types -- (i.e., do not expose internals) unqual <- runGhc GHC.getPrintUnqual - return $ GHC.showSDocForUser unqual (Compat.pprType t) + return $ Compat.showSDocForUser unqual (Compat.pprType t) parseModule' :: String -> HsModule parseModule' s = case parseModule s of @@ -45,7 +45,7 @@ show failed] instance FromGhcRep_ Compat.Kind String where - fromGhcRep_ (Compat.Kind k) = GHC.showSDoc (Compat.pprKind k) + fromGhcRep_ (Compat.Kind k) = Compat.showSDoc (Compat.pprKind k) -- ---------------- Modules -------------------------- diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -1,7 +1,7 @@ module Hint.GHC ( module GHC, module Outputable, - module ErrUtils, + module ErrUtils, Message, module Pretty, module DriverPhases, module StringBuffer, @@ -38,7 +38,14 @@ import Outputable ( PprStyle, SDoc, ppr, showSDoc, showSDocForUser, showSDocUnqual, withPprStyle, defaultErrStyle ) -import ErrUtils ( Message, mkLocMessage ) + +import ErrUtils ( mkLocMessage ) +#if __GLASGOW_HASKELL__ < 706 +import ErrUtils ( Message ) +#else +import ErrUtils ( MsgDoc ) -- we alias it as Message below +#endif + import Pretty ( Doc ) import DriverPhases ( Phase(Cpp), HscSource(HsSrcFile) ) import StringBuffer ( stringToStringBuffer ) @@ -52,6 +59,14 @@ import DynFlags ( supportedLanguages ) #endif +#if __GLASGOW_HASKELL__ >=704 +import DynFlags ( LogAction ) +#endif + +#if __GLASGOW_HASKELL__ >= 706 +import DynFlags ( tracingDynFlags ) +#endif + #if __GLASGOW_HASKELL__ >= 608 import PprTyThing ( pprTypeForUser ) #elif __GLASGOW_HASKELL__ < 608 @@ -60,4 +75,9 @@ #if __GLASGOW_HASKELL__ >= 702 import SrcLoc ( mkRealSrcLoc ) +#endif + + +#if __GLASGOW_HASKELL__ >= 706 +type Message = MsgDoc #endif diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -161,15 +161,20 @@ ifInterpreterNotRunning $ do s <- newInterpreterSession `catch` rethrowGhcException -- SH.protectHandlers $ execute s (initialize args >> action) - execute s (initialize args >> action) + execute s (initialize args >> action `finally` cleanSession) where rethrowGhcException = throw . GhcException . showGhcEx #if __GLASGOW_HASKELL__ < 610 newInterpreterSession = do s <- liftIO $ Compat.newSession GHC.Paths.libdir newSessionData s + cleanSession = cleanPhantomModules -- clean ghc session, too? #else -- GHC >= 610 newInterpreterSession = newSessionData () + cleanSession = + do cleanPhantomModules + runGhc $ do dflags <- GHC.getSessionDynFlags + GHC.defaultCleanupHandler dflags (return ()) #endif {-# NOINLINE uniqueToken #-} @@ -216,13 +221,20 @@ } mkLogHandler :: IORef [GhcError] -> GhcErrLogger -mkLogHandler r _ src style msg = modifyIORef r (errorEntry :) - where errorEntry = mkGhcError src style msg +mkLogHandler r = compat $ \_ src style msg -> + let errorEntry = mkGhcError src style msg + in modifyIORef r (errorEntry :) + where +#if __GLASGOW_HASKELL__ < 706 + compat = id +#else + compat = const -- cater for the extra DynFlags args +#endif mkGhcError :: GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError mkGhcError src_span style msg = GhcError{errMsg = niceErrMsg} - where niceErrMsg = GHC.showSDoc . GHC.withPprStyle style $ - GHC.mkLocMessage src_span msg + where niceErrMsg = Compat.showSDoc . GHC.withPprStyle style $ + Compat.mkLocMessage src_span msg -- The MonadInterpreter instance diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -50,10 +50,19 @@ do -- parsing failed, so we report it just as all -- other errors get reported.... logger <- fromSession ghcErrLogger - liftIO $ logger GHC.SevError - span - GHC.defaultErrStyle - err +#if __GLASGOW_HASKELL__ >= 706 + dflags <- runGhc GHC.getSessionDynFlags + let logger' = logger dflags + errStyle = GHC.defaultErrStyle dflags +#else + let logger' = logger + errStyle = GHC.defaultErrStyle + +#endif + liftIO $ logger' GHC.SevError + span + errStyle + err -- -- behave like the rest of the GHC API functions -- do on error... diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs --- a/src/Hint/Reflection.hs +++ b/src/Hint/Reflection.hs @@ -12,6 +12,7 @@ import Hint.Base import qualified Hint.GHC as GHC +import qualified Hint.Compat as Compat -- | An Id for a class, a type constructor, a data constructor, a binding, etc type Id = String @@ -37,56 +38,49 @@ do module_ <- findModule mn mod_info <- mayFail $ runGhc1 GHC.getModuleInfo module_ exports <- mapM (runGhc1 GHC.lookupName) (GHC.modInfoExports mod_info) + dflags <- runGhc GHC.getSessionDynFlags -- - return (asModElemList $ catMaybes exports) + return $ asModElemList dflags (catMaybes exports) +asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem] +asModElemList df xs = concat [ + cs', + ts', + ds \\ (concatMap (map Fun . children) ts'), + fs \\ (concatMap (map Fun . children) cs') + ] + where (cs,ts,ds,fs) = + ( #if __GLASGOW_HASKELL__ < 704 -asModElemList :: [GHC.TyThing] -> [ModuleElem] -asModElemList xs = concat [cs', - ts', - ds \\ (concatMap (map Fun . children) ts'), - fs \\ (concatMap (map Fun . children) cs')] - where (cs,ts,ds,fs) = ([asModElem c | c@GHC.AClass{} <- xs], - [asModElem t | t@GHC.ATyCon{} <- xs], - [asModElem d | d@GHC.ADataCon{} <- xs], - [asModElem f | f@GHC.AnId{} <- xs]) - cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs] - ts' = [Data t $ filter (alsoIn ds) dcs | Data t dcs <- ts] - alsoIn es = (`elem` (map name es)) - - -asModElem :: GHC.TyThing -> ModuleElem -asModElem (GHC.AnId f) = Fun $ getUnqualName f -asModElem (GHC.ADataCon dc) = Fun $ getUnqualName dc -asModElem (GHC.ATyCon tc) = Data (getUnqualName tc) - (map getUnqualName $ GHC.tyConDataCons tc) -asModElem (GHC.AClass c) = Class (getUnqualName c) - (map getUnqualName $ GHC.classMethods c) -asModElem _ = error "asModElem: can't happen!" + [asModElem df c | c@GHC.AClass{} <- xs], + [asModElem df t | t@GHC.ATyCon{} <- xs], #else -asModElemList :: [GHC.TyThing] -> [ModuleElem] -asModElemList xs = concat [cs', - ts', - ds \\ (concatMap (map Fun . children) ts'), - fs \\ (concatMap (map Fun . children) cs')] - where (cs,ts,ds,fs) = ([asModElem c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'], - [asModElem t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'], - [asModElem d | d@GHC.ADataCon{} <- xs], - [asModElem f | f@GHC.AnId{} <- xs]) + [asModElem df c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'], + [asModElem df t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'], +#endif + [asModElem df d | d@GHC.ADataCon{} <- xs], + [asModElem df f | f@GHC.AnId{} <- xs] + ) cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs] ts' = [Data t $ filter (alsoIn ds) dcs | Data t dcs <- ts] alsoIn es = (`elem` (map name es)) -asModElem :: GHC.TyThing -> ModuleElem -asModElem (GHC.AnId f) = Fun $ getUnqualName f -asModElem (GHC.ADataCon dc) = Fun $ getUnqualName dc -asModElem (GHC.ATyCon tc) = +asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem +asModElem df (GHC.AnId f) = Fun $ getUnqualName df f +asModElem df (GHC.ADataCon dc) = Fun $ getUnqualName df dc +#if __GLASGOW_HASKELL__ < 704 +asModElem df(GHC.ATyCon tc) = Data (getUnqualName df tc) + (map (getUnqualName df) $ GHC.tyConDataCons tc) +asModElem df (GHC.AClass c) = Class (getUnqualName c) + (map (getUnqualName df) $ GHC.classMethods c) +#else +asModElem df (GHC.ATyCon tc) = if GHC.isClassTyCon tc - then Class (getUnqualName tc) (map getUnqualName $ (GHC.classMethods . fromJust . GHC.tyConClass_maybe) tc) - else Data (getUnqualName tc) (map getUnqualName $ GHC.tyConDataCons tc) -asModElem _ = error "asModElem: can't happen!" + then Class (getUnqualName df tc) (map (getUnqualName df) $ (GHC.classMethods . fromJust . GHC.tyConClass_maybe) tc) + else Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc) +asModElem _ _ = error "asModElem: can't happen!" #endif -getUnqualName :: GHC.NamedThing a => a -> String -getUnqualName = GHC.showSDocUnqual . GHC.pprParenSymName +getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String +getUnqualName dfs = Compat.showSDocUnqual dfs . GHC.pprParenSymName