{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
module AutoInstrument.Internal.Plugin.Parser
  ( parsedResultAction
  ) where

import           Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Char8 as BS8
import           Data.Maybe (mapMaybe)
import qualified Data.Set as S

import qualified AutoInstrument.Internal.GhcFacade as Ghc
import qualified AutoInstrument.Internal.Config as Cfg

parsedResultAction
  :: [Ghc.CommandLineOption]
  -> Ghc.ModSummary
  -> Ghc.ParsedResult
  -> Ghc.Hsc Ghc.ParsedResult
parsedResultAction :: [CommandLineOption]
-> ModSummary -> ParsedResult -> Hsc ParsedResult
parsedResultAction [CommandLineOption]
opts ModSummary
modSummary
    parsedResult :: ParsedResult
parsedResult@Ghc.ParsedResult
      {parsedResultModule :: ParsedResult -> HsParsedModule
Ghc.parsedResultModule = prm :: HsParsedModule
prm@Ghc.HsParsedModule
        {hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
Ghc.hpm_module = Ghc.L SrcSpan
modLoc mo :: HsModule GhcPs
mo@Ghc.HsModule{[LHsDecl GhcPs]
hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
Ghc.hsmodDecls}}} = do

  let modName :: ModuleName
modName = GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
Ghc.moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> GenModule Unit
Ghc.ms_mod ModSummary
modSummary
      unitId :: UnitId
unitId = Unit -> UnitId
Ghc.toUnitId (Unit -> UnitId)
-> (GenModule Unit -> Unit) -> GenModule Unit -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> Unit
forall unit. GenModule unit -> unit
Ghc.moduleUnit (GenModule Unit -> UnitId) -> GenModule Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ ModSummary -> GenModule Unit
Ghc.ms_mod ModSummary
modSummary

  HscEnv
hscEnv <- Hsc HscEnv
Ghc.getHscEnv
  FindResult
result <- IO FindResult -> Hsc FindResult
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> Hsc FindResult)
-> IO FindResult -> Hsc FindResult
forall a b. (a -> b) -> a -> b
$
    HscEnv -> ModuleName -> PkgQual -> IO FindResult
Ghc.findImportedModule HscEnv
hscEnv (CommandLineOption -> ModuleName
Ghc.mkModuleName CommandLineOption
"AutoInstrument.Internal.Types") PkgQual
Ghc.NoPkgQual
  GenModule Unit
otelMod <-
    case FindResult
result of
      Ghc.Found ModLocation
_ GenModule Unit
m -> GenModule Unit -> Hsc (GenModule Unit)
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenModule Unit
m
      FindResult
_ -> CommandLineOption -> Hsc (GenModule Unit)
forall a. HasCallStack => CommandLineOption -> a
error CommandLineOption
"AutoInstrument.Internal.Types module not found"
  let occ :: OccName
occ = CommandLineOption -> OccName
Ghc.mkVarOcc CommandLineOption
"autoInstrument"
  Name
autoInstrumentName <- IO Name -> Hsc Name
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Name -> Hsc Name) -> IO Name -> Hsc Name
forall a b. (a -> b) -> a -> b
$ NameCache -> GenModule Unit -> OccName -> IO Name
Ghc.lookupNameCache (HscEnv -> NameCache
Ghc.hsc_NC HscEnv
hscEnv) GenModule Unit
otelMod OccName
occ

  Maybe Config
mConfig <- IO (Maybe Config) -> Hsc (Maybe Config)
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Config) -> Hsc (Maybe Config))
-> IO (Maybe Config) -> Hsc (Maybe Config)
forall a b. (a -> b) -> a -> b
$ (ConfigCache -> Config) -> Maybe ConfigCache -> Maybe Config
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConfigCache -> Config
Cfg.getConfig (Maybe ConfigCache -> Maybe Config)
-> IO (Maybe ConfigCache) -> IO (Maybe Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CommandLineOption] -> IO (Maybe ConfigCache)
Cfg.getConfigCache [CommandLineOption]
opts

  case Maybe Config
mConfig of
    Maybe Config
