{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# 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
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.StringBuffer
import GHC.Driver.Config.Parser
import GHC.Driver.DynFlags
import GHC.Parser
import GHC.Parser.Annotation
import GHC.Parser.Lexer hiding (buffer)
import GHC.Tc.Types
import GHC.Types.Name hiding (Name)
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Utils.Outputable hiding ((<>))
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


newtype FunName = FunName 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

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 (EpAnn AnnListItem) (HsDecl GhcPs) -> [(Int, FunName)])
-> [GenLocated (EpAnn AnnListItem) (HsDecl GhcPs)]
-> [(Int, FunName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated (EpAnn AnnListItem) (HsDecl GhcPs) -> [(Int, FunName)]
forall {idR} {ann} {l} {ann}.
(IdP idR ~ RdrName,
 XRec idR (HsBindLR idR idR)
 ~ GenLocated (EpAnn ann) (HsBindLR idR idR),
 XRec idR RdrName ~ GenLocated l RdrName) =>
GenLocated (EpAnn ann) (HsDecl idR) -> [(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
    indexEntry :: EpAnn ann -> GenLocated l RdrName -> [(Int, FunName)]
indexEntry EpAnn {Anchor
entry :: Anchor
entry :: forall ann. EpAnn ann -> Anchor
entry} = \case
      L l
_ RdrName
fi ->
        case RdrName
fi of
          Unqual OccName
s ->
              [ ( RealSrcLoc -> Int
srcLocLine (RealSrcSpan -> RealSrcLoc
realSrcSpanStart (Anchor -> RealSrcSpan
forall a. EpaLocation' a -> RealSrcSpan
anchor Anchor
entry))
                , String -> FunName
FunName (String -> FunName) -> String -> FunName
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
s
                )
              ]
          RdrName
_ -> []

    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 (EpAnn ann) (HsDecl idR) -> [(Int, FunName)]
extract (L EpAnn ann
l (ValD XValD idR
_ (FunBind {LIdP idR
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id :: LIdP idR
fun_id}))) = EpAnn ann -> GenLocated l RdrName -> [(Int, FunName)]
forall {ann} {l}.
EpAnn ann -> GenLocated l RdrName -> [(Int, FunName)]
indexEntry EpAnn ann
l LIdP idR
GenLocated l RdrName
fun_id
    extract (L EpAnn ann
_ (InstD XInstD idR
_ (ClsInstD {ClsInstDecl idR
cid_inst :: ClsInstDecl idR
cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst}))) =
      case ClsInstDecl idR
cid_inst of
        ClsInstDecl {LHsBinds idR
cid_binds :: LHsBinds idR
cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds} -> (GenLocated (EpAnn ann) (HsBindLR idR idR) -> [(Int, FunName)])
-> [GenLocated (EpAnn ann) (HsBindLR idR idR)] -> [(Int, FunName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated (EpAnn ann) (HsBindLR idR idR) -> [(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 (Bag (GenLocated (EpAnn ann) (HsBindLR idR idR))
-> [GenLocated (EpAnn ann) (HsBindLR idR idR)]
forall a. Bag a -> [a]
bagToList LHsBinds idR
Bag (GenLocated (EpAnn ann) (HsBindLR idR idR))
cid_binds)
        ClsInstDecl idR
_ -> []
    extract (L EpAnn ann
_ (TyClD XTyClD idR
_ (ClassDecl {LHsBinds idR
tcdMeths :: LHsBinds idR
tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths}))) =
      (GenLocated (EpAnn ann) (HsBindLR idR idR) -> [(Int, FunName)])
-> [GenLocated (EpAnn ann) (HsBindLR idR idR)] -> [(Int, FunName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated (EpAnn ann) (HsBindLR idR idR) -> [(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 (Bag (GenLocated (EpAnn ann) (HsBindLR idR idR))
-> [GenLocated (EpAnn ann) (HsBindLR idR idR)]
forall a. Bag a -> [a]
bagToList LHsBinds idR
Bag (GenLocated (EpAnn ann) (HsBindLR idR idR))
tcdMeths)
    extract GenLocated (EpAnn ann) (HsDecl idR)
_ = []

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'