{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Debug.TraceEmbrace.FileIndex where
import Data.IntMap.Strict qualified as IM
import Data.String ( IsString )
import GHC.Data.FastString ( mkFastString )
import GHC.Data.StringBuffer ( stringToStringBuffer )
import GHC.Driver.Config.Parser ( initParserOpts )
import GHC.Driver.DynFlags ( HasDynFlags(..) )
import GHC.Exts (IsList (toList))
import GHC.Hs.Extension (GhcPs)
import GHC.Parser ( parseModule )
import GHC.Parser.Lexer
( ParserOpts,
P(unP),
ParseResult(..),
getPsErrorMessages,
initParserState )
import GHC.Tc.Types ( TcM )
import GHC.Types.Name ( occNameString )
import GHC.Types.Name.Reader ( RdrName(Unqual) )
import GHC.Types.SrcLoc
( GenLocated(L), mkRealSrcLoc, realSrcSpanStart, srcLocLine )
import GHC.Utils.Outputable
( Outputable(ppr), defaultSDocContext, renderWithContext )
import Language.Haskell.Syntax
import Language.Haskell.TH.Syntax (Q (..), runIO, getQ, putQ, Loc (..), Lift, reportWarning)
import Language.Preprocessor.Cpphs (runCpphs, defaultCpphsOptions)
import Unsafe.Coerce ( unsafeCoerce )
#if MIN_VERSION_base(4,21,0)
import GHC.Parser.Annotation (epaLocationRealSrcSpan, SrcSpanAnnA, EpAnn(entry, EpAnn) )
#else
import GHC.Parser.Annotation (anchor, SrcSpanAnnA, EpAnn(entry, EpAnn))
import GHC.Types.SrcLoc (EpaLocation', RealSrcSpan)
epaLocationRealSrcSpan :: EpaLocation' a -> RealSrcSpan
epaLocationRealSrcSpan = anchor
#endif
newtype FunName = FunName { FunName -> String
unFunName :: String } deriving (Int -> FunName -> ShowS
[FunName] -> ShowS
FunName -> String
(Int -> FunName -> ShowS)
-> (FunName -> String) -> ([FunName] -> ShowS) -> Show FunName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FunName -> ShowS
showsPrec :: Int -> FunName -> ShowS
$cshow :: FunName -> String
show :: FunName -> String
$cshowList :: [FunName] -> ShowS
showList :: [FunName] -> ShowS
Show, FunName -> FunName -> Bool
(FunName -> FunName -> Bool)
-> (FunName -> FunName -> Bool) -> Eq FunName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FunName -> FunName -> Bool
== :: FunName -> FunName -> Bool
$c/= :: FunName -> FunName -> Bool
/= :: FunName -> FunName -> Bool
Eq, Eq FunName
Eq FunName =>
(FunName -> FunName -> Ordering)
-> (FunName -> FunName -> Bool)
-> (FunName -> FunName -> Bool)
-> (FunName -> FunName -> Bool)
-> (FunName -> FunName -> Bool)
-> (FunName -> FunName -> FunName)
-> (FunName -> FunName -> FunName)
-> Ord FunName
FunName -> FunName -> Bool
FunName -> FunName -> Ordering
FunName -> FunName -> FunName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FunName -> FunName -> Ordering
compare :: FunName -> FunName -> Ordering
$c< :: FunName -> FunName -> Bool
< :: FunName -> FunName -> Bool
$c<= :: FunName -> FunName -> Bool
<= :: FunName -> FunName -> Bool
$c> :: FunName -> FunName -> Bool
> :: FunName -> FunName -> Bool
$c>= :: FunName -> FunName -> Bool
>= :: FunName -> FunName -> Bool
$cmax :: FunName -> FunName -> FunName
max :: FunName -> FunName -> FunName
$cmin :: FunName -> FunName -> FunName
min :: FunName -> FunName -> FunName
Ord, String -> FunName
(String -> FunName) -> IsString FunName
forall a. (String -> a) -> IsString a
$cfromString :: String -> FunName
fromString :: String -> FunName
IsString, (forall (m :: * -> *). Quote m => FunName -> m Exp)
-> (forall (m :: * -> *). Quote m => FunName -> Code m FunName)
-> Lift FunName
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => FunName -> m Exp
forall (m :: * -> *). Quote m => FunName -> Code m FunName
$clift :: forall (m :: * -> *). Quote m => FunName -> m Exp
lift :: forall (m :: * -> *). Quote m => FunName -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => FunName -> Code m FunName
liftTyped :: forall (m :: * -> *). Quote m => FunName -> Code m FunName
Lift)
type LineFileIndex = IM.IntMap FunName
unsafeRunTcM :: TcM a -> Q a
unsafeRunTcM :: forall a. TcM a -> Q a
unsafeRunTcM TcM a
m = (forall (m :: * -> *). Quasi m => m a) -> Q a
forall a. (forall (m :: * -> *). Quasi m => m a) -> Q a
Q (TcM a -> m a
forall a b. a -> b
unsafeCoerce TcM a
m)
instance HasDynFlags Q where
getDynFlags :: Q DynFlags
getDynFlags = TcM DynFlags -> Q DynFlags
forall a. TcM a -> Q a
unsafeRunTcM TcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
calret :: Monad m => (a -> m ()) -> a -> m a
calret :: forall (m :: * -> *) a. Monad m => (a -> m ()) -> a -> m a
calret a -> m ()
f a
a = a -> m ()
f a
a m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
getLineFileIndex' :: FilePath -> Q LineFileIndex
getLineFileIndex' :: String -> Q LineFileIndex
getLineFileIndex' String
fp = Q (Maybe LineFileIndex)
forall a. Typeable a => Q (Maybe a)
getQ Q (Maybe LineFileIndex)
-> (Maybe LineFileIndex -> Q LineFileIndex) -> Q LineFileIndex
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Q LineFileIndex
-> (LineFileIndex -> Q LineFileIndex)
-> Maybe LineFileIndex
-> Q LineFileIndex
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((LineFileIndex -> Q ()) -> LineFileIndex -> Q LineFileIndex
forall (m :: * -> *) a. Monad m => (a -> m ()) -> a -> m a
calret LineFileIndex -> Q ()
forall a. Typeable a => a -> Q ()
putQ (LineFileIndex -> Q LineFileIndex)
-> Q LineFileIndex -> Q LineFileIndex
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q LineFileIndex
mkLineFunIndex String
fp) LineFileIndex -> Q LineFileIndex
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
getLineFileIndex :: Loc -> Q LineFileIndex
getLineFileIndex :: Loc -> Q LineFileIndex
getLineFileIndex = String -> Q LineFileIndex
getLineFileIndex' (String -> Q LineFileIndex)
-> (Loc -> String) -> Loc -> Q LineFileIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_filename
indexEntry :: EpAnn ann -> GenLocated l RdrName -> [(Int, FunName)]
indexEntry :: forall ann l. EpAnn ann -> GenLocated l RdrName -> [(Int, FunName)]
indexEntry EpAnn {EpaLocation
entry :: forall ann. EpAnn ann -> EpaLocation
entry :: EpaLocation
entry} = \case
L l
_ RdrName
fi ->
case RdrName
fi of
Unqual OccName
s ->
[ ( RealSrcLoc -> Int
srcLocLine (RealSrcSpan -> RealSrcLoc
realSrcSpanStart (EpaLocation -> RealSrcSpan
forall a. EpaLocation' a -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
entry))
, String -> FunName
FunName (String -> FunName) -> String -> FunName
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
s
)
]
RdrName
_ -> []
mkLineFunIndex :: FilePath -> Q LineFileIndex
mkLineFunIndex :: String -> Q LineFileIndex
mkLineFunIndex String
fp = do
fileContent <- IO String -> Q String
forall a. IO a -> Q a
runIO (CpphsOptions -> String -> String -> IO String
runCpphs CpphsOptions
defaultCpphsOptions String
fp (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
fp)
ops <- initParserOpts <$> getDynFlags
case runParser fp ops fileContent parseModule of
POk PState
_ (L SrcSpan
_ HsModule GhcPs
r) ->
LineFileIndex -> Q LineFileIndex
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LineFileIndex -> Q LineFileIndex)
-> LineFileIndex -> Q LineFileIndex
forall a b. (a -> b) -> a -> b
$ [(Int, FunName)] -> LineFileIndex
forall a. [(Int, a)] -> IntMap a
IM.fromList ((GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [(Int, FunName)])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [(Int, FunName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [(Int, FunName)]
extract (HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
r))
PFailed PState
ps -> do
String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
String
"Failed to parse [" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fp String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"] for line function index due: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (Messages PsMessage -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Messages PsMessage -> SDoc) -> Messages PsMessage -> SDoc
forall a b. (a -> b) -> a -> b
$ PState -> Messages PsMessage
getPsErrorMessages PState
ps) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
String
"\n--------------------------------------------------------------------"
LineFileIndex -> Q LineFileIndex
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LineFileIndex
forall a. Monoid a => a
mempty
where
methodExtract :: GenLocated (EpAnn ann) (HsBindLR idL idR) -> [(Int, FunName)]
methodExtract (L EpAnn ann
l (FunBind {LIdP idL
fun_id :: LIdP idL
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id})) = EpAnn ann -> GenLocated l RdrName -> [(Int, FunName)]
forall ann l. EpAnn ann -> GenLocated l RdrName -> [(Int, FunName)]
indexEntry EpAnn ann
l LIdP idL
GenLocated l RdrName
fun_id
methodExtract GenLocated (EpAnn ann) (HsBindLR idL idR)
_ = []
extract :: GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [(IM.Key, FunName)]
extract :: GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [(Int, FunName)]
extract (L SrcSpanAnnA
l (ValD XValD GhcPs
_ (FunBind {LIdP GhcPs
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id :: LIdP GhcPs
fun_id}))) = SrcSpanAnnA -> GenLocated SrcSpanAnnN RdrName -> [(Int, FunName)]
forall ann l. EpAnn ann -> GenLocated l RdrName -> [(Int, FunName)]
indexEntry SrcSpanAnnA
l LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
fun_id
extract (L SrcSpanAnnA
_ (InstD XInstD GhcPs
_ (ClsInstD {ClsInstDecl GhcPs
cid_inst :: ClsInstDecl GhcPs
cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst}))) =
case ClsInstDecl GhcPs
cid_inst of
ClsInstDecl {LHsBinds GhcPs
cid_binds :: LHsBinds GhcPs
cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds} -> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs) -> [(Int, FunName)])
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [(Int, FunName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs) -> [(Int, FunName)]
forall {idL} {l} {ann} {idR}.
(IdP idL ~ RdrName, XRec idL RdrName ~ GenLocated l RdrName) =>
GenLocated (EpAnn ann) (HsBindLR idL idR) -> [(Int, FunName)]
methodExtract ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [Item [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]]
forall l. IsList l => l -> [Item l]
toList LHsBinds GhcPs
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
cid_binds)
extract (L SrcSpanAnnA
_ (TyClD XTyClD GhcPs
_ (ClassDecl {LHsBinds GhcPs
tcdMeths :: LHsBinds GhcPs
tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths}))) =
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs) -> [(Int, FunName)])
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [(Int, FunName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs) -> [(Int, FunName)]
forall {idL} {l} {ann} {idR}.
(IdP idL ~ RdrName, XRec idL RdrName ~ GenLocated l RdrName) =>
GenLocated (EpAnn ann) (HsBindLR idL idR) -> [(Int, FunName)]
methodExtract ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [Item [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]]
forall l. IsList l => l -> [Item l]
toList LHsBinds GhcPs
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
tcdMeths)
extract GenLocated SrcSpanAnnA (HsDecl GhcPs)
_ = []
runParser :: FilePath -> ParserOpts -> String -> P a -> ParseResult a
runParser :: forall a. String -> ParserOpts -> String -> P a -> ParseResult a
runParser String
filename ParserOpts
opts String
str P a
parser = P a -> PState -> ParseResult a
forall a. P a -> PState -> ParseResult a
unP P a
parser PState
parseState
where
location' :: RealSrcLoc
location' = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
buffer :: StringBuffer
buffer = String -> StringBuffer
stringToStringBuffer String
str
parseState :: PState
parseState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState ParserOpts
opts StringBuffer
buffer RealSrcLoc
location'