GitLab

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC

Commits:

3c4db9cf
by Apoorv Ingle at 2025-05-26T11:18:53-05:00
```
remove special case for HsExpanded in Ticks
```

655c636b

by Apoorv Ingle at 2025-05-26T11:19:29-05:00

check the right origin for record selector incomplete warnings

2 changed files:

compiler/GHC/HsToCore/Ticks.hs
compiler/GHC/Tc/Instance/Class.hs

Changes:

compiler/GHC/HsToCore/Ticks.hs

@@ -583,7 +583,11 @@ addTickHsExpr (HsProc x pat cmdtop) =
  addTickHsExpr (XExpr (WrapExpr w e)) =
          liftM (XExpr . WrapExpr w) $
                (addTickHsExpr e)        -- Explicitly no tick on inside
 -addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e
 +addTickHsExpr (XExpr (ExpandedThingTc o e)) =
 +        liftM (XExpr . ExpandedThingTc o) $
 +              (addTickHsExpr e)        -- Explicitly no tick on inside
++
 +  -- addTickHsExpanded o e
  addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
@@ -607,24 +611,24 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
                      ListComp -> Just $ BinBox QualBinBox
                      _        -> Nothing
 -addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
 -addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of
 -  -- We always want statements to get a tick, so we can step over each one.
 -  -- To avoid duplicates we blacklist SrcSpans we already inserted here.
 -  OrigStmt (L pos _) _ -> do_tick_black pos
 -  _                    -> skip
 -  where
 -    skip = addTickHsExpr e
 -    do_tick_black pos = do
 -      d <- getDensity
 -      case d of
 -         TickForCoverage    -> tick_it_black pos
 -         TickForBreakPoints -> tick_it_black pos
 -         _                  -> skip
 -    tick_it_black pos =
 -      unLoc <$> allocTickBox (ExpBox False) False False (locA pos)
 -                             (withBlackListed (locA pos) $
 -                               addTickHsExpr e)
 +-- addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
 +-- addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of
 +--   -- We always want statements to get a tick, so we can step over each one.
 +--   -- To avoid duplicates we blacklist SrcSpans we already inserted here.
 +--   OrigStmt (L pos _) _ -> do_tick_black pos
 +--   _                    -> skip
 +--   where
 +--     skip = addTickHsExpr e
 +--     do_tick_black pos = do
 +--       d <- getDensity
 +--       case d of
 +--          TickForCoverage    -> tick_it_black pos
 +--          TickForBreakPoints -> tick_it_black pos
 +--          _                  -> skip
 +--     tick_it_black pos =
 +--       unLoc <$> allocTickBox (ExpBox False) False False (locA pos)
 +--                              (withBlackListed (locA pos) $
 +--                                addTickHsExpr e)
  addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
  addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e

compiler/GHC/Tc/Instance/Class.hs

@@ -22,7 +22,7 @@ import GHC.Tc.Instance.Typeable
  import GHC.Tc.Utils.TcMType
  import GHC.Tc.Types.Evidence
  import GHC.Tc.Types.CtLoc
 -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) )
 +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(OccurrenceOf) )
  import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs )
  import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
@@ -1327,7 +1327,7 @@ warnIncompleteRecSel dflags sel_id ct_loc
      -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin,
      -- despite the expansion to (getField @"x" r)
 -    isGetFieldOrigin (GetFieldOrigin {}) = True
 +    isGetFieldOrigin (OccurrenceOf f)    = f `hasKey` getFieldClassOpKey
      isGetFieldOrigin _                   = False
  lookupHasFieldLabel