GitLab

Simon Peyton Jones pushed to branch wip/ani/no-ds-flag-cache at Glasgow Haskell Compiler / GHC

Commits:

b5adc452
by Simon Peyton Jones at 2026-03-30T17:45:43+01:00
```
More wibbles
```

4 changed files:

compiler/GHC/Tc/Gen/App.hs
− compiler/GHC/Tc/Gen/App.hs-boot
compiler/GHC/Tc/Gen/Head.hs
compiler/GHC/Tc/Utils/Unify.hs

Changes:

@@ -11,7 +11,6 @@
  module GHC.Tc.Gen.App
         ( tcApp
 -       , tcExprSigma
         , tcExprPrag ) where
  import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )
@@ -165,34 +164,6 @@ Note [Instantiation variables are short lived]
  -}
 -{- *********************************************************************
 -*                                                                      *
 -              tcInferSigma
 -*                                                                      *
 -********************************************************************* -}
+-
 --- Very similar to tcApp, but returns a sigma (uninstantiated) type
 --- CAUTION: Any changes to tcApp should be reflected here
 --- cf. T19167. the head is an expanded expression applied to a type
 --- Caution: Currently we assume that the expression is compiler generated/expanded
 --- Because that is what T19167 test case expects.
 --- This function should go away after MR!15778 lands
 -tcExprSigma :: Bool -> CtOrigin -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
 -tcExprSigma inst fun_orig rn_expr
 -  = do { (fun@(rn_fun,fun_lspan), rn_args) <- splitHsApps rn_expr
 -       ; do_ql <- wantQuickLook rn_fun
 -       ; (tc_fun, fun_sigma) <- tcInferAppHead fun
 -       ; inGenCode <- inGeneratedCode
 -       ; traceTc "tcExprSigma" (vcat [ text "rn_expr:" <+> ppr rn_expr
 -                                     , text "tc_fun" <+> ppr tc_fun
 -                                     , text "inGeneratedCode:" <+> ppr inGenCode])
 -       ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (fun_orig, rn_fun, fun_lspan)
 -                                           tc_fun fun_sigma rn_args
 -       ; tc_args <- tcValArgs do_ql (rn_fun, fun_lspan) inst_args
 -       ; let tc_expr = rebuildHsApps (tc_fun, fun_lspan) tc_args
 -       ; return (tc_expr, app_res_sigma) }
+-
+-
  {- *********************************************************************
  *                                                                      *
                Typechecking n-ary applications

compiler/GHC/Tc/Gen/App.hs-boot deleted

 -module GHC.Tc.Gen.App where
+-
 -import GHC.Hs ( HsExpr )
 -import GHC.Tc.Types  ( TcM )
 -import GHC.Tc.Types.Origin  ( CtOrigin )
 -import GHC.Tc.Utils.TcType ( TcSigmaType )
 -import GHC.Hs.Extension ( GhcRn, GhcTc )
+-
+-
 -import GHC.Prelude (Bool)
+-
 -tcExprSigma :: Bool -> CtOrigin -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)

compiler/GHC/Tc/Gen/Head.hs

@@ -445,8 +445,7 @@ tcInferAppHead (fun,fun_lspan)
      do { mb_tc_fun <- tcInferAppHead_maybe fun
         ; case mb_tc_fun of
              Just (fun', fun_sigma) -> return (fun', fun_sigma)
 -            Nothing -> tcInferExprSigma fun
+-
 +            Nothing                -> tcInferExprSigma fun
+        }
  tcInferAppHead_maybe :: HsExpr GhcRn
@@ -456,24 +455,11 @@ tcInferAppHead_maybe :: HsExpr GhcRn
  -- XExpr's although complicated needs to be looked through, useful for QL things when
  -- the argument is an XExpr
  tcInferAppHead_maybe fun = case fun of
 -      HsVar _ nm
 -        -> Just <$> tcInferId nm
 -      ExprWithTySig _ e hs_ty
 -        -> Just <$>tcExprWithSig e hs_ty
 -      HsOverLit _ lit
 -        -> Just <$> tcInferOverLit lit
 -      XExpr (HsRecSelRn f)
 -        -> Just <$> tcInferRecSelId f
+-
 ---      XExpr (ExpandedThingRn (HSE o (L loc e)))
 ---        -> setSrcSpan (locA loc) $ Just <$>
 ---           do { (e', ty) <- tcExprSigma False (hsCtxtCtOrigin o) e
 ---              ; return (mkExpandedTc o (L loc e'), ty) }
 ---                      -- We do not want to instantiate the type of the head as there may be
 ---                      -- visible type applications in the argument.
 ---                      -- c.f. T19167
 -      _
 -        -> return Nothing
 +      HsVar _ nm              -> Just <$> tcInferId nm
 +      ExprWithTySig _ e hs_ty -> Just <$>tcExprWithSig e hs_ty
 +      HsOverLit _ lit         -> Just <$> tcInferOverLit lit
 +      XExpr (HsRecSelRn f)    -> Just <$> tcInferRecSelId f
 +      _                       -> return Nothing
  {- *********************************************************************
  *                                                                      *

compiler/GHC/Tc/Utils/Unify.hs

@@ -1261,17 +1261,28 @@ we simply look to see if the hole is filled already.
  But consider
      case x of
        True  -> True
 -      False -> error "urk"
 +      False -> undefined
  and suppose we call `tcInferSigma` on this expression, so that the `ir_inst`
  field of the expected result type is `IIF_Sigma`.   The danger is that we'll
  fill the hole with `Bool` (from the `True`) and then reject when we try to
 -unify that with `forall a. a->a`, from the call to `error`.
 +unify that with `forall a. a->a`, from the call to `undefined`.
++
 +Another example:
 +   case x of
 +     True  -> (e1 :: forall a b. a->b)
 +     False -> (e3 :: forall b a. a->b)
  To avoid this, we never infer a sigma-type from a multi-branch `case`.  Instead
  we just zap the `IIF_Sigma` to `IIF_DeepRho` when walking inside the branches
  of multi-arm case-expression, or an if-expression. See calls to
  `adjustExpTypeForCaseBranches`.
 +This does mean that this would work:
 +   (let x = 77+55 in h x x) @Int
 +where
 +   h :: Int -> Int -> forall a. a->a
 +The `@Int` would instantiate the `forall a`.
++
  Note that
        case e of
          True  -> hr