diff --git a/elisp/intero.el b/elisp/intero.el --- a/elisp/intero.el +++ b/elisp/intero.el @@ -70,7 +70,11 @@ :group 'haskell) (defcustom intero-package-version - "0.1.28" + (cl-case system-type + ;; Until is fixed: + (windows-nt "0.1.28") + (cygwin "0.1.28") + (t "0.1.29")) "Package version to auto-install. This version does not necessarily have to be the latest version diff --git a/intero.cabal b/intero.cabal --- a/intero.cabal +++ b/intero.cabal @@ -1,7 +1,7 @@ name: intero version: - 0.1.29 + 0.1.30 synopsis: Complete interactive development program for Haskell license: @@ -65,6 +65,7 @@ GhciTypes GhciInfo GhciFind + Intero.Compat Paths_intero build-depends: base < 5, @@ -73,7 +74,7 @@ directory, filepath, -- We permit any 8.0.1.* or 8.0.2.* or 8.2.1 - ghc >= 7.8 && <= 8.2.2, + ghc >= 7.8 && <= 8.4.1, ghc-paths, haskeline, process, diff --git a/src/Completion.hs b/src/Completion.hs --- a/src/Completion.hs +++ b/src/Completion.hs @@ -31,6 +31,7 @@ import FastString import GHC import HscTypes +import Intero.Compat import Name import OccName import Outputable @@ -38,7 +39,6 @@ import TcRnDriver import TcRnTypes (tcg_rdr_env) import TyCoRep -import TyCon import TysWiredIn import Unify import Unique @@ -55,7 +55,7 @@ -- | All the context we need to generate completions for a declaration -- in a module. data Declaration = Declaration - { declarationBind :: !(HsBindLR Name Name) + { declarationBind :: !(HsBindLR StageReaderName StageReaderName) -- ^ The actual declaration, which we use to find holes and -- substitute them with candidate replacements. -- ^ A sample source, which we use merely for debugging. @@ -168,14 +168,14 @@ , holeDeclaration = declaration })) . listify (isJust . getHoleName) . declarationBind - typeAt :: RealSrcSpan -> LHsExpr Id -> Maybe Type + typeAt :: RealSrcSpan -> LHsExpr StageReaderId -> Maybe Type typeAt rs expr = if getLoc expr == RealSrcSpan rs then case expr of L _ (HsVar (L _ i)) -> pure (idType i) _ -> Nothing else Nothing - getHoleName :: LHsExpr Name -> Maybe (OccName, RealSrcSpan) + getHoleName :: LHsExpr StageReaderName -> Maybe (OccName, RealSrcSpan) getHoleName = \case L someSpan (HsUnboundVar (TrueExprHole name)) -> do @@ -419,7 +419,7 @@ u <- get modify (+ 1) pure (makeTypeVariable u "was_Any") - FunTy (TyConApp (tyConFlavour -> "class") _) x -> go x + FunTy (TyConApp (ghc_tyConFlavour -> "class") _) x -> go x ForAllTy _ x -> go x CastTy x _ -> go x FunTy x y -> FunTy <$> (go x) <*> (go y) @@ -443,7 +443,7 @@ GhcMonad m => ParsedModule -> Hole - -> HsExpr RdrName + -> HsExpr StageReaderRdrName -> m (Maybe ParsedModule) tryWellTypedFill pm hole expr = handleSourceError @@ -456,11 +456,11 @@ -- Filling holes in the AST -- | Fill the given hole in the module with the given expression. -fillHole :: ParsedModule -> Hole -> HsExpr RdrName -> ParsedModule +fillHole :: ParsedModule -> Hole -> HsExpr StageReaderRdrName -> ParsedModule fillHole pm hole expr = pm {pm_parsed_source = everywhere (mkT replace) (pm_parsed_source pm)} where - replace :: LHsExpr RdrName -> LHsExpr RdrName + replace :: LHsExpr StageReaderRdrName -> LHsExpr StageReaderRdrName replace = (\case L someSpan _ @@ -471,14 +471,14 @@ -------------------------------------------------------------------------------- -- Helpers -rdrNameToLHsExpr :: id -> GenLocated SrcSpan (HsExpr id) +rdrNameToLHsExpr :: RdrName -> GenLocated SrcSpan (HsExpr StageReaderRdrName) rdrNameToLHsExpr rdrname = L (UnhelpfulSpan (mkFastString "Generated by rdrNameToLHsExpr")) (HsVar (L (UnhelpfulSpan (mkFastString "Generated by getWellTypedFills")) rdrname)) -rdrNameToHsExpr :: id -> HsExpr id +rdrNameToHsExpr :: RdrName -> HsExpr StageReaderRdrName rdrNameToHsExpr rdrname = HsVar (L (UnhelpfulSpan (mkFastString "Generated by rdrNameToHsExpr")) rdrname) @@ -502,7 +502,7 @@ nullLogAction _df _reason _sev _span _style _msgdoc = pure () -- | Convert parsed source groups into one bag of binds. -_parsedModuleToBag :: ParsedModule -> Bag (LHsBindLR RdrName RdrName) +_parsedModuleToBag :: ParsedModule -> Bag (LHsBindLR StageReaderRdrName StageReaderRdrName) _parsedModuleToBag = listToBag . mapMaybe valD . hsmodDecls . unLoc . pm_parsed_source where @@ -512,7 +512,7 @@ _ -> Nothing -- | Convert renamed source groups into one bag of binds. -renamedSourceToBag :: RenamedSource -> Bag (LHsBindLR Name Name) +renamedSourceToBag :: RenamedSource -> Bag (LHsBindLR StageReaderName StageReaderName) renamedSourceToBag (hsGroup, _, _, _) = unHsValBindsLR (hs_valds hsGroup) where unHsValBindsLR = diff --git a/src/GhciFind.hs b/src/GhciFind.hs --- a/src/GhciFind.hs +++ b/src/GhciFind.hs @@ -9,8 +9,9 @@ (findType,FindType(..),findLoc,findNameUses,findCompletions,guessModule) where +import Intero.Compat #if __GLASGOW_HASKELL__ >= 800 -import Module +import Module #endif import Control.Exception #if __GLASGOW_HASKELL__ < 710 @@ -374,7 +375,7 @@ Just name -> case find (reliableNameEquality name) names of Just nameWithBetterType -> - do result <- getInfo True nameWithBetterType + do result <- ghc_getInfo True nameWithBetterType case result of Just (thing,_,_,_) -> return (FindTyThing minfo thing) diff --git a/src/GhciInfo.hs b/src/GhciInfo.hs --- a/src/GhciInfo.hs +++ b/src/GhciInfo.hs @@ -10,25 +10,29 @@ import Control.Exception import Control.Monad import qualified CoreUtils -import DataCon import Data.Data -import Data.Generics (GenericQ, mkQ, extQ) +import qualified Data.Generics import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Time +import DataCon import Desugar import GHC import GhcMonad import GhciTypes -import NameSet +import Intero.Compat import Outputable import Prelude hiding (mod) import System.Directory import TcHsSyn import Var +#if __GLASGOW_HASKELL__ <= 802 +import NameSet +#endif + #if MIN_VERSION_ghc(7,8,3) #else import Bag @@ -95,9 +99,9 @@ => TypecheckedModule -> m [SpanInfo] processAllTypeCheckedModule tcm = do let tcs = tm_typechecked_source tcm - bs = listifyAllSpans tcs :: [LHsBind Id] - es = listifyAllSpans tcs :: [LHsExpr Id] - ps = listifyAllSpans tcs :: [LPat Id] + bs = listifyAllSpans tcs :: [LHsBind StageReaderId] + es = listifyAllSpans tcs :: [LHsExpr StageReaderId] + ps = listifyAllSpans tcs :: [LPat StageReaderId] bts <- mapM (getTypeLHsBind tcm) bs ets <- mapM (getTypeLHsExpr tcm) es pts <- mapM (getTypeLPat tcm) ps @@ -109,7 +113,7 @@ getTypeLHsBind :: (GhcMonad m) => TypecheckedModule - -> LHsBind Id + -> LHsBind StageReaderId -> m [(Maybe Id,SrcSpan,Type)] #if MIN_VERSION_ghc(7,8,3) getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _}) = @@ -133,7 +137,7 @@ getTypeLHsExpr :: (GhcMonad m) => TypecheckedModule - -> LHsExpr Id + -> LHsExpr StageReaderId -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLHsExpr _ e = do hs_env <- getSession @@ -155,7 +159,7 @@ -- | Get id and type for patterns. getTypeLPat :: (GhcMonad m) - => TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type)) + => TypecheckedModule -> LPat StageReaderId -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLPat _ (L spn pat) = return (Just (getMaybeId pat,spn,getPatType pat)) where @@ -177,14 +181,18 @@ where p (L spn _) = isGoodSrcSpan spn listifyStaged :: Typeable r - => Stage -> (r -> Bool) -> GenericQ [r] + => Stage -> (r -> Bool) -> Data.Generics.GenericQ [r] +#if __GLASGOW_HASKELL__ <= 802 listifyStaged s p = everythingStaged s (++) [] - ([] `mkQ` + ([] `Data.Generics.mkQ` (\x -> [x | p x])) +#else +listifyStaged _ p = Data.Generics.listify p +#endif ------------------------------------------------------------------------------ -- The following was taken from 'ghc-syb-utils' @@ -203,9 +211,10 @@ -- | Like 'everything', but avoid known potholes, based on the 'Stage' that -- generated the Ast. -everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r +#if __GLASGOW_HASKELL__ <= 802 +everythingStaged :: Stage -> (r -> r -> r) -> r -> Data.Generics.GenericQ r -> Data.Generics.GenericQ r everythingStaged stage k z f x - | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z + | (const False `Data.Generics.extQ` postTcType `Data.Generics.extQ` fixity `Data.Generics.extQ` nameSet) x = z | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool #if __GLASGOW_HASKELL__ >= 709 @@ -214,6 +223,8 @@ postTcType = const (stage Bool #endif fixity = const (stage Bool +#endif + -- | Pretty print the types into a 'SpanInfo'. toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo diff --git a/src/GhciMonad.hs b/src/GhciMonad.hs --- a/src/GhciMonad.hs +++ b/src/GhciMonad.hs @@ -382,7 +382,7 @@ = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float secs_str = showFFloat (Just 2) secs putStrLn (showSDoc dflags ( - parens (text (secs_str "") <+> text "secs" <> comma <+> + parens (text (secs_str "") <+> text "secs" Outputable.<> comma <+> text (show allocs) <+> text "bytes"))) ----------------------------------------------------------------------------- diff --git a/src/GhciTags.hs b/src/GhciTags.hs --- a/src/GhciTags.hs +++ b/src/GhciTags.hs @@ -16,6 +16,7 @@ import Exception import GHC import GhciMonad +import Intero.Compat import Outputable -- ToDo: figure out whether we need these, and put something appropriate @@ -59,7 +60,7 @@ ghciCreateTagsFile kind file = do createTagsFile kind file --- ToDo: +-- ToDo: -- - remove restriction that all modules must be interpreted -- (problem: we don't know source locations for entities unless -- we compiled the module. @@ -69,7 +70,7 @@ -- createTagsFile :: TagsKind -> FilePath -> GHCi () createTagsFile tagskind tagsFile = do - graph <- GHC.getModuleGraph + graph <- ghc_getModuleGraph mtags <- mapM listModuleTags (map GHC.ms_mod graph) either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags case either_res of @@ -203,4 +204,3 @@ ++ "\x01" ++ show lineNo ++ "," ++ show charPos showETag _ = throwGhcException (CmdLineError "missing source file info in showETag") - diff --git a/src/GhciTypes.hs b/src/GhciTypes.hs --- a/src/GhciTypes.hs +++ b/src/GhciTypes.hs @@ -4,6 +4,7 @@ import Data.Time import GHC +import Intero.Compat import Outputable -- | Info about a module. This information is generated every time a @@ -21,7 +22,7 @@ -- (exports, instances, scope) from a module. ,modinfoLastUpdate :: !UTCTime -- ^ Last time the module was updated. - ,modinfoImports :: ![LImportDecl Name] + ,modinfoImports :: ![LImportDecl StageReaderName] -- ^ Import declarations within this module. ,modinfoLocation :: !SrcSpan -- ^ The location of the module @@ -49,14 +50,14 @@ instance Outputable SpanInfo where ppr (SpanInfo sl sc el ec ty v) = - (int sl <> - text ":" <> - int sc <> - text "-") <> - (int el <> - text ":" <> - int ec <> - text ": ") <> - (ppr v <> - text " :: " <> + (int sl Outputable.<> + text ":" Outputable.<> + int sc Outputable.<> + text "-") Outputable.<> + (int el Outputable.<> + text ":" Outputable.<> + int ec Outputable.<> + text ": ") Outputable.<> + (ppr v Outputable.<> + text " :: " Outputable.<> ppr ty) diff --git a/src/InteractiveUI.hs b/src/InteractiveUI.hs --- a/src/InteractiveUI.hs +++ b/src/InteractiveUI.hs @@ -26,7 +26,9 @@ #include "HsVersions.h" + -- Intero +import Intero.Compat #if __GLASGOW_HASKELL__ >= 800 import GHCi import GHCi.RemoteTypes @@ -40,7 +42,6 @@ import GhciInfo import GhciTypes import GhciFind -import GHC (getModuleGraph) -- GHCi #if __GLASGOW_HASKELL__ >= 800 @@ -943,19 +944,19 @@ r:_ -> do let ix = GHC.resumeHistoryIx r if ix == 0 - then return (brackets (ppr (GHC.resumeSpan r)) <> space) + then return (brackets (ppr (GHC.resumeSpan r)) Outputable.<> space) else do let hist = GHC.resumeHistory r !! (ix-1) pan <- GHC.getHistorySpan hist - return (brackets (ppr (negate ix) <> char ':' - <+> ppr pan) <> space) + return (brackets (ppr (negate ix) Outputable.<> char ':' + <+> ppr pan) Outputable.<> space) let dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty rev_imports = reverse imports -- rightmost are the most recent modules_bit = - hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+> + hsep [ char '*' Outputable.<> ppr m | IIModule m <- rev_imports ] <+> hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ]) -- use the 'as' name if there is one @@ -966,12 +967,12 @@ | otherwise = unLoc (ideclName d) #endif - deflt_prompt = dots <> context_bit <> modules_bit + deflt_prompt = dots Outputable.<> context_bit Outputable.<> modules_bit - f ('%':'l':xs) = ppr (1 + line_number st) <> f xs - f ('%':'s':xs) = deflt_prompt <> f xs - f ('%':'%':xs) = char '%' <> f xs - f (x:xs) = char x <> f xs + f ('%':'l':xs) = ppr (1 + line_number st) Outputable.<> f xs + f ('%':'s':xs) = deflt_prompt Outputable.<> f xs + f ('%':'%':xs) = char '%' Outputable.<> f xs + f (x:xs) = char x Outputable.<> f xs f [] = empty dflags <- getDynFlags @@ -1463,7 +1464,7 @@ infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc infoThing allInfo str = do names <- GHC.parseName str - mb_stuffs <- mapM (GHC.getInfo allInfo) names + mb_stuffs <- mapM (ghc_getInfo allInfo) names let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs) return $ vcat (intersperse (text "") $ map pprInfo filtered) @@ -1557,7 +1558,7 @@ Left _e -> return () Right dir -> changeDirectory [dir] changeDirectory (dir:_) = do - graph <- GHC.getModuleGraph + graph <- ghc_getModuleGraph when (not (null graph)) $ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed." GHC.setTargets [] @@ -1619,9 +1620,9 @@ chooseEditFile = do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x - graph <- GHC.getModuleGraph + graph <- ghc_getModuleGraph failed_graph <- filterM hasFailed graph - let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing + let order g = flattenSCCs $ ghc_topSortModuleGraph True g Nothing pick xs = case xs of x : _ -> GHC.ml_hs_file (GHC.ms_location x) _ -> Nothing @@ -1809,7 +1810,7 @@ case wasok of Succeeded -> do names <- GHC.getRdrNamesInScope - loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name + loaded <- ghc_getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name v <- lift (fmap mod_infos getGHCiState) !newInfos <- collectInfo v loaded lift (modifyGHCiState (\s -> s { mod_infos = newInfos, rdrNamesInScope = names })) @@ -1837,7 +1838,7 @@ targets <- GHC.getTargets case [ m | Just m <- map (findTarget ms) targets ] of [] -> - let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in + let graph' = flattenSCCs (ghc_topSortModuleGraph True ms Nothing) in load_this (last graph') (m:_) -> load_this m @@ -1917,12 +1918,12 @@ let mod_commas | null mods = text "none." | otherwise = hsep ( - punctuate comma (map ppr mods)) <> text "." + punctuate comma (map ppr mods)) Outputable.<> text "." status = case ok of Failed -> text "Failed" Succeeded -> text "Ok" - msg = status <> text ", modules loaded:" <+> mod_commas + msg = status Outputable.<> text ", modules loaded:" <+> mod_commas when (verbosity dflags > 0) $ liftIO $ putStrLn $ showSDocForUser dflags unqual msg @@ -2682,10 +2683,10 @@ dflags <- getDynFlags let opts = options st liftIO $ putStrLn (showSDoc dflags ( - text "options currently set: " <> + text "options currently set: " Outputable.<> if null opts then text "none." - else hsep (map (\o -> char '+' <> text (optToStr o)) opts) + else hsep (map (\o -> char '+' Outputable.<> text (optToStr o)) opts) )) getDynFlags >>= liftIO . showDynFlags show_all @@ -2714,10 +2715,10 @@ where is_on = test f dflags quiet = not show_all && test f default_dflags == is_on - default_dflags = defaultDynFlags (settings dflags) + default_dflags = ghc_defaultDynFlags (settings dflags) - fstr str = text "-f" <> text str - fnostr str = text "-fno-" <> text str + fstr str = text "-f" Outputable.<> text str + fnostr str = text "-fno-" Outputable.<> text str #if __GLASGOW_HASKELL__ < 709 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs) @@ -2987,7 +2988,7 @@ getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary] getLoadedModules = do - graph <- GHC.getModuleGraph + graph <- ghc_getModuleGraph filterM (GHC.isLoaded . GHC.ms_mod_name) graph showBindings :: GHCi () @@ -3002,7 +3003,7 @@ where makeDoc (AnId i) = pprTypeAndContents i makeDoc tt = do - mb_stuff <- GHC.getInfo False (getName tt) + mb_stuff <- ghc_getInfo False (getName tt) return $ maybe (text "") pprTT mb_stuff pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc @@ -3029,7 +3030,7 @@ printForUser stdout $ vcat (map pp_resume (reverse resumes)) where pp_resume res = - ptext (sLit "--> ") <> text (GHC.resumeStmt res) + ptext (sLit "--> ") Outputable.<> text (GHC.resumeStmt res) $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res)) showPackages :: GHCi () @@ -3087,7 +3088,7 @@ showLanguages' :: Bool -> DynFlags -> IO () showLanguages' show_all dflags = putStrLn $ showSDoc dflags $ vcat - [ text "base language is: " <> + [ text "base language is: " Outputable.<> case language dflags of Nothing -> text "Haskell2010" Just Haskell98 -> text "Haskell98" @@ -3103,13 +3104,13 @@ setting test (FlagSpec str f _ _) #endif | quiet = empty - | is_on = text "-X" <> text str - | otherwise = text "-XNo" <> text str + | is_on = text "-X" Outputable.<> text str + | otherwise = text "-XNo" Outputable.<> text str where is_on = test f dflags quiet = not show_all && test f default_dflags == is_on default_dflags = - defaultDynFlags (settings dflags) `lang_set` + ghc_defaultDynFlags (settings dflags) `lang_set` case language dflags of Nothing -> Just Haskell2010 other -> other @@ -3223,7 +3224,7 @@ listHomeModules :: String -> GHCi [String] listHomeModules w = do - g <- GHC.getModuleGraph + g <- ghc_getModuleGraph let home_mods = map GHC.ms_mod_name g dflags <- getDynFlags return $ sort $ filter (w `isPrefixOf`) @@ -3439,7 +3440,7 @@ liftIO $ putStrLn $ if null rest then "" else "..." bold :: SDoc -> SDoc -bold c | do_bold = text start_bold <> c <> text end_bold +bold c | do_bold = text start_bold Outputable.<> c Outputable.<> text end_bold | otherwise = c backCmd :: String -> GHCi () @@ -3500,10 +3501,10 @@ (GHC.srcLocLine l, GHC.srcLocCol l) UnhelpfulLoc _ -> - noCanDo name $ text "can't find its location: " <> ppr loc + noCanDo name $ text "can't find its location: " Outputable.<> ppr loc where noCanDo n why = printForUser stdout $ - text "cannot set breakpoint on " <> ppr n <> text ": " <> why + text "cannot set breakpoint on " Outputable.<> ppr n Outputable.<> text ": " Outputable.<> why breakByModule :: Module -> [String] -> GHCi () breakByModule md (arg1:rest) @@ -3541,10 +3542,10 @@ , onBreakCmd = "" } printForUser stdout $ - text "Breakpoint " <> ppr nm <> + text "Breakpoint " Outputable.<> ppr nm Outputable.<> if alreadySet - then text " was already set at " <> ppr pan - else text " activated at " <> ppr pan + then text " was already set at " Outputable.<> ppr pan + else text " activated at " Outputable.<> ppr pan else do printForUser stdout $ text "Breakpoint could not be activated at" <+> ppr pan @@ -3669,17 +3670,17 @@ Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan" Just (_, RealSrcSpan pan) -> listAround pan False UnhelpfulLoc _ -> - noCanDo name $ text "can't find its location: " <> + noCanDo name $ text "can't find its location: " Outputable.<> ppr loc where noCanDo n why = printForUser stdout $ - text "cannot list source code for " <> ppr n <> text ": " <> why + text "cannot list source code for " Outputable.<> ppr n Outputable.<> text ": " Outputable.<> why list2 _other = liftIO $ putStrLn "syntax: :list [ | | ]" listModuleLine :: Module -> Int -> InputT GHCi () listModuleLine modl line = do - graph <- GHC.getModuleGraph + graph <- ghc_getModuleGraph let this = filter ((== modl) . GHC.ms_mod) graph case this of [] -> panic "listModuleLine" @@ -3965,12 +3966,12 @@ (n:_) -> do let modl = ASSERT( isExternalName n ) GHC.nameModule n if not (GHC.isExternalName n) - then noCanDo n $ ppr n <> + then noCanDo n $ ppr n Outputable.<> text " is not defined in an interpreted module" else do is_interpreted <- GHC.moduleIsInterpreted modl if not is_interpreted - then noCanDo n $ text "module " <> ppr modl <> + then noCanDo n $ text "module " Outputable.<> ppr modl Outputable.<> text " is not interpreted" else and_then n diff --git a/src/Intero/Compat.hs b/src/Intero/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Intero/Compat.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE CPP #-} + +-- | Compatibility between GHC API versions. + +module Intero.Compat + ( ghc_getModuleGraph + , ghc_getInfo + , ghc_defaultDynFlags + , ghc_topSortModuleGraph + , ghc_mkWarn + , ghc_mkErr + , ghc_errMsg + , ghc_warnMsg + , ghc_tyConFlavour + , StageReaderName + , StageReaderRdrName + , StageReaderId + ) where + +#if __GLASGOW_HASKELL__ > 800 +import TyCoRep +#endif +import TyCon +#if __GLASGOW_HASKELL__ > 802 +import CmdLineParser +#endif +#if __GLASGOW_HASKELL__ >= 800 +import qualified Data.Graph as SCC +#else +import qualified Digraph as SCC +#endif +import DynFlags +import GHC + +ghc_tyConFlavour :: TyCon -> String +#if __GLASGOW_HASKELL__ > 802 +ghc_tyConFlavour n = + if tyConFlavour n == ClassFlavour + then "class" + else "" +#else +#if __GLASGOW_HASKELL__ > 800 +ghc_tyConFlavour = tyConFlavour +#else +ghc_tyConFlavour _ = "" +#endif +#endif + +ghc_defaultDynFlags :: Settings -> DynFlags +#if __GLASGOW_HASKELL__ <= 802 +ghc_defaultDynFlags = defaultDynFlags +#else +ghc_defaultDynFlags s = defaultDynFlags s [] +#endif + +ghc_getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst])) +#if __GLASGOW_HASKELL__ <= 802 +ghc_getInfo = getInfo +#else +ghc_getInfo x y = fmap (fmap (\(a,b,c,d,_) -> (a,b,c,d))) (getInfo x y) +#endif + +ghc_getModuleGraph :: GhcMonad m => m [ModSummary] +#if __GLASGOW_HASKELL__ <= 802 +ghc_getModuleGraph = GHC.getModuleGraph +#else +ghc_getModuleGraph = fmap mgModSummaries GHC.getModuleGraph +#endif + +ghc_topSortModuleGraph :: Bool -> [ModSummary] -> Maybe ModuleName -> [SCC.SCC ModSummary] +#if __GLASGOW_HASKELL__ <= 802 +ghc_topSortModuleGraph = GHC.topSortModuleGraph +#else +ghc_topSortModuleGraph bool sums may = GHC.topSortModuleGraph bool (mkModuleGraph sums) may +#endif + +#if __GLASGOW_HASKELL__ <= 802 +type StageReaderName = Name +#else +type StageReaderName = GhcRn +#endif + +#if __GLASGOW_HASKELL__ <= 802 +type StageReaderRdrName = RdrName +#else +type StageReaderRdrName = GhcPs +#endif + +#if __GLASGOW_HASKELL__ <= 802 +type StageReaderId = Id +#else +type StageReaderId = GhcTc +#endif + +#if __GLASGOW_HASKELL__ > 802 +ghc_mkWarn :: Located String -> Warn +ghc_mkWarn = Warn CmdLineParser.NoReason +#else +ghc_mkWarn :: a -> a +ghc_mkWarn = id +#endif + +#if __GLASGOW_HASKELL__ > 802 +ghc_mkErr :: Located String -> Err +ghc_mkErr = Err +#else +ghc_mkErr :: a -> a +ghc_mkErr = id +#endif + +#if __GLASGOW_HASKELL__ > 802 +ghc_errMsg :: Err -> Located String +ghc_errMsg = errMsg +#else +ghc_errMsg :: a -> a +ghc_errMsg = id +#endif + +#if __GLASGOW_HASKELL__ > 802 +ghc_warnMsg :: Warn -> Located String +ghc_warnMsg = warnMsg +#else +ghc_warnMsg :: a -> a +ghc_warnMsg = id +#endif diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -25,6 +25,7 @@ -- ghci-ng import qualified GHC.Paths +import Intero.Compat -- Implementations of the various modes (--show-iface, mkdependHS. etc.) import LoadIface ( showIface ) @@ -136,8 +137,8 @@ let flagWarnings = modeFlagWarnings #else (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1' - (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 - let flagWarnings = staticFlagWarnings ++ modeFlagWarnings + (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + let flagWarnings = staticFlagWarnings ++ modeFlagWarnings #endif -- If all we want to do is something like showing the version number @@ -225,7 +226,7 @@ GHC.prettyPrintGhcErrors dflags4 $ do - let flagWarnings' = flagWarnings ++ dynamicFlagWarnings + let flagWarnings' = (map ghc_mkWarn flagWarnings) ++ dynamicFlagWarnings handleSourceError (\e -> do GHC.printException e @@ -266,8 +267,8 @@ liftIO $ dumpPackages dflags6 # if __GLASGOW_HASKELL__ < 802 - when (verbosity dflags6 >= 3) $ do - liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) + when (verbosity dflags6 >= 3) $ do + liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) #endif ---------------- Final sanity checking ----------- @@ -561,14 +562,14 @@ mode = case mModeFlag of Nothing -> doMakeMode Just (m, _) -> m - errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2 + errs = errs1 ++ map ghc_mkErr (map (mkGeneralLocated "on the commandline") errs2) when (not (null errs)) $ throwGhcException #if __GLASGOW_HASKELL__ < 709 $ errorsToGhcException errs #else - $ errorsToGhcException $ map (\(L sp e) -> (show sp, e)) errs + $ errorsToGhcException $ map (\(L sp e) -> (show sp, e)) (map ghc_errMsg errs) #endif - return (mode, flags' ++ leftover, warns) + return (mode, flags' ++ leftover, map ghc_warnMsg warns) type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) @@ -777,13 +778,13 @@ #else availableOptions = map ((:) '-') $ getFlagNames mode_flags ++ - getFlagNames flagsDynamic ++ - (filterUnwantedStatic . getFlagNames $ flagsStatic) ++ - flagsStaticNames - -- this is a hack to get rid of two unwanted entries that get listed - -- as static flags. Hopefully this hack will disappear one day together - -- with static flags - filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"])) + getFlagNames flagsDynamic ++ + (filterUnwantedStatic . getFlagNames $ flagsStatic) ++ + flagsStaticNames + -- this is a hack to get rid of two unwanted entries that get listed + -- as static flags. Hopefully this hack will disappear one day together + -- with static flags + filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"])) #endif getFlagNames opts = map getFlagName opts #if __GLASGOW_HASKELL__ >= 710 @@ -830,7 +831,7 @@ -- the "z-encoded" total. putMsg dflags msg where - x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' + x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int) countFS entries longest has_z [] = (entries, longest, has_z)