Nothing -> ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedResult
parsedResult
      { Ghc.parsedResultMessages = (Ghc.parsedResultMessages parsedResult)
        { Ghc.psErrors =
            let msg = CommandLineOption -> MsgEnvelope PsMessage
Ghc.mkParseError CommandLineOption
"Failed to load auto instrumentation config"
             in Ghc.addMessage msg . Ghc.psErrors $ Ghc.parsedResultMessages parsedResult
        }
      }
    Just Config
config -> do
      let matches :: Set OccName
matches = [OccName] -> Set OccName
forall a. Ord a => [a] -> Set a
S.fromList ([OccName] -> Set OccName) -> [OccName] -> Set OccName
forall a b. (a -> b) -> a -> b
$ Config -> [LHsDecl GhcPs] -> [OccName]
getMatches Config
config [LHsDecl GhcPs]
hsmodDecls

          newDecls :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
newDecls = ModuleName
-> UnitId -> Name -> Set OccName -> LHsDecl GhcPs -> LHsDecl GhcPs
instrumentDecl ModuleName
modName UnitId
unitId Name
autoInstrumentName Set OccName
matches (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
hsmodDecls

      ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedResult
parsedResult
        { Ghc.parsedResultModule = prm
          { Ghc.hpm_module = Ghc.L modLoc mo
            { Ghc.hsmodDecls = newDecls
            }
          }
        }

getMatches
  :: Cfg.Config
  -> [Ghc.LHsDecl Ghc.GhcPs]
  -> [Ghc.OccName]
getMatches :: Config -> [LHsDecl GhcPs] -> [OccName]
getMatches Config
cfg = [[OccName]] -> [OccName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[OccName]] -> [OccName])
-> ([GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [[OccName]])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Maybe [OccName])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [[OccName]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Maybe [OccName]
forall {l}. GenLocated l (HsDecl GhcPs) -> Maybe [OccName]
go where
  go :: GenLocated l (HsDecl GhcPs) -> Maybe [OccName]
go (Ghc.L l
_ (Ghc.SigD XSigD GhcPs
_ (Ghc.TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
lhs (Ghc.HsWC XHsWC GhcPs (LHsSigType GhcPs)
_ (Ghc.L SrcSpanAnnA
_ (Ghc.HsSig XHsSig GhcPs
_ HsOuterSigTyVarBndrs GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
ty)))))))
    | [HsType GhcPs] -> HsType GhcPs -> Bool
isTargetTy [] HsType GhcPs
ty = [OccName] -> Maybe [OccName]
forall a. a -> Maybe a
Just (RdrName -> OccName
Ghc.rdrNameOcc (RdrName -> OccName)
-> (GenLocated SrcSpanAnnN RdrName -> RdrName)
-> GenLocated SrcSpanAnnN RdrName
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
Ghc.unLoc (GenLocated SrcSpanAnnN RdrName -> OccName)
-> [GenLocated SrcSpanAnnN RdrName] -> [OccName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LIdP GhcPs]
[GenLocated SrcSpanAnnN RdrName]
lhs)
  go GenLocated l (HsDecl GhcPs)
_ = Maybe [OccName]
forall a. Maybe a
Nothing
  isTargetTy :: [HsType GhcPs] -> HsType GhcPs -> Bool
isTargetTy [HsType GhcPs]
preds = \case
    Ghc.HsForAllTy XForAllTy GhcPs
_ HsForAllTelescope GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
body) -> [HsType GhcPs] -> HsType GhcPs -> Bool
isTargetTy [HsType GhcPs]
preds HsType GhcPs
body
    Ghc.HsQualTy XQualTy GhcPs
