Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
-
6b8198f1
by Apoorv Ingle at 2026-01-12T15:07:33-06:00
2 changed files:
Changes:
| ... | ... | @@ -75,9 +75,6 @@ import GHC.Utils.Panic |
| 75 | 75 | |
| 76 | 76 | import GHC.Data.Maybe
|
| 77 | 77 | |
| 78 | -import qualified GHC.LanguageExtensions as LangExt
|
|
| 79 | - |
|
| 80 | - |
|
| 81 | 78 | {- *********************************************************************
|
| 82 | 79 | * *
|
| 83 | 80 | HsExprArg: auxiliary data type
|
| ... | ... | @@ -480,43 +477,6 @@ with_get_ds mthing = |
| 480 | 477 | ; return (expr_tc, ds_flag, sig_ty)
|
| 481 | 478 | }
|
| 482 | 479 | |
| 483 | - |
|
| 484 | - |
|
| 485 | --- | Variant of 'getDeepSubsumptionFlag' which enables a top-level subsumption
|
|
| 486 | --- in order to implement the plan of Note [Typechecking data constructors].
|
|
| 487 | -getDeepSubsumptionFlag_DataConHead :: HsExpr GhcTc -> TcM DeepSubsumptionFlag
|
|
| 488 | -getDeepSubsumptionFlag_DataConHead app_head =
|
|
| 489 | - do { user_ds <- xoptM LangExt.DeepSubsumption
|
|
| 490 | - ; traceTc "getDeepSubsumptionFlag_DataConHead" (ppr app_head)
|
|
| 491 | - ; return $
|
|
| 492 | - if | user_ds
|
|
| 493 | - -> Deep DeepSub
|
|
| 494 | - | otherwise
|
|
| 495 | - -> go app_head
|
|
| 496 | - }
|
|
| 497 | - where
|
|
| 498 | - go :: HsExpr GhcTc -> DeepSubsumptionFlag
|
|
| 499 | - go app_head
|
|
| 500 | - | XExpr (ConLikeTc (RealDataCon {})) <- app_head
|
|
| 501 | - = Deep TopSub
|
|
| 502 | - | XExpr (ExpandedThingTc _ f) <- app_head
|
|
| 503 | - = go f
|
|
| 504 | - | XExpr (WrapExpr _ f) <- app_head
|
|
| 505 | - = go f
|
|
| 506 | - | HsVar _ f <- app_head
|
|
| 507 | - , isDataConId (unLoc f)
|
|
| 508 | - = Deep TopSub
|
|
| 509 | - | HsApp _ f _ <- app_head
|
|
| 510 | - = go (unLoc f)
|
|
| 511 | - | HsAppType _ f _ <- app_head
|
|
| 512 | - = go (unLoc f)
|
|
| 513 | - | OpApp _ _ f _ <- app_head
|
|
| 514 | - = go (unLoc f)
|
|
| 515 | - | HsPar _ f <- app_head
|
|
| 516 | - = go (unLoc f)
|
|
| 517 | - | otherwise
|
|
| 518 | - = Shallow
|
|
| 519 | - |
|
| 520 | 480 | {- *********************************************************************
|
| 521 | 481 | * *
|
| 522 | 482 | Record selectors
|
| ... | ... | @@ -93,12 +93,13 @@ import qualified GHC.LanguageExtensions as LangExt |
| 93 | 93 | |
| 94 | 94 | import GHC.Builtin.Types
|
| 95 | 95 | import GHC.Types.Name
|
| 96 | -import GHC.Types.Id( idType )
|
|
| 96 | +import GHC.Types.Id( idType, isDataConId )
|
|
| 97 | 97 | import GHC.Types.Var as Var
|
| 98 | 98 | import GHC.Types.Var.Set
|
| 99 | 99 | import GHC.Types.Var.Env
|
| 100 | 100 | import GHC.Types.Basic
|
| 101 | 101 | import GHC.Types.Unique.Set (nonDetEltsUniqSet)
|
| 102 | +import GHC.Types.SrcLoc (unLoc)
|
|
| 102 | 103 | |
| 103 | 104 | import GHC.Utils.Misc
|
| 104 | 105 | import GHC.Utils.Outputable as Outputable
|
| ... | ... | @@ -2031,14 +2032,36 @@ getDeepSubsumptionFlag = |
| 2031 | 2032 | getDeepSubsumptionFlag_DataConHead :: HsExpr GhcTc -> TcM DeepSubsumptionFlag
|
| 2032 | 2033 | getDeepSubsumptionFlag_DataConHead app_head =
|
| 2033 | 2034 | do { user_ds <- xoptM LangExt.DeepSubsumption
|
| 2035 | + ; traceTc "getDeepSubsumptionFlag_DataConHead" (ppr app_head)
|
|
| 2034 | 2036 | ; return $
|
| 2035 | 2037 | if | user_ds
|
| 2036 | 2038 | -> Deep DeepSub
|
| 2037 | - | XExpr (ConLikeTc (RealDataCon {})) <- app_head
|
|
| 2038 | - -> Deep TopSub
|
|
| 2039 | 2039 | | otherwise
|
| 2040 | - -> Shallow
|
|
| 2041 | - }
|
|
| 2040 | + -> go app_head
|
|
| 2041 | + }
|
|
| 2042 | + where
|
|
| 2043 | + go :: HsExpr GhcTc -> DeepSubsumptionFlag
|
|
| 2044 | + go app_head
|
|
| 2045 | + | XExpr (ConLikeTc (RealDataCon {})) <- app_head
|
|
| 2046 | + = Deep TopSub
|
|
| 2047 | + | XExpr (ExpandedThingTc _ f) <- app_head
|
|
| 2048 | + = go f
|
|
| 2049 | + | XExpr (WrapExpr _ f) <- app_head
|
|
| 2050 | + = go f
|
|
| 2051 | + | HsVar _ f <- app_head
|
|
| 2052 | + , isDataConId (unLoc f)
|
|
| 2053 | + = Deep TopSub
|
|
| 2054 | + | HsApp _ f _ <- app_head
|
|
| 2055 | + = go (unLoc f)
|
|
| 2056 | + | HsAppType _ f _ <- app_head
|
|
| 2057 | + = go (unLoc f)
|
|
| 2058 | + | OpApp _ _ f _ <- app_head
|
|
| 2059 | + = go (unLoc f)
|
|
| 2060 | + | HsPar _ f <- app_head
|
|
| 2061 | + = go (unLoc f)
|
|
| 2062 | + | otherwise
|
|
| 2063 | + = Shallow
|
|
| 2064 | + |
|
| 2042 | 2065 | |
| 2043 | 2066 | -- | 'tc_sub_type_deep' is where the actual work happens for deep subsumption.
|
| 2044 | 2067 | --
|