1{-# LANGUAGE CPP #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE RankNTypes #-} 4{-# LANGUAGE TupleSections #-} 5{-# LANGUAGE TypeFamilies #-} 6 7{-# LANGUAGE NoMonoLocalBinds #-} 8 9module Wingman.LanguageServer where 10 11import ConLike 12import Control.Arrow ((***)) 13import Control.Monad 14import Control.Monad.IO.Class 15import Control.Monad.RWS 16import Control.Monad.State (State, evalState) 17import Control.Monad.Trans.Maybe 18import Data.Bifunctor (first) 19import Data.Coerce 20import Data.Functor ((<&>)) 21import Data.Functor.Identity (runIdentity) 22import qualified Data.HashMap.Strict as Map 23import Data.IORef (readIORef) 24import qualified Data.Map as M 25import Data.Maybe 26import Data.Set (Set) 27import qualified Data.Set as S 28import qualified Data.Text as T 29import Data.Traversable 30import Development.IDE (getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange) 31import Development.IDE (hscEnv) 32import Development.IDE.Core.RuleTypes 33import Development.IDE.Core.Rules (usePropertyAction) 34import Development.IDE.Core.Service (runAction) 35import Development.IDE.Core.Shake (IdeState (..), uses, define, use) 36import qualified Development.IDE.Core.Shake as IDE 37import Development.IDE.Core.UseStale 38import Development.IDE.GHC.Compat hiding (parseExpr) 39import Development.IDE.GHC.Error (realSrcSpanToRange) 40import Development.IDE.GHC.ExactPrint 41import Development.IDE.Graph (Action, RuleResult, Rules, action) 42import Development.IDE.Graph.Classes (Binary, Hashable, NFData) 43import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) 44import qualified FastString 45import GHC.Generics (Generic) 46import Generics.SYB hiding (Generic) 47import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope, ExternalPackageState, HscEnv (hsc_EPS), unpackFS) 48import qualified Ide.Plugin.Config as Plugin 49import Ide.Plugin.Properties 50import Ide.PluginUtils (usePropertyLsp) 51import Ide.Types (PluginId) 52import Language.Haskell.GHC.ExactPrint (Transform) 53import Language.Haskell.GHC.ExactPrint (modifyAnnsT, addAnnotationsForPretty) 54import Language.LSP.Server (MonadLsp, sendNotification) 55import Language.LSP.Types hiding 56 (SemanticTokenAbsolute (length, line), 57 SemanticTokenRelative (length), 58 SemanticTokensEdit (_start)) 59import Language.LSP.Types.Capabilities 60import OccName 61import Prelude hiding (span) 62import Retrie (transformA) 63import SrcLoc (containsSpan) 64import TcRnTypes (tcg_binds, TcGblEnv) 65import Wingman.Context 66import Wingman.GHC 67import Wingman.Judgements 68import Wingman.Judgements.SYB (everythingContaining, metaprogramQ) 69import Wingman.Judgements.Theta 70import Wingman.Range 71import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) 72import Wingman.Types 73 74 75tacticDesc :: T.Text -> T.Text 76tacticDesc name = "fill the hole using the " <> name <> " tactic" 77 78 79------------------------------------------------------------------------------ 80-- | The name of the command for the LS. 81tcCommandName :: TacticCommand -> T.Text 82tcCommandName = T.pack . show 83 84 85runIde :: String -> String -> IdeState -> Action a -> IO a 86runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state 87 88 89runCurrentIde 90 :: forall a r 91 . ( r ~ RuleResult a 92 , Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a 93 , Show r, Typeable r, NFData r 94 ) 95 => String 96 -> IdeState 97 -> NormalizedFilePath 98 -> a 99 -> MaybeT IO (Tracked 'Current r) 100runCurrentIde herald state nfp a = 101 MaybeT $ fmap (fmap unsafeMkCurrent) $ runIde herald (show a) state $ use a nfp 102 103 104runStaleIde 105 :: forall a r 106 . ( r ~ RuleResult a 107 , Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a 108 , Show r, Typeable r, NFData r 109 ) 110 => String 111 -> IdeState 112 -> NormalizedFilePath 113 -> a 114 -> MaybeT IO (TrackedStale r) 115runStaleIde herald state nfp a = 116 MaybeT $ runIde herald (show a) state $ useWithStale a nfp 117 118 119unsafeRunStaleIde 120 :: forall a r 121 . ( r ~ RuleResult a 122 , Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a 123 , Show r, Typeable r, NFData r 124 ) 125 => String 126 -> IdeState 127 -> NormalizedFilePath 128 -> a 129 -> MaybeT IO r 130unsafeRunStaleIde herald state nfp a = do 131 (r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp 132 pure r 133 134 135------------------------------------------------------------------------------ 136 137properties :: Properties 138 '[ 'PropertyKey "hole_severity" ('TEnum (Maybe DiagnosticSeverity)) 139 , 'PropertyKey "max_use_ctor_actions" 'TInteger 140 , 'PropertyKey "timeout_duration" 'TInteger 141 , 'PropertyKey "auto_gas" 'TInteger 142 , 'PropertyKey "proofstate_styling" 'TBoolean 143 ] 144properties = emptyProperties 145 & defineBooleanProperty #proofstate_styling 146 "Should Wingman emit styling markup when showing metaprogram proof states?" True 147 & defineIntegerProperty #auto_gas 148 "The depth of the search tree when performing \"Attempt to fill hole\". Bigger values will be able to derive more solutions, but will take exponentially more time." 4 149 & defineIntegerProperty #timeout_duration 150 "The timeout for Wingman actions, in seconds" 2 151 & defineIntegerProperty #max_use_ctor_actions 152 "Maximum number of `Use constructor <x>` code actions that can appear" 5 153 & defineEnumProperty #hole_severity 154 "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities." 155 [ (Just DsError, "error") 156 , (Just DsWarning, "warning") 157 , (Just DsInfo, "info") 158 , (Just DsHint, "hint") 159 , (Nothing, "none") 160 ] 161 Nothing 162 163 164-- | Get the the plugin config 165getTacticConfig :: MonadLsp Plugin.Config m => PluginId -> m Config 166getTacticConfig pId = 167 Config 168 <$> usePropertyLsp #max_use_ctor_actions pId properties 169 <*> usePropertyLsp #timeout_duration pId properties 170 <*> usePropertyLsp #auto_gas pId properties 171 <*> usePropertyLsp #proofstate_styling pId properties 172 173 174getIdeDynflags 175 :: IdeState 176 -> NormalizedFilePath 177 -> MaybeT IO DynFlags 178getIdeDynflags state nfp = do 179 -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags' 180 -- which don't change very often. 181 msr <- unsafeRunStaleIde "getIdeDynflags" state nfp GetModSummaryWithoutTimestamps 182 pure $ ms_hspp_opts $ msrModSummary msr 183 184getAllMetaprograms :: Data a => a -> [String] 185getAllMetaprograms = everything (<>) $ mkQ mempty $ \case 186 WingmanMetaprogram fs -> [ unpackFS fs ] 187 (_ :: HsExpr GhcTc) -> mempty 188 189 190------------------------------------------------------------------------------ 191-- | Find the last typechecked module, and find the most specific span, as well 192-- as the judgement at the given range. 193judgementForHole 194 :: IdeState 195 -> NormalizedFilePath 196 -> Tracked 'Current Range 197 -> Config 198 -> MaybeT IO HoleJudgment 199judgementForHole state nfp range cfg = do 200 let stale a = runStaleIde "judgementForHole" state nfp a 201 202 TrackedStale asts amapping <- stale GetHieAst 203 case unTrack asts of 204 HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" 205 HAR _ (unsafeCopyAge asts -> hf) _ _ HieFresh -> do 206 range' <- liftMaybe $ mapAgeFrom amapping range 207 binds <- stale GetBindings 208 tcg@(TrackedStale tcg_t tcg_map) 209 <- fmap (fmap tmrTypechecked) 210 $ stale TypeCheck 211 212 hscenv <- stale GhcSessionDeps 213 214 (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf 215 216 new_rss <- liftMaybe $ mapAgeTo amapping rss 217 tcg_rss <- liftMaybe $ mapAgeFrom tcg_map new_rss 218 219 -- KnownThings is just the instances in scope. There are no ranges 220 -- involved, so it's not crucial to track ages. 221 let henv = untrackedStaleValue $ hscenv 222 eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv 223 224 (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps 225 let mp = getMetaprogramAtSpan (fmap RealSrcSpan tcg_rss) tcg_t 226 227 dflags <- getIdeDynflags state nfp 228 pure $ HoleJudgment 229 { hj_range = fmap realSrcSpanToRange new_rss 230 , hj_jdg = jdg 231 , hj_ctx = ctx 232 , hj_dflags = dflags 233 , hj_hole_sort = holeSortFor mp 234 } 235 236 237holeSortFor :: Maybe T.Text -> HoleSort 238holeSortFor = maybe Hole Metaprogram 239 240 241mkJudgementAndContext 242 :: Config 243 -> Type 244 -> TrackedStale Bindings 245 -> Tracked 'Current RealSrcSpan 246 -> TrackedStale TcGblEnv 247 -> HscEnv 248 -> ExternalPackageState 249 -> Maybe (Judgement, Context) 250mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgmap) hscenv eps = do 251 binds_rss <- mapAgeFrom bmap rss 252 tcg_rss <- mapAgeFrom tcgmap rss 253 254 let tcs = fmap tcg_binds tcg 255 ctx = mkContext cfg 256 (mapMaybe (sequenceA . (occName *** coerce)) 257 $ unTrack 258 $ getDefiningBindings <$> binds <*> binds_rss) 259 (unTrack tcg) 260 hscenv 261 eps 262 evidence 263 top_provs = getRhsPosVals tcg_rss tcs 264 already_destructed = getAlreadyDestructed (fmap RealSrcSpan tcg_rss) tcs 265 local_hy = spliceProvenance top_provs 266 $ hypothesisFromBindings binds_rss binds 267 evidence = getEvidenceAtHole (fmap RealSrcSpan tcg_rss) tcs 268 cls_hy = foldMap evidenceToHypothesis evidence 269 subst = ts_unifier $ evidenceToSubst evidence defaultTacticState 270 pure $ 271 ( disallowing AlreadyDestructed already_destructed 272 $ fmap (CType . substTyAddInScope subst . unCType) $ 273 mkFirstJudgement 274 ctx 275 (local_hy <> cls_hy) 276 (isRhsHoleWithoutWhere tcg_rss tcs) 277 g 278 , ctx 279 ) 280 281 282------------------------------------------------------------------------------ 283-- | Determine which bindings have already been destructed by the location of 284-- the hole. 285getAlreadyDestructed 286 :: Tracked age SrcSpan 287 -> Tracked age (LHsBinds GhcTc) 288 -> Set OccName 289getAlreadyDestructed (unTrack -> span) (unTrack -> binds) = 290 everythingContaining span 291 (mkQ mempty $ \case 292 Case (HsVar _ (L _ (occName -> var))) _ -> 293 S.singleton var 294 (_ :: HsExpr GhcTc) -> mempty 295 ) binds 296 297 298getSpanAndTypeAtHole 299 :: Tracked age Range 300 -> Tracked age (HieASTs b) 301 -> Maybe (Tracked age RealSrcSpan, b) 302getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do 303 join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> 304 case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of 305 Nothing -> Nothing 306 Just ast' -> do 307 let info = nodeInfo ast' 308 ty <- listToMaybe $ nodeType info 309 guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info 310 -- Ensure we're actually looking at a hole here 311 occ <- (either (const Nothing) (Just . occName) =<<) 312 . listToMaybe 313 . S.toList 314 . M.keysSet 315 $ nodeIdentifiers info 316 guard $ isHole occ 317 pure (unsafeCopyAge r $ nodeSpan ast', ty) 318 319 320 321------------------------------------------------------------------------------ 322-- | Combine two (possibly-overlapping) hypotheses; using the provenance from 323-- the first hypothesis if the bindings overlap. 324spliceProvenance 325 :: Hypothesis a -- ^ Bindings to keep 326 -> Hypothesis a -- ^ Bindings to keep if they don't overlap with the first set 327 -> Hypothesis a 328spliceProvenance top x = 329 let bound = S.fromList $ fmap hi_name $ unHypothesis top 330 in mappend top $ Hypothesis . filter (flip S.notMember bound . hi_name) $ unHypothesis x 331 332 333------------------------------------------------------------------------------ 334-- | Compute top-level position vals of a function 335getRhsPosVals 336 :: Tracked age RealSrcSpan 337 -> Tracked age TypecheckedSource 338 -> Hypothesis CType 339getRhsPosVals (unTrack -> rss) (unTrack -> tcs) 340 = everything (<>) (mkQ mempty $ \case 341 TopLevelRHS name ps 342 (L (RealSrcSpan span) -- body with no guards and a single defn 343 (HsVar _ (L _ hole))) 344 _ 345 | containsSpan rss span -- which contains our span 346 , isHole $ occName hole -- and the span is a hole 347 -> flip evalState 0 $ buildTopLevelHypothesis name ps 348 _ -> mempty 349 ) tcs 350 351 352------------------------------------------------------------------------------ 353-- | Construct a hypothesis given the patterns from the left side of a HsMatch. 354-- These correspond to things that the user put in scope before running 355-- tactics. 356buildTopLevelHypothesis 357 :: OccName -- ^ Function name 358 -> [PatCompat GhcTc] 359 -> State Int (Hypothesis CType) 360buildTopLevelHypothesis name ps = do 361 fmap mconcat $ 362 for (zip [0..] ps) $ \(ix, p) -> 363 buildPatHy (TopLevelArgPrv name ix $ length ps) p 364 365 366------------------------------------------------------------------------------ 367-- | Construct a hypothesis for a single pattern, including building 368-- sub-hypotheses for constructor pattern matches. 369buildPatHy :: Provenance -> PatCompat GhcTc -> State Int (Hypothesis CType) 370buildPatHy prov (fromPatCompat -> p0) = 371 case p0 of 372 VarPat _ x -> pure $ mkIdHypothesis (unLoc x) prov 373 LazyPat _ p -> buildPatHy prov p 374 AsPat _ x p -> do 375 hy' <- buildPatHy prov p 376 pure $ mkIdHypothesis (unLoc x) prov <> hy' 377 ParPat _ p -> buildPatHy prov p 378 BangPat _ p -> buildPatHy prov p 379 ViewPat _ _ p -> buildPatHy prov p 380 -- Desugar lists into cons 381 ListPat _ [] -> pure mempty 382 ListPat x@(ListPatTc ty _) (p : ps) -> 383 mkDerivedConHypothesis prov (RealDataCon consDataCon) [ty] 384 [ (0, p) 385 , (1, toPatCompat $ ListPat x ps) 386 ] 387 -- Desugar tuples into an explicit constructor 388 TuplePat tys pats boxity -> 389 mkDerivedConHypothesis 390 prov 391 (RealDataCon $ tupleDataCon boxity $ length pats) 392 tys 393 $ zip [0.. ] pats 394 ConPatOut (L _ con) args _ _ _ f _ -> 395 case f of 396 PrefixCon l_pgt -> 397 mkDerivedConHypothesis prov con args $ zip [0..] l_pgt 398 InfixCon pgt pgt5 -> 399 mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5] 400 RecCon r -> 401 mkDerivedRecordHypothesis prov con args r 402#if __GLASGOW_HASKELL__ >= 808 403 SigPat _ p _ -> buildPatHy prov p 404#endif 405#if __GLASGOW_HASKELL__ == 808 406 XPat p -> buildPatHy prov $ unLoc p 407#endif 408 _ -> pure mempty 409 410 411------------------------------------------------------------------------------ 412-- | Like 'mkDerivedConHypothesis', but for record patterns. 413mkDerivedRecordHypothesis 414 :: Provenance 415 -> ConLike -- ^ Destructing constructor 416 -> [Type] -- ^ Applied type variables 417 -> HsRecFields GhcTc (PatCompat GhcTc) 418 -> State Int (Hypothesis CType) 419mkDerivedRecordHypothesis prov dc args (HsRecFields (fmap unLoc -> fs) _) 420 | Just rec_fields <- getRecordFields dc 421 = do 422 let field_lookup = M.fromList $ zip (fmap (occNameFS . fst) rec_fields) [0..] 423 mkDerivedConHypothesis prov dc args $ fs <&> \(HsRecField (L _ rec_occ) p _) -> 424 ( field_lookup M.! (occNameFS $ occName $ unLoc $ rdrNameFieldOcc rec_occ) 425 , p 426 ) 427mkDerivedRecordHypothesis _ _ _ _ = 428 error "impossible! using record pattern on something that isn't a record" 429 430 431------------------------------------------------------------------------------ 432-- | Construct a fake variable name. Used to track the provenance of top-level 433-- pattern matches which otherwise wouldn't have anything to attach their 434-- 'TopLevelArgPrv' to. 435mkFakeVar :: State Int OccName 436mkFakeVar = do 437 i <- get 438 put $ i + 1 439 pure $ mkVarOcc $ "_" <> show i 440 441 442------------------------------------------------------------------------------ 443-- | Construct a fake varible to attach the current 'Provenance' to, and then 444-- build a sub-hypothesis for the pattern match. 445mkDerivedConHypothesis 446 :: Provenance 447 -> ConLike -- ^ Destructing constructor 448 -> [Type] -- ^ Applied type variables 449 -> [(Int, PatCompat GhcTc)] -- ^ Patterns, and their order in the data con 450 -> State Int (Hypothesis CType) 451mkDerivedConHypothesis prov dc args ps = do 452 var <- mkFakeVar 453 hy' <- fmap mconcat $ 454 for ps $ \(ix, p) -> do 455 let prov' = PatternMatchPrv 456 $ PatVal (Just var) 457 (S.singleton var <> provAncestryOf prov) 458 (Uniquely dc) 459 ix 460 buildPatHy prov' p 461 pure 462 $ mappend hy' 463 $ Hypothesis 464 $ pure 465 $ HyInfo var (DisallowedPrv AlreadyDestructed prov) 466 $ CType 467 -- TODO(sandy): This is the completely wrong type, but we don't have a good 468 -- way to get the real one. It's probably OK though, since we're generating 469 -- this term with a disallowed provenance, and it doesn't actually exist 470 -- anyway. 471 $ conLikeResTy dc args 472 473 474------------------------------------------------------------------------------ 475-- | Build a 'Hypothesis' given an 'Id'. 476mkIdHypothesis :: Id -> Provenance -> Hypothesis CType 477mkIdHypothesis (splitId -> (name, ty)) prov = 478 Hypothesis $ pure $ HyInfo name prov ty 479 480 481------------------------------------------------------------------------------ 482-- | Is this hole immediately to the right of an equals sign --- and is there 483-- no where clause attached to it? 484-- 485-- It's important that there is no where clause because otherwise it gets 486-- clobbered. See #2183 for an example. 487-- 488-- This isn't a perfect check, and produces some ugly code. But it's much much 489-- better than the alternative, which is to destructively modify the user's 490-- AST. 491isRhsHoleWithoutWhere 492 :: Tracked age RealSrcSpan 493 -> Tracked age TypecheckedSource 494 -> Bool 495isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = 496 everything (||) (mkQ False $ \case 497 TopLevelRHS _ _ 498 (L (RealSrcSpan span) _) 499 (EmptyLocalBinds _) -> containsSpan rss span 500 _ -> False 501 ) tcs 502 503 504ufmSeverity :: UserFacingMessage -> MessageType 505ufmSeverity NotEnoughGas = MtInfo 506ufmSeverity TacticErrors = MtError 507ufmSeverity TimedOut = MtInfo 508ufmSeverity NothingToDo = MtInfo 509ufmSeverity (InfrastructureError _) = MtError 510 511 512mkShowMessageParams :: UserFacingMessage -> ShowMessageParams 513mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm 514 515 516showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () 517showLspMessage = sendNotification SWindowShowMessage 518 519 520-- This rule only exists for generating file diagnostics 521-- so the RuleResult is empty 522data WriteDiagnostics = WriteDiagnostics 523 deriving (Eq, Show, Typeable, Generic) 524 525instance Hashable WriteDiagnostics 526instance NFData WriteDiagnostics 527instance Binary WriteDiagnostics 528 529type instance RuleResult WriteDiagnostics = () 530 531wingmanRules :: PluginId -> Rules () 532wingmanRules plId = do 533 define $ \WriteDiagnostics nfp -> 534 usePropertyAction #hole_severity plId properties >>= \case 535 Nothing -> pure (mempty, Just ()) 536 Just severity -> 537 use GetParsedModule nfp >>= \case 538 Nothing -> 539 pure ([], Nothing) 540 Just pm -> do 541 let holes :: [Range] 542 holes = 543 everything (<>) 544 (mkQ mempty $ \case 545 L span (HsVar _ (L _ name)) 546 | isHole (occName name) -> 547 maybeToList $ srcSpanToRange span 548 L span (HsUnboundVar _ (TrueExprHole occ)) 549 | isHole occ -> 550 maybeToList $ srcSpanToRange span 551#if __GLASGOW_HASKELL__ <= 808 552 L span (EWildPat _) -> 553 maybeToList $ srcSpanToRange span 554#endif 555 (_ :: LHsExpr GhcPs) -> mempty 556 ) $ pm_parsed_source pm 557 pure 558 ( fmap (\r -> (nfp, ShowDiag, mkDiagnostic severity r)) holes 559 , Just () 560 ) 561 562 action $ do 563 files <- getFilesOfInterestUntracked 564 void $ uses WriteDiagnostics $ Map.keys files 565 566 567mkDiagnostic :: DiagnosticSeverity -> Range -> Diagnostic 568mkDiagnostic severity r = 569 Diagnostic r 570 (Just severity) 571 (Just $ InR "hole") 572 (Just "wingman") 573 "Hole" 574 (Just $ List [DtUnnecessary]) 575 Nothing 576 577 578------------------------------------------------------------------------------ 579-- | Transform a 'Graft' over the AST into a 'WorkspaceEdit'. 580mkWorkspaceEdits 581 :: DynFlags 582 -> ClientCapabilities 583 -> Uri 584 -> Annotated ParsedSource 585 -> Graft (Either String) ParsedSource 586 -> Either UserFacingMessage WorkspaceEdit 587mkWorkspaceEdits dflags ccs uri pm g = do 588 let pm' = runIdentity $ transformA pm annotateMetaprograms 589 let response = transform dflags ccs uri g pm' 590 in first (InfrastructureError . T.pack) response 591 592 593------------------------------------------------------------------------------ 594-- | Add ExactPrint annotations to every metaprogram in the source tree. 595-- Usually the ExactPrint module can do this for us, but we've enabled 596-- QuasiQuotes, so the round-trip print/parse journey will crash. 597annotateMetaprograms :: Data a => a -> Transform a 598annotateMetaprograms = everywhereM $ mkM $ \case 599 L ss (WingmanMetaprogram mp) -> do 600 let x = L ss $ MetaprogramSyntax mp 601 let anns = addAnnotationsForPretty [] x mempty 602 modifyAnnsT $ mappend anns 603 pure x 604 (x :: LHsExpr GhcPs) -> pure x 605 606 607------------------------------------------------------------------------------ 608-- | Find the source of a tactic metaprogram at the given span. 609getMetaprogramAtSpan 610 :: Tracked age SrcSpan 611 -> Tracked age TcGblEnv 612 -> Maybe T.Text 613getMetaprogramAtSpan (unTrack -> ss) 614 = fmap snd 615 . listToMaybe 616 . metaprogramQ ss 617 . tcg_binds 618 . unTrack 619 620