_ (Ghc.L SrcSpanAnnC
_ [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctx) (Ghc.L SrcSpanAnnA
_ HsType GhcPs
body) ->
      [HsType GhcPs] -> HsType GhcPs -> Bool
isTargetTy ([HsType GhcPs]
preds [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [HsType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
Ghc.unLoc [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctx) HsType GhcPs
body
    app :: HsType GhcPs
app@Ghc.HsAppTy{} -> [HsType GhcPs] -> HsType GhcPs -> Bool
check [HsType GhcPs]
preds HsType GhcPs
app
    var :: HsType GhcPs
var@Ghc.HsTyVar{} -> [HsType GhcPs] -> HsType GhcPs -> Bool
check [HsType GhcPs]
preds HsType GhcPs
var
    Ghc.HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
_ LHsType GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
nxt) -> [HsType GhcPs] -> HsType GhcPs -> Bool
isTargetTy [HsType GhcPs]
preds HsType GhcPs
nxt
    Ghc.HsParTy XParTy GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
nxt) -> [HsType GhcPs] -> HsType GhcPs -> Bool
isTargetTy [HsType GhcPs]
preds HsType GhcPs
nxt
    Ghc.HsDocTy XDocTy GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
nxt) LHsDoc GhcPs
_ -> [HsType GhcPs] -> HsType GhcPs -> Bool
isTargetTy [HsType GhcPs]
preds HsType GhcPs
nxt
    HsType GhcPs
_ -> Bool
False

  check
    :: [Ghc.HsType Ghc.GhcPs]
    -> Ghc.HsType Ghc.GhcPs
    -> Bool
  check :: [HsType GhcPs] -> HsType GhcPs -> Bool
check [HsType GhcPs]
preds HsType GhcPs
expr =
    (Target -> Bool) -> [Target] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([HsType GhcPs] -> HsType GhcPs -> Target -> Bool
matchTarget [HsType GhcPs]
preds HsType GhcPs
expr) (Config -> [Target]
Cfg.targets Config
cfg)
    Bool -> Bool -> Bool
&& Bool -> Bool
not ((Target -> Bool) -> [Target] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([HsType GhcPs] -> HsType GhcPs -> Target -> Bool
matchTarget [HsType GhcPs]
preds HsType GhcPs
expr) (Config -> [Target]
Cfg.exclusions Config
cfg))

  matchTarget :: [HsType GhcPs] -> HsType GhcPs -> Target -> Bool
matchTarget [HsType GhcPs]
preds HsType GhcPs
expr = \case
    Cfg.Constructor TargetCon
conTarget -> Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
True TargetCon
conTarget HsType GhcPs
expr
    Cfg.Constraints ConstraintSet
predTarget -> [HsType GhcPs] -> ConstraintSet -> Bool
checkPred [HsType GhcPs]
preds ConstraintSet
predTarget

  checkTy
    :: Bool
    -> Cfg.TargetCon
    -> Ghc.HsType Ghc.GhcPs
    -> Bool
  checkTy :: Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
top TargetCon
t (Ghc.HsParTy XParTy GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
x)) = Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
top TargetCon
t HsType GhcPs
x
  checkTy Bool
top TargetCon
t (Ghc.HsDocTy XDocTy GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
x) LHsDoc GhcPs
_) = Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
top TargetCon
t HsType GhcPs
x
  checkTy Bool
_ (Cfg.TyVar CommandLineOption
name) (Ghc.HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (Ghc.L SrcSpanAnnN
_ RdrName
rdrName)) =
    CommandLineOption -> ByteString
BS8.pack CommandLineOption
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> ByteString
Ghc.bytesFS (OccName -> FastString
Ghc.occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
Ghc.rdrNameOcc RdrName
rdrName)
  checkTy Bool
top target :: TargetCon
target@(Cfg.App TargetCon
x TargetCon
y) (Ghc.HsAppTy XAppTy GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
con) (Ghc.L SrcSpanAnnA
_ HsType GhcPs
arg)) =
    (Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
False TargetCon
y HsType GhcPs
arg Bool -> Bool -> Bool
&& Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
False TargetCon
x HsType GhcPs
con )
    Bool -> Bool -> Bool
|| (Bool
top Bool -> Bool -> Bool
&& Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
True TargetCon
target HsType GhcPs
con)
  checkTy Bool
True target :: TargetCon
target@(Cfg.TyVar CommandLineOption
_) (Ghc.HsAppTy XAppTy GhcPs
_ (Ghc.L SrcSpanAnnA
_ HsType GhcPs
con) LHsType GhcPs
_) =
    Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
True TargetCon
target HsType GhcPs
con
  checkTy Bool
_ TargetCon
Cfg.Unit (Ghc.HsTupleTy XTupleTy GhcPs
_ HsTupleSort
Ghc.HsBoxedOrConstraintTuple []) = Bool
True
  checkTy Bool
