From d00e956e4a1b698a3818173305d2195d3d1c8ab7 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 19 Aug 2017 17:27:08 -0400 Subject: [PATCH] Compatibility with GHC 8.2.1 --- GhcMod/Exe/Browse.hs | 3 ++- GhcMod/Exe/FillSig.hs | 12 ++++++++++-- GhcMod/Exe/Test.hs | 12 ++++++++++++ core/GhcMod/Doc.hs | 19 +++++++++++++++++-- core/GhcMod/DynFlags.hs | 14 ++++++++++++++ core/GhcMod/DynFlagsTH.hs | 2 ++ core/GhcMod/Gap.hs | 20 ++++++++++++++++++-- core/GhcMod/LightGhc.hs | 9 +++++++++ core/GhcMod/Pretty.hs | 8 ++++++++ ghc-mod.cabal | 20 ++++++++++---------- 10 files changed, 102 insertions(+), 17 deletions(-) diff --git a/GhcMod/Exe/Browse.hs b/GhcMod/Exe/Browse.hs index 069750b..643f487 100644 --- a/GhcMod/Exe/Browse.hs +++ b/GhcMod/Exe/Browse.hs @@ -166,4 +166,5 @@ removeForAlls' ty (Just (pre, ftype)) | otherwise = ty showOutputable :: Outputable a => DynFlags -> a -> String -showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr +showOutputable dflag = + unwords . lines . showPage dflag (styleUnqualified dflag) . ppr diff --git a/GhcMod/Exe/FillSig.hs b/GhcMod/Exe/FillSig.hs index 236f1dc..c8bb925 100644 --- a/GhcMod/Exe/FillSig.hs +++ b/GhcMod/Exe/FillSig.hs @@ -116,7 +116,9 @@ getSignature modSum lineNo colNo = do p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum -- Inspect the parse tree to find the signature case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 802 + [L loc (G.SigD (Ty.TypeSig names (G.HsWC _ (G.HsIB _ (L _ ty) _))))] -> +#elif __GLASGOW_HASKELL__ >= 800 [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] -> #elif __GLASGOW_HASKELL__ >= 710 [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] -> @@ -133,7 +135,9 @@ getSignature modSum lineNo colNo = do case Gap.getClass lst of Just (clsName,loc) -> obtainClassInfo minfo clsName loc _ -> return Nothing -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 802 + [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _ _)))] -> do +#elif __GLASGOW_HASKELL__ >= 800 [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do #elif __GLASGOW_HASKELL__ >= 708 [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do @@ -365,7 +369,11 @@ refine file lineNo colNo (Expression expr) = modSum <- fileModSummaryWithMapping file p <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p +#if __GLASGOW_HASKELL__ >= 802 + ety <- G.exprType G.TM_Inst expr +#else ety <- G.exprType expr +#endif whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, name, rty, paren) -> let eArgs = getFnArgs ety diff --git a/GhcMod/Exe/Test.hs b/GhcMod/Exe/Test.hs index 96eb01c..d390127 100644 --- a/GhcMod/Exe/Test.hs +++ b/GhcMod/Exe/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module GhcMod.Exe.Test where import Control.Applicative @@ -36,6 +38,15 @@ test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do return "" +#if __GLASGOW_HASKELL__ >= 802 +runTest :: GhcMonad m => String -> m (Maybe SomeException) +runTest fn = do + res <- execStmt ("quickCheck " ++ fn) execOptions + return $ case res of + ExecComplete (Right _) _ -> Nothing + ExecComplete (Left se) _ -> Just se + _ -> error "runTest" +#else runTest :: GhcMonad m => String -> m (Maybe SomeException) runTest fn = do res <- runStmt ("quickCheck " ++ fn) RunToCompletion @@ -43,3 +54,4 @@ runTest fn = do RunOk [] -> Nothing RunException se -> Just se _ -> error "runTest" +#endif diff --git a/core/GhcMod/Doc.hs b/core/GhcMod/Doc.hs index 005eaf1..b90e203 100644 --- a/core/GhcMod/Doc.hs +++ b/core/GhcMod/Doc.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE CPP #-} + module GhcMod.Doc where import GHC import GhcMod.Gap (withStyle, showDocWith) import Outputable +#if __GLASGOW_HASKELL__ >= 802 +import DynFlags +#endif import Pretty (Mode(..)) showPage :: DynFlags -> PprStyle -> SDoc -> String @@ -14,7 +19,17 @@ showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style getStyle :: GhcMonad m => m PprStyle getStyle = do unqual <- getPrintUnqual +#if __GLASGOW_HASKELL__ >= 802 + dflags <- getDynFlags + return $ mkUserStyle dflags unqual AllTheWay +#else return $ mkUserStyle unqual AllTheWay +#endif -styleUnqualified :: PprStyle -styleUnqualified = mkUserStyle neverQualify AllTheWay +styleUnqualified :: DynFlags -> PprStyle +styleUnqualified dflags = +#if __GLASGOW_HASKELL__ >= 802 + mkUserStyle dflags neverQualify AllTheWay +#else + mkUserStyle neverQualify AllTheWay +#endif diff --git a/core/GhcMod/DynFlags.hs b/core/GhcMod/DynFlags.hs index 5caa072..2021dcf 100644 --- a/core/GhcMod/DynFlags.hs +++ b/core/GhcMod/DynFlags.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE CPP #-} module GhcMod.DynFlags where @@ -14,6 +16,12 @@ import GhcMod.DynFlagsTH import System.IO.Unsafe (unsafePerformIO) import Prelude +-- For orphans +#if __GLASGOW_HASKELL__ == 802 +import Util (OverridingBool(..)) +import PprColour +#endif + setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ _ -> return () @@ -102,6 +110,12 @@ deferErrors df = return $ ---------------------------------------------------------------- +#if __GLASGOW_HASKELL__ == 802 +deriving instance Eq OverridingBool +deriving instance Eq PprColour.Scheme +deriving instance Eq PprColour.PprColour +#endif + deriveEqDynFlags [d| eqDynFlags :: DynFlags -> DynFlags -> [[(Bool, String)]] eqDynFlags = undefined diff --git a/core/GhcMod/DynFlagsTH.hs b/core/GhcMod/DynFlagsTH.hs index 1b03851..776c588 100644 --- a/core/GhcMod/DynFlagsTH.hs +++ b/core/GhcMod/DynFlagsTH.hs @@ -76,7 +76,9 @@ deriveEqDynFlags qds = do ] ignoredTypeNames = [ "LogAction" + , "LogFinaliser" , "PackageState" + , "IO" , "Hooks" , "FlushOut" , "FlushErr" diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs index 728a04c..dff6b87 100644 --- a/core/GhcMod/Gap.hs +++ b/core/GhcMod/Gap.hs @@ -5,7 +5,7 @@ module GhcMod.Gap ( , mkTarget , withStyle , GmLogAction - , setLogAction + , GhcMod.Gap.setLogAction , getSrcSpan , getSrcFile , withInteractiveContext @@ -87,6 +87,9 @@ import qualified StringBuffer as SB #if __GLASGOW_HASKELL__ >= 710 import CoAxiom (coAxiomTyCon) #endif +#if __GLASGOW_HASKELL__ >= 802 +import IfaceSyn (showToIface) +#endif #if __GLASGOW_HASKELL__ >= 708 import FamInstEnv @@ -442,7 +445,11 @@ pprInfo m pefas (thing, fixity, insts) | fx == defaultFixity = Outputable.empty | otherwise = ppr fx <+> ppr (getName thing) #if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 802 + pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext showToIface thing') +#else pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing') +#endif #if __GLASGOW_HASKELL__ >= 710 pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc }) = pprTyThingInContextLoc (ATyCon rep_tc) @@ -570,7 +577,12 @@ type GLMatchI = LMatch Id #endif getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 802 +-- Instance declarations of sort 'instance F (G a)' +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar _ (L _ className))) _)))) _}))] = Just (className, loc) +-- Instance declarations of sort 'instance F G' (no variables) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar _ (L _ className))) _)) _}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 800 -- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) @@ -668,7 +680,11 @@ parseModuleHeader str dflags filename = #endif POk pst rdr_module -> +#if __GLASGOW_HASKELL__ >= 802 + let (warns,_) = getMessages pst dflags in +#else let (warns,_) = getMessages pst in +#endif Right (warns, rdr_module) mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle diff --git a/core/GhcMod/LightGhc.hs b/core/GhcMod/LightGhc.hs index 3be80e0..146f2c0 100644 --- a/core/GhcMod/LightGhc.hs +++ b/core/GhcMod/LightGhc.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module GhcMod.LightGhc where import Control.Monad @@ -6,7 +8,9 @@ import Data.IORef import GHC import GHC.Paths (libdir) +#if __GLASGOW_HASKELL__ < 802 import StaticFlags +#endif import SysTools import DynFlags import HscMain @@ -17,6 +21,11 @@ import GhcMod.Monad.Types import GhcMod.DynFlags import qualified GhcMod.Gap as Gap +#if __GLASGOW_HASKELL__ >= 802 +initStaticOpts :: Monad m => m () +initStaticOpts = return () +#endif + -- We have to be more careful about tearing down 'HscEnv's since GHC 8 added an -- out of process GHCI server which has to be shutdown. newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv diff --git a/core/GhcMod/Pretty.hs b/core/GhcMod/Pretty.hs index 9f6145b..d273788 100644 --- a/core/GhcMod/Pretty.hs +++ b/core/GhcMod/Pretty.hs @@ -14,6 +14,8 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE CPP #-} + module GhcMod.Pretty ( renderGm , renderSDoc @@ -47,8 +49,14 @@ renderSDoc sdoc = do gmComponentNameDoc :: ChComponentName -> Doc gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" +#if MIN_VERSION_cabal_helper(0,8,0) +gmComponentNameDoc ChLibName = text $ "library" +gmComponentNameDoc (ChSubLibName _)= text $ "library" +gmComponentNameDoc (ChFLibName _) = text $ "flibrary" +#else gmComponentNameDoc (ChLibName "") = text $ "library" gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n +#endif gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n diff --git a/ghc-mod.cabal b/ghc-mod.cabal index e0b4823..f4ab136 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -183,7 +183,7 @@ Library , time , transformers - , base < 4.10 && >= 4.6.0.1 + , base < 4.11 && >= 4.6.0.1 , djinn-ghc < 0.1 && >= 0.0.2.2 , extra < 1.6 && >= 1.4 , fclabels < 2.1 && >= 2.0 @@ -204,7 +204,7 @@ Library , transformers-base < 0.5 && >= 0.4.4 , cabal-helper < 0.8 && >= 0.7.3.0 - , ghc < 8.2 && >= 7.6 + , ghc < 8.4 && >= 7.6 if impl(ghc >= 8.0) Build-Depends: ghc-boot @@ -230,14 +230,14 @@ Executable ghc-mod , mtl , process - , base < 4.10 && >= 4.6.0.1 + , base < 4.11 && >= 4.6.0.1 , fclabels < 2.1 && >= 2.0 , monad-control < 1.1 && >= 1 , optparse-applicative < 0.14 && >= 0.13.0.0 , semigroups < 0.19 && >= 0.10.0 , split < 0.3 && >= 0.2.2 - , ghc < 8.2 && >= 7.6 + , ghc < 8.4 && >= 7.6 , ghc-mod @@ -262,7 +262,7 @@ Executable ghc-modi , process , time - , base < 4.10 && >= 4.6.0.1 + , base < 4.11 && >= 4.6.0.1 , ghc-mod @@ -274,7 +274,7 @@ Test-Suite doctest Ghc-Options: -Wall Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs - Build-Depends: base < 4.10 && >= 4.6.0.1 + Build-Depends: base < 4.11 && >= 4.6.0.1 , doctest < 0.12 && >= 0.9.3 @@ -321,7 +321,7 @@ Test-Suite spec , process , transformers - , base < 4.10 && >= 4.6.0.1 + , base < 4.11 && >= 4.6.0.1 , fclabels < 2.1 && >= 2.0 , hspec < 2.4 && >= 2.0.0 , monad-journal < 0.8 && >= 0.4 @@ -336,7 +336,7 @@ Test-Suite spec Build-Depends: cabal-helper < 0.8 && >= 0.7.1.0 - , ghc < 8.2 && >= 7.6 + , ghc < 8.4 && >= 7.6 , ghc-mod @@ -346,7 +346,7 @@ Test-Suite shelltest Hs-Source-Dirs: shelltest Type: exitcode-stdio-1.0 Build-Tools: shelltest - Build-Depends: base < 4.10 && >= 4.6.0.1 + Build-Depends: base < 4.11 && >= 4.6.0.1 , process < 1.5 -- , shelltestrunner >= 1.3.5 if !flag(shelltest) @@ -366,7 +366,7 @@ Benchmark criterion directory , filepath - , base < 4.10 && >= 4.6.0.1 + , base < 4.11 && >= 4.6.0.1 , criterion < 1.2 && >= 1.1.1.0 , temporary < 1.3 && >= 1.2.0.3