{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Index functions and methods of a Haskell module by line number
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'