_ (Cfg.Tuple [TargetCon]
targets) (Ghc.HsTupleTy XTupleTy GhcPs
_ HsTupleSort
Ghc.HsBoxedOrConstraintTuple [LHsType GhcPs]
exprs) =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (TargetCon -> HsType GhcPs -> Bool)
-> [TargetCon] -> [HsType GhcPs] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
False) [TargetCon]
targets (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
Ghc.unLoc (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [HsType GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
exprs)
  checkTy Bool
_ TargetCon
Cfg.WC HsType GhcPs
_ = Bool
True
  checkTy Bool
_ TargetCon
_ HsType GhcPs
_ = Bool
False

  checkPred
    :: [Ghc.HsType Ghc.GhcPs]
    -> Cfg.ConstraintSet
    -> Bool
  checkPred :: [HsType GhcPs] -> ConstraintSet -> Bool
checkPred [HsType GhcPs]
preds ConstraintSet
predSet =
    (TargetCon -> Bool) -> [TargetCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\TargetCon
p -> (HsType GhcPs -> Bool) -> [HsType GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> TargetCon -> HsType GhcPs -> Bool
checkTy Bool
True TargetCon
p) [HsType GhcPs]
preds)
        (ConstraintSet -> [TargetCon]
forall a. Set a -> [a]
S.toList ConstraintSet
predSet)

instrumentDecl
  :: Ghc.ModuleName
  -> Ghc.UnitId
  -> Ghc.Name
  -> S.Set Ghc.OccName
  -> Ghc.LHsDecl Ghc.GhcPs
  -> Ghc.LHsDecl Ghc.GhcPs
instrumentDecl :: ModuleName
-> UnitId -> Name -> Set OccName -> LHsDecl GhcPs -> LHsDecl GhcPs
instrumentDecl ModuleName
modName UnitId
unitId Name
instrName Set OccName
targets
    (Ghc.L SrcSpanAnnA
loc (Ghc.ValD XValD GhcPs
vX fb :: HsBind GhcPs
fb@Ghc.FunBind
      { fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
Ghc.fun_matches = mg :: MatchGroup GhcPs (LHsExpr GhcPs)
mg@Ghc.MG
        { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
Ghc.mg_alts = Ghc.L SrcSpanAnnL
altsLoc [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts }, LIdP GhcPs
fun_id :: LIdP GhcPs
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
Ghc.fun_id}))
  | RdrName -> OccName
Ghc.rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
Ghc.unLoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
fun_id) OccName -> Set OccName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set OccName
targets
  = let newAlts :: [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
newAlts = ((GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GenLocated
    SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
  -> GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
 -> [GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> [GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> ((Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap)
          (ModuleName
-> UnitId
-> RdrName
-> Name
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
instrumentMatch ModuleName
modName UnitId
unitId (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
Ghc.unLoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
fun_id) Name
instrName)
          [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts
     in SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
loc (XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
Ghc.ValD XValD GhcPs
vX (HsBind GhcPs
fb
       { Ghc.fun_matches = mg
         { Ghc.mg_alts = Ghc.L altsLoc newAlts }}))
instrumentDecl ModuleName
_ UnitId
_ Name
_ Set OccName
_ LHsDecl GhcPs
x = LHsDecl GhcPs
x

instrumentMatch
  :: Ghc.ModuleName
  -> Ghc.UnitId
  -> Ghc.RdrName
  -> Ghc.Name
  -> Ghc.Match Ghc.GhcPs (Ghc.GenLocated Ghc.SrcSpanAnnA (Ghc.HsExpr Ghc.GhcPs))
  -> Ghc.Match Ghc.GhcPs (Ghc.GenLocated Ghc.SrcSpanAnnA (Ghc.HsExpr Ghc.GhcPs))
instrumentMatch :: ModuleName
-> UnitId
-> RdrName
-> Name
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
instrumentMatch ModuleName
modName UnitId
unitId RdrName
bindName Name
instrName Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match =
  Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match
    { Ghc.m_grhss = (Ghc.m_grhss match)
      { Ghc.grhssGRHSs = (fmap . fmap) modifyGRH (Ghc.grhssGRHSs (Ghc.m_grhss match)) }
    }
  where
    modifyGRH :: Ghc.GRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)
              -> Ghc.GRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)
    modifyGRH :: GRHS GhcPs (LHsExpr GhcPs) -> GRHS GhcPs (LHsExpr GhcPs)
modifyGRH (Ghc.GRHS XCGRHS GhcPs (LHsExpr GhcPs)
x [GuardLStmt GhcPs]
guards LHsExpr GhcPs
body) =
      XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [GuardLStmt GhcPs]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS XCGRHS GhcPs (LHsExpr GhcPs)
XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x [GuardLStmt GhcPs]
guards (LHsExpr GhcPs -> LHsExpr GhcPs
go LHsExpr GhcPs
body)
    go :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs
    go :: LHsExpr GhcPs -> LHsExpr GhcPs
go (Ghc.L SrcSpanAnnA
loc HsExpr GhcPs
x) =
      let instrVar :: HsExpr GhcPs
instrVar = XVar GhcPs -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
Ghc.HsVar XVar GhcPs
NoExtField
Ghc.noExtField (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnN
forall ann. SrcAnn ann
Ghc.noSrcSpanA (Name -> RdrName
Ghc.Exact Name
instrName))
          mkStringExpr :: FastString -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
mkStringExpr = SrcAnn ann
-> HsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcAnn ann
forall ann. SrcAnn ann
Ghc.noSrcSpanA (HsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs))
-> (FastString -> HsExpr GhcPs)
-> FastString
-> GenLocated (SrcAnn ann) (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
Ghc.HsLit XLitE GhcPs
EpAnn NoEpAnns
forall a. EpAnn a
Ghc.noAnn
                       (HsLit GhcPs -> HsExpr GhcPs)
-> (FastString -> HsLit GhcPs) -> FastString -> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHsString GhcPs -> FastString -> HsLit GhcPs
forall x. XHsString x -> FastString -> HsLit x
Ghc.HsString XHsString GhcPs
SourceText
Ghc.NoSourceText
          app :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs
          app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
app LHsExpr GhcPs
l LHsExpr GhcPs
r = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
forall ann. SrcAnn ann
Ghc.noSrcSpanA (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
Ghc.HsApp XApp GhcPs
EpAnn NoEpAnns
forall a. EpAnn a
Ghc.noAnn LHsExpr GhcPs
l LHsExpr GhcPs
r
          srcSpan :: RealSrcSpan
srcSpan = SrcSpan -> RealSrcSpan
Ghc.realSrcSpan (SrcSpan -> RealSrcSpan)
-> (SrcSpanAnnA -> SrcSpan) -> SrcSpanAnnA -> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
Ghc.locA (SrcSpanAnnA -> RealSrcSpan) -> SrcSpanAnnA -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
loc :: Ghc.RealSrcSpan
          instr :: LHsExpr GhcPs
instr =
            SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
forall ann. SrcAnn ann
Ghc.noSrcSpanA HsExpr GhcPs
instrVar
              LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`app`
            (FastString -> LHsExpr GhcPs
FastString -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}. FastString -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
mkStringExpr (FastString -> LHsExpr GhcPs)
-> (OccName -> FastString) -> OccName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
Ghc.occNameFS (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
Ghc.rdrNameOcc RdrName
bindName)
              LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`app`
            FastString -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}. FastString -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
mkStringExpr (ModuleName -> FastString
Ghc.moduleNameFS ModuleName
modName)
              LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`app`
            FastString -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}. FastString -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
mkStringExpr (RealSrcSpan -> FastString
Ghc.srcSpanFile RealSrcSpan
srcSpan)
              LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`app`
            (FastString -> LHsExpr GhcPs
FastString -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}. FastString -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
mkStringExpr (FastString -> LHsExpr GhcPs)
-> (Int -> FastString) -> Int -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> FastString
Ghc.fsLit (CommandLineOption -> FastString)
-> (Int -> CommandLineOption) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show (Int -> LHsExpr GhcPs) -> Int -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
Ghc.srcSpanStartLine RealSrcSpan
srcSpan)
              LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`app`
            FastString -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}. FastString -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
mkStringExpr (UnitId -> FastString
Ghc.unitIdFS UnitId
unitId)

       in SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
loc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
Ghc.HsApp XApp GhcPs
EpAnn NoEpAnns
forall a. EpAnn a
Ghc.noAnn LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
instr (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpanAnnA
loc HsExpr GhcPs
x)