mirror of
https://github.com/aaronallen8455/graph-trace.git
synced 2024-09-11 09:05:34 +03:00
fix ghc 9 incompatibilities
This commit is contained in:
parent
a0e573bb88
commit
cd64d2069c
@ -32,14 +32,6 @@ import Graph.Trace.Internal.Types
|
||||
import qualified Graph.Trace.Internal.Types as DT
|
||||
import Graph.Trace.Internal.Trace as Trace
|
||||
|
||||
-- import qualified Debug.Trace as D
|
||||
|
||||
-- TODO If more than one application is running at once, will need to use
|
||||
-- different names for log files. There may be a way to query what the name of
|
||||
-- the running application is, otherwise it could be a plugin argument. Looks
|
||||
-- like you can get the package name from the CallStack, so maybe that will
|
||||
-- work? Probably not since the MVar is defined in the plugin package.
|
||||
|
||||
plugin :: Ghc.Plugin
|
||||
plugin =
|
||||
Ghc.defaultPlugin
|
||||
@ -185,8 +177,7 @@ modifyClsInstDecl debugNames nameMap
|
||||
= do
|
||||
newBinds <- modifyBinds nameMap (entryName debugNames) binds
|
||||
pure inst { Ghc.cid_binds = newBinds }
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#else
|
||||
#if !(MIN_VERSION_ghc(9,0,0))
|
||||
modifyClsInstDecl _ _ x = pure x
|
||||
#endif
|
||||
|
||||
@ -286,7 +277,7 @@ modifyBinding
|
||||
-> Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn
|
||||
-> StateT (S.Set Ghc.Name) Ghc.TcM (Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn)
|
||||
modifyBinding nameMap entryName
|
||||
bnd@Ghc.FunBind { Ghc.fun_id = Ghc.L loc name
|
||||
bnd@Ghc.FunBind { Ghc.fun_id = Ghc.L' loc name
|
||||
, Ghc.fun_matches = mg@(Ghc.MG _ alts _) }
|
||||
| Just (mUserKey, prop) <- M.lookup name nameMap
|
||||
= do
|
||||
@ -439,14 +430,11 @@ updateDebugIpInFunBind whereVarName
|
||||
= mtch{Ghc.m_grhss =
|
||||
g{Ghc.grhssGRHSs = fmap (updateDebugIPInGRHS whereVarName) <$> grhss }
|
||||
}
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#else
|
||||
#if !(MIN_VERSION_ghc(9,0,0))
|
||||
updateMatch x = x
|
||||
#endif
|
||||
updateDebugIpInFunBind _ b = b
|
||||
|
||||
-- TODO have some warning when optimizations are turned on.
|
||||
|
||||
-- | Produce the contents of the where binding that contains the new debug IP
|
||||
-- value, generated by creating a new ID and pairing it with the old one.
|
||||
-- The ID is randomly generated. Could instead have a global ID sequence but
|
||||
@ -459,7 +447,7 @@ mkNewIpExpr
|
||||
-> Ghc.TcM (Ghc.LHsExpr Ghc.GhcRn)
|
||||
mkNewIpExpr srcSpan newKey newProp = do
|
||||
let mDefSite = case Ghc.srcSpanStart srcSpan of
|
||||
Ghc.RealSrcLoc loc ->
|
||||
Ghc.RealSrcLoc' loc ->
|
||||
Just SrcCodeLoc
|
||||
{ srcModule = Ghc.unpackFS $ Ghc.srcLocFile loc
|
||||
, srcLine = Ghc.srcLocLine loc
|
||||
@ -527,8 +515,7 @@ emitEntryEvent emitEntryName (Ghc.GRHS x guards body) =
|
||||
(Ghc.noLocA' . Ghc.HsVar Ghc.NoExtField $ Ghc.noLocA' emitEntryName)
|
||||
)
|
||||
body
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#else
|
||||
#if !(MIN_VERSION_ghc(9,0,0))
|
||||
emitEntryEvent _ x = x
|
||||
#endif
|
||||
|
||||
@ -554,8 +541,7 @@ updateDebugIPInGRHS whereBindName (Ghc.GRHS x guards body)
|
||||
$ Ghc.noLocA' whereBindName
|
||||
)
|
||||
]
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
#else
|
||||
#if !(MIN_VERSION_ghc(9,0,0))
|
||||
updateDebugIPInGRHS _ x = x
|
||||
#endif
|
||||
|
||||
@ -582,8 +568,6 @@ isDebuggerIpCt ct@Ghc.CDictCan{}
|
||||
= True
|
||||
isDebuggerIpCt _ = False
|
||||
|
||||
-- TODO can the solver be replaced by a global IP instance?
|
||||
|
||||
tcPluginSolver :: Ghc.TcPluginSolver
|
||||
tcPluginSolver _ [] wanted = do
|
||||
case filter isDebuggerIpCt wanted of
|
||||
|
@ -15,6 +15,8 @@ module Graph.Trace.Internal.GhcFacade
|
||||
, noLoc'
|
||||
, emptyComments'
|
||||
, pattern HsQualTy'
|
||||
, pattern RealSrcLoc'
|
||||
, pattern L'
|
||||
) where
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
@ -209,3 +211,19 @@ pattern HsQualTy' x lctx body
|
||||
HsQualTy' x Nothing body = HsQualTy x (noLoc []) body
|
||||
HsQualTy' x (Just lctx) body = HsQualTy x lctx body
|
||||
#endif
|
||||
|
||||
pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
pattern RealSrcLoc' loc = RealSrcLoc loc Nothing
|
||||
#else
|
||||
pattern RealSrcLoc' loc = RealSrcLoc loc
|
||||
#endif
|
||||
|
||||
pattern L' :: SrcSpan -> a
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
-> GenLocated (SrcSpanAnn' ann) a
|
||||
pattern L' ss a <- L (SrcSpanAnn _ ss) a
|
||||
#else
|
||||
-> Located a
|
||||
pattern L' ss a <- L ss a
|
||||
#endif
|
||||
|
Loading…
Reference in New Issue
Block a user