hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Compatibility with GHC 8.2.1

Browse Source
This commit is contained in:
Ben Gamari 2017-08-19 17:27:08 -04:00
parent 3d9a339869
commit d00e956e4a
10 changed files with 102 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
GhcMod/Exe/Browse.hs
View File

@ -166,4 +166,5 @@ removeForAlls' ty (Just (pre, ftype))
| otherwise = ty | otherwise = ty
showOutputable :: Outputable a => DynFlags -> a -> String showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr showOutputable dflag =
unwords . lines . showPage dflag (styleUnqualified dflag) . ppr

12
GhcMod/Exe/FillSig.hs
View File

@ -116,7 +116,9 @@ getSignature modSum lineNo colNo = do
p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
-- Inspect the parse tree to find the signature -- Inspect the parse tree to find the signature
case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of 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)))))] -> [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] ->
#elif __GLASGOW_HASKELL__ >= 710 #elif __GLASGOW_HASKELL__ >= 710
[L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] -> [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->
@ -133,7 +135,9 @@ getSignature modSum lineNo colNo = do
case Gap.getClass lst of case Gap.getClass lst of
Just (clsName,loc) -> obtainClassInfo minfo clsName loc Just (clsName,loc) -> obtainClassInfo minfo clsName loc
_ -> return Nothing _ -> 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 [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do
#elif __GLASGOW_HASKELL__ >= 708 #elif __GLASGOW_HASKELL__ >= 708
[L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do [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 modSum <- fileModSummaryWithMapping file
p <- G.parseModule modSum p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p 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 ety <- G.exprType expr
#endif
whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $ whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $
\(loc, name, rty, paren) -> \(loc, name, rty, paren) ->
let eArgs = getFnArgs ety let eArgs = getFnArgs ety

12
GhcMod/Exe/Test.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE CPP #-}
module GhcMod.Exe.Test where module GhcMod.Exe.Test where
import Control.Applicative import Control.Applicative
@ -36,6 +38,15 @@ test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do
return "" 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 :: GhcMonad m => String -> m (Maybe SomeException)
runTest fn = do runTest fn = do
res <- runStmt ("quickCheck " ++ fn) RunToCompletion res <- runStmt ("quickCheck " ++ fn) RunToCompletion
@ -43,3 +54,4 @@ runTest fn = do
RunOk [] -> Nothing RunOk [] -> Nothing
RunException se -> Just se RunException se -> Just se
_ -> error "runTest" _ -> error "runTest"
#endif

19
core/GhcMod/Doc.hs
View File

@ -1,8 +1,13 @@
{-# LANGUAGE CPP #-}
module GhcMod.Doc where module GhcMod.Doc where
import GHC import GHC
import GhcMod.Gap (withStyle, showDocWith) import GhcMod.Gap (withStyle, showDocWith)
import Outputable import Outputable
#if __GLASGOW_HASKELL__ >= 802
import DynFlags
#endif
import Pretty (Mode(..)) import Pretty (Mode(..))
showPage :: DynFlags -> PprStyle -> SDoc -> String showPage :: DynFlags -> PprStyle -> SDoc -> String
@ -14,7 +19,17 @@ showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
getStyle :: GhcMonad m => m PprStyle getStyle :: GhcMonad m => m PprStyle
getStyle = do getStyle = do
unqual <- getPrintUnqual unqual <- getPrintUnqual
#if __GLASGOW_HASKELL__ >= 802
dflags <- getDynFlags
return $ mkUserStyle dflags unqual AllTheWay
#else
return $ mkUserStyle unqual AllTheWay return $ mkUserStyle unqual AllTheWay
#endif
styleUnqualified :: PprStyle styleUnqualified :: DynFlags -> PprStyle
styleUnqualified = mkUserStyle neverQualify AllTheWay styleUnqualified dflags =
#if __GLASGOW_HASKELL__ >= 802
mkUserStyle dflags neverQualify AllTheWay
#else
mkUserStyle neverQualify AllTheWay
#endif

14
core/GhcMod/DynFlags.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE CPP #-}
module GhcMod.DynFlags where module GhcMod.DynFlags where
@ -14,6 +16,12 @@ import GhcMod.DynFlagsTH
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Prelude import Prelude
-- For orphans
#if __GLASGOW_HASKELL__ == 802
import Util (OverridingBool(..))
import PprColour
#endif
setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df = setEmptyLogger df =
Gap.setLogAction df $ \_ _ _ _ _ _ -> return () 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| deriveEqDynFlags [d|
eqDynFlags :: DynFlags -> DynFlags -> [[(Bool, String)]] eqDynFlags :: DynFlags -> DynFlags -> [[(Bool, String)]]
eqDynFlags = undefined eqDynFlags = undefined

2
core/GhcMod/DynFlagsTH.hs
View File

@ -76,7 +76,9 @@ deriveEqDynFlags qds = do
] ]
ignoredTypeNames = ignoredTypeNames =
[ "LogAction" [ "LogAction"
, "LogFinaliser"
, "PackageState" , "PackageState"
, "IO"
, "Hooks" , "Hooks"
, "FlushOut" , "FlushOut"
, "FlushErr" , "FlushErr"

20
core/GhcMod/Gap.hs
View File

@ -5,7 +5,7 @@ module GhcMod.Gap (
, mkTarget , mkTarget
, withStyle , withStyle
, GmLogAction , GmLogAction
, setLogAction , GhcMod.Gap.setLogAction
, getSrcSpan , getSrcSpan
, getSrcFile , getSrcFile
, withInteractiveContext , withInteractiveContext
@ -87,6 +87,9 @@ import qualified StringBuffer as SB
#if __GLASGOW_HASKELL__ >= 710 #if __GLASGOW_HASKELL__ >= 710
import CoAxiom (coAxiomTyCon) import CoAxiom (coAxiomTyCon)
#endif #endif
#if __GLASGOW_HASKELL__ >= 802
import IfaceSyn (showToIface)
#endif
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
import FamInstEnv import FamInstEnv
@ -442,7 +445,11 @@ pprInfo m pefas (thing, fixity, insts)
| fx == defaultFixity = Outputable.empty | fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing) | otherwise = ppr fx <+> ppr (getName thing)
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
#if __GLASGOW_HASKELL__ >= 802
pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext showToIface thing')
#else
pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing') pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
#endif
#if __GLASGOW_HASKELL__ >= 710 #if __GLASGOW_HASKELL__ >= 710
pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc }) pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
= pprTyThingInContextLoc (ATyCon rep_tc) = pprTyThingInContextLoc (ATyCon rep_tc)
@ -570,7 +577,12 @@ type GLMatchI = LMatch Id
#endif #endif
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) 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)' -- 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) 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) -- Instance declarations of sort 'instance F G' (no variables)
@ -668,7 +680,11 @@ parseModuleHeader str dflags filename =
#endif #endif
POk pst rdr_module -> POk pst rdr_module ->
#if __GLASGOW_HASKELL__ >= 802
let (warns,_) = getMessages pst dflags in
#else
let (warns,_) = getMessages pst in let (warns,_) = getMessages pst in
#endif
Right (warns, rdr_module) Right (warns, rdr_module)
mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle

9
core/GhcMod/LightGhc.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE CPP #-}
module GhcMod.LightGhc where module GhcMod.LightGhc where
import Control.Monad import Control.Monad
@ -6,7 +8,9 @@ import Data.IORef
import GHC import GHC
import GHC.Paths (libdir) import GHC.Paths (libdir)
#if __GLASGOW_HASKELL__ < 802
import StaticFlags import StaticFlags
#endif
import SysTools import SysTools
import DynFlags import DynFlags
import HscMain import HscMain
@ -17,6 +21,11 @@ import GhcMod.Monad.Types
import GhcMod.DynFlags import GhcMod.DynFlags
import qualified GhcMod.Gap as Gap 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 -- 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. -- out of process GHCI server which has to be shutdown.
newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv

8
core/GhcMod/Pretty.hs
View File

@ -14,6 +14,8 @@
-- You should have received a copy of the GNU Affero General Public License -- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
module GhcMod.Pretty module GhcMod.Pretty
( renderGm ( renderGm
, renderSDoc , renderSDoc
@ -47,8 +49,14 @@ renderSDoc sdoc = do
gmComponentNameDoc :: ChComponentName -> Doc gmComponentNameDoc :: ChComponentName -> Doc
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" 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 "") = text $ "library"
gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n
#endif
gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n
gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n
gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n

20
ghc-mod.cabal
View File

@ -183,7 +183,7 @@ Library
, time , time
, transformers , transformers
, base < 4.10 && >= 4.6.0.1 , base < 4.11 && >= 4.6.0.1
, djinn-ghc < 0.1 && >= 0.0.2.2 , djinn-ghc < 0.1 && >= 0.0.2.2
, extra < 1.6 && >= 1.4 , extra < 1.6 && >= 1.4
, fclabels < 2.1 && >= 2.0 , fclabels < 2.1 && >= 2.0
@ -204,7 +204,7 @@ Library
, transformers-base < 0.5 && >= 0.4.4 , transformers-base < 0.5 && >= 0.4.4
, cabal-helper < 0.8 && >= 0.7.3.0 , cabal-helper < 0.8 && >= 0.7.3.0
, ghc < 8.2 && >= 7.6 , ghc < 8.4 && >= 7.6
if impl(ghc >= 8.0) if impl(ghc >= 8.0)
Build-Depends: ghc-boot Build-Depends: ghc-boot
@ -230,14 +230,14 @@ Executable ghc-mod
, mtl , mtl
, process , process
, base < 4.10 && >= 4.6.0.1 , base < 4.11 && >= 4.6.0.1
, fclabels < 2.1 && >= 2.0 , fclabels < 2.1 && >= 2.0
, monad-control < 1.1 && >= 1 , monad-control < 1.1 && >= 1
, optparse-applicative < 0.14 && >= 0.13.0.0 , optparse-applicative < 0.14 && >= 0.13.0.0
, semigroups < 0.19 && >= 0.10.0 , semigroups < 0.19 && >= 0.10.0
, split < 0.3 && >= 0.2.2 , split < 0.3 && >= 0.2.2
, ghc < 8.2 && >= 7.6 , ghc < 8.4 && >= 7.6
, ghc-mod , ghc-mod
@ -262,7 +262,7 @@ Executable ghc-modi
, process , process
, time , time
, base < 4.10 && >= 4.6.0.1 , base < 4.11 && >= 4.6.0.1
, ghc-mod , ghc-mod
@ -274,7 +274,7 @@ Test-Suite doctest
Ghc-Options: -Wall Ghc-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs 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 , doctest < 0.12 && >= 0.9.3
@ -321,7 +321,7 @@ Test-Suite spec
, process , process
, transformers , transformers
, base < 4.10 && >= 4.6.0.1 , base < 4.11 && >= 4.6.0.1
, fclabels < 2.1 && >= 2.0 , fclabels < 2.1 && >= 2.0
, hspec < 2.4 && >= 2.0.0 , hspec < 2.4 && >= 2.0.0
, monad-journal < 0.8 && >= 0.4 , monad-journal < 0.8 && >= 0.4
@ -336,7 +336,7 @@ Test-Suite spec
Build-Depends: Build-Depends:
cabal-helper < 0.8 && >= 0.7.1.0 cabal-helper < 0.8 && >= 0.7.1.0
, ghc < 8.2 && >= 7.6 , ghc < 8.4 && >= 7.6
, ghc-mod , ghc-mod
@ -346,7 +346,7 @@ Test-Suite shelltest
Hs-Source-Dirs: shelltest Hs-Source-Dirs: shelltest
Type: exitcode-stdio-1.0 Type: exitcode-stdio-1.0
Build-Tools: shelltest Build-Tools: shelltest
Build-Depends: base < 4.10 && >= 4.6.0.1 Build-Depends: base < 4.11 && >= 4.6.0.1
, process < 1.5 , process < 1.5
-- , shelltestrunner >= 1.3.5 -- , shelltestrunner >= 1.3.5
if !flag(shelltest) if !flag(shelltest)
@ -366,7 +366,7 @@ Benchmark criterion
directory directory
, filepath , filepath
, base < 4.10 && >= 4.6.0.1 , base < 4.11 && >= 4.6.0.1
, criterion < 1.2 && >= 1.1.1.0 , criterion < 1.2 && >= 1.1.1.0
, temporary < 1.3 && >= 1.2.0.3 , temporary < 1.3 && >= 1.2.0.3