Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

7 changed files:

Changes:

  • compiler/GHC/Tc/Gen/Expr.hs
    ... ... @@ -957,7 +957,7 @@ tcSynArgE :: CtOrigin
    957 957 
               -> SyntaxOpType                -- ^ shape it is expected to have
    958 958 
               -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
    959 959 
               -> TcM (a, HsWrapper)
    960 
    -           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
    960 
    +           -- ^ returns a wrapper :: (type of right shape) ~~> (type passed in)
    961 961 
     tcSynArgE orig op sigma_ty syn_ty thing_inside
    962 962 
       = do { (skol_wrap, (result, ty_wrapper))
    963 963 
                <- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty ->
    ... ... @@ -978,10 +978,10 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside
    978 978 
                ; return (result, mkWpCastN list_co) }
    979 979
    980 980 
         go rho_ty (SynFun arg_shape res_shape)
    981 
    -      = do { ( match_wrapper                         -- :: (arg_ty -> res_ty) "->" rho_ty
    981 
    +      = do { ( match_wrapper                         -- :: (arg_ty -> res_ty) ~~> rho_ty
    982 982 
                  , ( ( (result, arg_ty, res_ty, op_mult)
    983 
    -                 , res_wrapper )                     -- :: res_ty_out "->" res_ty
    984 
    -               , arg_wrapper1, [], arg_wrapper2 ) )  -- :: arg_ty "->" arg_ty_out
    983 
    +                 , res_wrapper )                     -- :: res_ty_out ~~> res_ty
    984 
    +               , arg_wrapper1, [], arg_wrapper2 ) )  -- :: arg_ty ~~> arg_ty_out
    985 985 
                    <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
    986 986 
                       \ [ExpFunPatTy arg_ty] res_ty ->
    987 987 
                       do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
    ... ... @@ -1031,7 +1031,7 @@ tcSynArgA :: CtOrigin
    1031 1031 
     tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
    1032 1032 
       = do { (match_wrapper, arg_tys, res_ty)
    1033 1033 
                <- matchActualFunTys herald orig (length arg_shapes) sigma_ty
    1034 
    -              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
    1034 
    +              -- match_wrapper :: sigma_ty ~~> (arg_tys -> res_ty)
    1035 1035 
            ; ((result, res_wrapper), arg_wrappers)
    1036 1036 
                <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
    1037 1037 
                   tc_syn_arg    res_ty  res_shape  $ \ res_results ->
    ... ... @@ -1061,12 +1061,12 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
    1061 1061 
                ; return (result, idHsWrapper) }
    1062 1062 
         tc_syn_arg res_ty SynRho thing_inside
    1063 1063 
           = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
    1064 
    -               -- inst_wrap :: res_ty "->" rho_ty
    1064 
    +               -- inst_wrap :: res_ty ~~> rho_ty
    1065 1065 
                ; result <- thing_inside [rho_ty]
    1066 1066 
                ; return (result, inst_wrap) }
    1067 1067 
         tc_syn_arg res_ty SynList thing_inside
    1068 1068 
           = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
    1069 
    -               -- inst_wrap :: res_ty "->" rho_ty
    1069 
    +               -- inst_wrap :: res_ty ~~> rho_ty
    1070 1070 
                ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty
    1071 1071 
                    -- list_co :: [elt_ty] ~N rho_ty
    1072 1072 
                ; result <- thing_inside [elt_ty]

  • compiler/GHC/Tc/Gen/Pat.hs
    ... ... @@ -329,7 +329,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl
    329 329 
       -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind
    330 330
    331 331 
       | Just bndr_id <- sig_fn bndr_name   -- There is a signature
    332 
    -  = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id)
    332 
    +  = do { wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing exp_pat_ty) (idType bndr_id)
    333 333 
                -- See Note [Subsumption check at pattern variables]
    334 334 
            ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
    335 335 
            ; return (wrap, bndr_id) }
    ... ... @@ -376,10 +376,12 @@ newLetBndr LetLclBndr name w ty
    376 376 
     newLetBndr (LetGblBndr prags) name w ty
    377 377 
       = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name)
    378 378
    379 
    -tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
    380 
    --- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
    381 
    --- Used during typechecking patterns
    382 
    -tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
    379 
    +-- | A version of 'tcSubTypePat' specialised to 'GenSigCtxt'.
    380 
    +--
    381 
    +-- Used during typechecking of patterns.
    382 
    +tcSubTypePat_GenSigCtxt :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
    383 
    +tcSubTypePat_GenSigCtxt penv t1 t2 =
    384 
    +  tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
    383 385
    384 386 
     {- Note [Subsumption check at pattern variables]
    385 387 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -618,111 +620,123 @@ tc_pat :: Scaled ExpSigmaTypeFRR
    618 620 
             -> Checker (Pat GhcRn) (Pat GhcTc)
    619 621 
             -- ^ Translated pattern
    620 622
    621 
    -tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
    622 
    -
    623 
    -  VarPat x (L l name) -> do
    624 
    -        { (wrap, id) <- tcPatBndr penv name pat_ty
    625 
    -        ; res <- tcCheckUsage name (scaledMult pat_ty) $
    626 
    -                              tcExtendIdEnv1 name id thing_inside
    627 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    628 
    -        ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
    629 
    -
    630 
    -  ParPat x pat -> do
    631 
    -        { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
    632 
    -        ; return (ParPat x pat', res) }
    633 
    -
    634 
    -  BangPat x pat -> do
    635 
    -        { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
    636 
    -        ; return (BangPat x pat', res) }
    637 
    -
    638 
    -  OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
    639 
    -    { let pats_list = NE.toList pats
    640 
    -    ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside)
    641 
    -    ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
    642 
    -    ; emitConstraints pat_ct
    643 
    -        -- captureConstraints/extendConstraints:
    644 
    -        --   like in Note [Hopping the LIE in lazy patterns]
    645 
    -    ; pat_ty <- expTypeToType (scaledThing pat_ty)
    646 
    -    ; return (OrPat pat_ty pats', res) }
    647 
    -
    648 
    -  LazyPat x pat -> do
    649 
    -        { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty
    650 
    -        ; (pat', (res, pat_ct))
    651 
    -                <- tc_lpat pat_ty (makeLazy penv) pat $
    652 
    -                   captureConstraints thing_inside
    653 
    -                -- Ignore refined penv', revert to penv
    654 
    -
    655 
    -        ; emitConstraints pat_ct
    656 
    -        -- captureConstraints/extendConstraints:
    657 
    -        --   see Note [Hopping the LIE in lazy patterns]
    658 
    -
    659 
    -        -- Check that the expected pattern type is itself lifted
    660 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    661 
    -        ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
    662 
    -
    663 
    -        ; return ((LazyPat x pat'), res) }
    664 
    -
    665 
    -  WildPat _ -> do
    666 
    -        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
    667 
    -        ; res <- thing_inside
    668 
    -        ; pat_ty <- expTypeToType (scaledThing pat_ty)
    669 
    -        ; return (WildPat pat_ty, res) }
    670 
    -
    671 
    -  AsPat x (L nm_loc name) pat -> do
    672 
    -        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
    673 
    -        ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
    674 
    -        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
    675 
    -                         tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
    676 
    -                                 penv pat thing_inside
    677 
    -            -- NB: if we do inference on:
    678 
    -            --          \ (y@(x::forall a. a->a)) = e
    679 
    -            -- we'll fail.  The as-pattern infers a monotype for 'y', which then
    680 
    -            -- fails to unify with the polymorphic type for 'x'.  This could
    681 
    -            -- perhaps be fixed, but only with a bit more work.
    682 
    -            --
    683 
    -            -- If you fix it, don't forget the bindInstsOfPatIds!
    684 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    685 
    -        ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
    686 
    -
    687 
    -  ViewPat _ expr pat -> do
    688 
    -        { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty
    689 
    -         --
    690 
    -         -- It should be possible to have view patterns at linear (or otherwise
    691 
    -         -- non-Many) multiplicity. But it is not clear at the moment what
    692 
    -         -- restriction need to be put in place, if any, for linear view
    693 
    -         -- patterns to desugar to type-correct Core.
    694 
    -
    695 
    -        ; (expr', expr_rho)    <- tcInferExpr IIF_ShallowRho expr
    696 
    -               -- IIF_ShallowRho: do not perform deep instantiation, regardless of
    697 
    -               -- DeepSubsumption (Note [View patterns and polymorphism])
    698 
    -               -- But we must do top-instantiation to expose the arrow to matchActualFunTy
    699 
    -
    700 
    -         -- Expression must be a function
    701 
    -        ; let herald = ExpectedFunTyViewPat $ unLoc expr
    702 
    -        ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma)
    703 
    -            <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
    704 
    -               -- See Note [View patterns and polymorphism]
    705 
    -               -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
    706 
    -
    707 
    -         -- Check that overall pattern is more polymorphic than arg type
    708 
    -        ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
    709 
    -            -- expr_wrap2 :: pat_ty "->" inf_arg_ty
    710 
    -
    711 
    -         -- Pattern must have inf_res_sigma
    712 
    -        ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside
    713 
    -
    714 
    -        ; let Scaled w h_pat_ty = pat_ty
    715 
    -        ; pat_ty <- readExpType h_pat_ty
    716 
    -        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
    717 
    -                              (Scaled w pat_ty) inf_res_sigma
    718 
    -              -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
    719 
    -              --                (pat_ty -> inf_res_sigma)
    720 
    -              -- NB: pat_ty comes from matchActualFunTy, so it has a
    721 
    -              -- fixed RuntimeRep, as needed to call mkWpFun.
    722 
    -
    723 
    -              expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1
    724 
    -
    725 
    -        ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
    623 
    +tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside =
    624 
    +
    625 
    +  case ps_pat of
    626 
    +
    627 
    +    VarPat x (L l name) -> do
    628 
    +      { (wrap, id) <- tcPatBndr penv name scaled_exp_pat_ty
    629 
    +      ; res <- tcCheckUsage name w_pat $ tcExtendIdEnv1 name id thing_inside
    630 
    +      ; pat_ty <- readExpType exp_pat_ty
    631 
    +      ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
    632 
    +
    633 
    +    ParPat x pat -> do
    634 
    +      { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
    635 
    +      ; return (ParPat x pat', res) }
    636 
    +
    637 
    +    BangPat x pat -> do
    638 
    +      { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
    639 
    +      ; return (BangPat x pat', res) }
    640 
    +
    641 
    +    OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
    642 
    +      { let pats_list   = NE.toList pats
    643 
    +            pat_exp_tys = map (const scaled_exp_pat_ty) pats_list
    644 
    +      ; (pats_list', (res, pat_ct)) <- tc_lpats pat_exp_tys penv pats_list (captureConstraints thing_inside)
    645 
    +      ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
    646 
    +      ; emitConstraints pat_ct
    647 
    +          -- captureConstraints/extendConstraints:
    648 
    +          --   like in Note [Hopping the LIE in lazy patterns]
    649 
    +      ; pat_ty <- expTypeToType exp_pat_ty
    650 
    +      ; return (OrPat pat_ty pats', res) }
    651 
    +
    652 
    +    LazyPat x pat -> do
    653 
    +      { checkManyPattern LazyPatternReason (noLocA ps_pat) scaled_exp_pat_ty
    654 
    +      ; (pat', (res, pat_ct))
    655 
    +              <- tc_lpat scaled_exp_pat_ty (makeLazy penv) pat $
    656 
    +                 captureConstraints thing_inside
    657 
    +              -- Ignore refined penv', revert to penv
    658 
    +
    659 
    +      ; emitConstraints pat_ct
    660 
    +      -- captureConstraints/extendConstraints:
    661 
    +      --   see Note [Hopping the LIE in lazy patterns]
    662 
    +
    663 
    +      -- Check that the expected pattern type is itself lifted
    664 
    +      ; pat_ty <- readExpType exp_pat_ty
    665 
    +      ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
    666 
    +
    667 
    +      ; return ((LazyPat x pat'), res) }
    668 
    +
    669 
    +    WildPat _ -> do
    670 
    +      { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
    671 
    +      ; res <- thing_inside
    672 
    +      ; pat_ty <- expTypeToType exp_pat_ty
    673 
    +      ; return (WildPat pat_ty, res) }
    674 
    +
    675 
    +    AsPat x (L nm_loc name) pat -> do
    676 
    +      { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
    677 
    +      ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name scaled_exp_pat_ty)
    678 
    +      ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
    679 
    +                       tc_lpat (Scaled w_pat (mkCheckExpType $ idType bndr_id))
    680 
    +                               penv pat thing_inside
    681 
    +          -- NB: if we do inference on:
    682 
    +          --          \ (y@(x::forall a. a->a)) = e
    683 
    +          -- we'll fail.  The as-pattern infers a monotype for 'y', which then
    684 
    +          -- fails to unify with the polymorphic type for 'x'.  This could
    685 
    +          -- perhaps be fixed, but only with a bit more work.
    686 
    +          --
    687 
    +          -- If you fix it, don't forget the bindInstsOfPatIds!
    688 
    +      ; pat_ty <- readExpType exp_pat_ty
    689 
    +      ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
    690 
    +
    691 
    +    ViewPat _ view_expr inner_pat -> do
    692 
    +
    693 
    +       -- The pattern is a view pattern, 'pat = (view_expr -> inner_pat)'.
    694 
    +       -- First infer the type of 'view_expr'; the overall type of the pattern
    695 
    +       -- is the argument type of 'view_expr', and the inner pattern type is
    696 
    +       -- checked against the result type of 'view_expr'.
    697 
    +
    698 
    +      { checkManyPattern ViewPatternReason (noLocA ps_pat) scaled_exp_pat_ty
    699 
    +          -- It should be possible to have view patterns at linear (or otherwise
    700 
    +          -- non-Many) multiplicity. But it is not clear at the moment what
    701 
    +          -- restrictions need to be put in place, if any, for linear view
    702 
    +          -- patterns to desugar to type-correct Core.
    703 
    +
    704 
    +         -- Infer the type of 'view_expr'.
    705 
    +      ; (view_expr', view_expr_rho)  <- tcInferExpr IIF_ShallowRho view_expr
    706 
    +             -- IIF_ShallowRho: do not perform deep instantiation, regardless of
    707 
    +             -- DeepSubsumption (Note [View patterns and polymorphism])
    708 
    +             -- But we must do top-instantiation to expose the arrow to matchActualFunTy
    709 
    +
    710 
    +        -- 'view_expr' must be a function; expose its argument/result types
    711 
    +        -- using 'matchActualFunTy'.
    712 
    +      ; let herald = ExpectedFunTyViewPat $ unLoc view_expr
    713 
    +      ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty)
    714 
    +          <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr)
    715 
    +               (1, view_expr_rho) view_expr_rho
    716 
    +             -- See Note [View patterns and polymorphism]
    717 
    +             -- view_expr_co1 :: view_expr_rho ~~> (view_arg_ty -> view_res_ty)
    718 
    +
    719 
    +       -- Check that the overall pattern's type is more polymorphic than
    720 
    +       -- the view function argument type.
    721 
    +      ; view_expr_wrap2 <- tcSubTypePat_GenSigCtxt penv exp_pat_ty view_arg_ty
    722 
    +          -- view_expr_wrap2 :: pat_ty ~~> view_arg_ty
    723 
    +
    724 
    +        -- The inner pattern must have type 'view_res_ty'.
    725 
    +      ; (inner_pat', res) <- tc_lpat (Scaled w_pat (mkCheckExpType view_res_ty)) penv inner_pat thing_inside
    726 
    +
    727 
    +      ; pat_ty <- readExpType exp_pat_ty
    728 
    +      ; let view_expr_wrap2' =
    729 
    +              mkWpFun view_expr_wrap2 idHsWrapper
    730 
    +                (Scaled w_pat pat_ty) view_res_ty
    731 
    +            -- view_expr_wrap2' ::  (view_arg_ty -> view_res_ty)
    732 
    +            --                  ~~> (pat_ty -> view_res_ty)
    733 
    +            -- This satisfies WpFun-FRR-INVARIANT:
    734 
    +            --  'view_arg_ty' was returned by matchActualFunTy, hence FRR
    735 
    +            --  'pat_ty' was passed in and is an 'ExpSigmaTypeFRR'
    736 
    +
    737 
    +            view_expr_wrap = view_expr_wrap2' <.> mkWpCastN view_expr_co1
    738 
    +
    739 
    +      ; return $ (ViewPat pat_ty (mkLHsWrap view_expr_wrap view_expr') inner_pat', res) }
    726 740
    727 741 
     {- Note [View patterns and polymorphism]
    728 742 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -748,93 +762,91 @@ Another example is #26331.
    748 762
    749 763 
     -- Type signatures in patterns
    750 764 
     -- See Note [Pattern coercions] below
    751 
    -  SigPat _ pat sig_ty -> do
    752 
    -        { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
    753 
    -                                                            sig_ty (scaledThing pat_ty)
    754 
    -                -- Using tcExtendNameTyVarEnv is appropriate here
    755 
    -                -- because we're not really bringing fresh tyvars into scope.
    756 
    -                -- We're *naming* existing tyvars. Note that it is OK for a tyvar
    757 
    -                -- from an outer scope to mention one of these tyvars in its kind.
    758 
    -        ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
    759 
    -                         tcExtendNameTyVarEnv tv_binds $
    760 
    -                         tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside
    761 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    762 
    -        ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
    765 
    +    SigPat _ pat sig_ty -> do
    766 
    +      { (inner_ty, tv_binds, wcs, wrap) <-
    767 
    +          tcPatSig (inPatBind penv) sig_ty exp_pat_ty
    768 
    +              -- Using tcExtendNameTyVarEnv is appropriate here
    769 
    +              -- because we're not really bringing fresh tyvars into scope.
    770 
    +              -- We're *naming* existing tyvars. Note that it is OK for a tyvar
    771 
    +              -- from an outer scope to mention one of these tyvars in its kind.
    772 
    +      ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
    773 
    +                       tcExtendNameTyVarEnv tv_binds $
    774 
    +                       tc_lpat (Scaled w_pat $ mkCheckExpType inner_ty) penv pat thing_inside
    775 
    +      ; pat_ty <- readExpType exp_pat_ty
    776 
    +      ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
    763 777
    764 778 
     ------------------------
    765 779 
     -- Lists, tuples, arrays
    766 780
    767 781 
       -- Necessarily a built-in list pattern, not an overloaded list pattern.
    768 782 
       -- See Note [Desugaring overloaded list patterns].
    769 
    -  ListPat _ pats -> do
    770 
    -        { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
    771 
    -        ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
    772 
    -                                     penv pats thing_inside
    773 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    774 
    -        ; return (mkHsWrapPat coi
    775 
    -                         (ListPat elt_ty pats') pat_ty, res) }
    776 
    -
    777 
    -  TuplePat _ pats boxity -> do
    778 
    -        { let arity = length pats
    779 
    -              tc = tupleTyCon boxity arity
    780 
    -              -- NB: tupleTyCon does not flatten 1-tuples
    781 
    -              -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
    782 
    -        ; checkTupSize arity
    783 
    -        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
    784 
    -                                               penv (scaledThing pat_ty)
    785 
    -                     -- Unboxed tuples have RuntimeRep vars, which we discard:
    786 
    -                     -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
    787 
    -        ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
    788 
    -                                           Boxed   -> arg_tys
    789 
    -        ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys)
    783 
    +    ListPat _ pats -> do
    784 
    +      { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv exp_pat_ty
    785 
    +      ; (pats', res) <- tcMultiple (tc_lpat (Scaled w_pat $ mkCheckExpType elt_ty))
    790 786 
                                        penv pats thing_inside
    791 
    -
    792 
    -        ; dflags <- getDynFlags
    793 
    -
    794 
    -        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
    795 
    -        -- so that we can experiment with lazy tuple-matching.
    796 
    -        -- This is a pretty odd place to make the switch, but
    797 
    -        -- it was easy to do.
    798 
    -        ; let
    799 
    -              unmangled_result = TuplePat con_arg_tys pats' boxity
    800 
    -                                 -- pat_ty /= pat_ty iff coi /= IdCo
    801 
    -              possibly_mangled_result
    802 
    -                | gopt Opt_IrrefutableTuples dflags &&
    803 
    -                  isBoxed boxity   = LazyPat noExtField (noLocA unmangled_result)
    804 
    -                | otherwise        = unmangled_result
    805 
    -
    806 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    807 
    -        ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
    808 
    -        ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
    809 
    -        }
    810 
    -
    811 
    -  SumPat _ pat alt arity  -> do
    812 
    -        { let tc = sumTyCon arity
    813 
    -        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
    814 
    -                                               penv (scaledThing pat_ty)
    815 
    -        ; -- Drop levity vars, we don't care about them here
    816 
    -          let con_arg_tys = drop arity arg_tys
    817 
    -        ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
    818 
    -                                 penv pat thing_inside
    819 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    820 
    -        ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
    821 
    -                 , res)
    822 
    -        }
    787 
    +      ; pat_ty <- readExpType exp_pat_ty
    788 
    +      ; return (mkHsWrapPat coi
    789 
    +                       (ListPat elt_ty pats') pat_ty, res) }
    790 
    +
    791 
    +    TuplePat _ pats boxity -> do
    792 
    +      { let arity = length pats
    793 
    +            tc = tupleTyCon boxity arity
    794 
    +            -- NB: tupleTyCon does not flatten 1-tuples
    795 
    +            -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
    796 
    +      ; checkTupSize arity
    797 
    +      ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
    798 
    +                   -- Unboxed tuples have RuntimeRep vars, which we discard:
    799 
    +                   -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
    800 
    +      ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
    801 
    +                                         Boxed   -> arg_tys
    802 
    +      ; (pats', res) <- tc_lpats (map (Scaled w_pat . mkCheckExpType) con_arg_tys)
    803 
    +                                 penv pats thing_inside
    804 
    +
    805 
    +      ; dflags <- getDynFlags
    806 
    +
    807 
    +      -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
    808 
    +      -- so that we can experiment with lazy tuple-matching.
    809 
    +      -- This is a pretty odd place to make the switch, but
    810 
    +      -- it was easy to do.
    811 
    +      ; let
    812 
    +            unmangled_result = TuplePat con_arg_tys pats' boxity
    813 
    +                               -- pat_ty /= pat_ty iff coi /= IdCo
    814 
    +            possibly_mangled_result
    815 
    +              | gopt Opt_IrrefutableTuples dflags &&
    816 
    +                isBoxed boxity   = LazyPat noExtField (noLocA unmangled_result)
    817 
    +              | otherwise        = unmangled_result
    818 
    +
    819 
    +      ; pat_ty <- readExpType exp_pat_ty
    820 
    +      ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
    821 
    +      ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
    822 
    +      }
    823 
    +
    824 
    +    SumPat _ pat alt arity  -> do
    825 
    +      { let tc = sumTyCon arity
    826 
    +      ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
    827 
    +      ; -- Drop levity vars, we don't care about them here
    828 
    +        let con_arg_tys = drop arity arg_tys
    829 
    +      ; (pat', res) <- tc_lpat (Scaled w_pat $ mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
    830 
    +                               penv pat thing_inside
    831 
    +      ; pat_ty <- readExpType exp_pat_ty
    832 
    +      ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
    833 
    +               , res)
    834 
    +      }
    823 835
    824 836 
     ------------------------
    825 837 
     -- Data constructors
    826 
    -  ConPat _ con arg_pats ->
    827 
    -    tcConPat penv con pat_ty arg_pats thing_inside
    838 
    +    ConPat _ con arg_pats ->
    839 
    +      tcConPat penv con scaled_exp_pat_ty arg_pats thing_inside
    828 840
    829 841 
     ------------------------
    830 842 
     -- Literal patterns
    831 
    -  LitPat x simple_lit -> do
    832 
    -        { let lit_ty = hsLitType simple_lit
    833 
    -        ; wrap   <- tc_sub_type penv (scaledThing pat_ty) lit_ty
    834 
    -        ; res    <- thing_inside
    835 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    836 
    -        ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
    837 
    -                 , res) }
    843 
    +    LitPat x simple_lit -> do
    844 
    +      { let lit_ty = hsLitType simple_lit
    845 
    +      ; wrap   <- tcSubTypePat_GenSigCtxt penv exp_pat_ty lit_ty
    846 
    +      ; res    <- thing_inside
    847 
    +      ; pat_ty <- readExpType exp_pat_ty
    848 
    +      ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
    849 
    +               , res) }
    838 850
    839 851 
     ------------------------
    840 852 
     -- Overloaded patterns: n, and n+k
    ... ... @@ -854,31 +866,31 @@ Another example is #26331.
    854 866 
     -- where lit_ty is the type of the overloaded literal 5.
    855 867 
     --
    856 868 
     -- When there is no negation, neg_lit_ty and lit_ty are the same
    857 
    -  NPat _ (L l over_lit) mb_neg eq -> do
    858 
    -        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
    859 
    -          -- It may be possible to refine linear pattern so that they work in
    860 
    -          -- linear environments. But it is not clear how useful this is.
    861 
    -        ; let orig = LiteralOrigin over_lit
    862 
    -        ; ((lit', mb_neg'), eq')
    863 
    -            <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny]
    864 
    -                          (mkCheckExpType boolTy) $
    865 
    -               \ [neg_lit_ty] _ ->
    866 
    -               let new_over_lit lit_ty = newOverloadedLit over_lit
    867 
    -                                           (mkCheckExpType lit_ty)
    868 
    -               in case mb_neg of
    869 
    -                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
    870 
    -                 Just neg -> -- Negative literal
    871 
    -                             -- The 'negate' is re-mappable syntax
    872 
    -                   second Just <$>
    873 
    -                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
    874 
    -                    \ [lit_ty] _ -> new_over_lit lit_ty)
    875 
    -                     -- applied to a closed literal: linearity doesn't matter as
    876 
    -                     -- literals are typed in an empty environment, hence have
    877 
    -                     -- all multiplicities.
    878 
    -
    879 
    -        ; res <- thing_inside
    880 
    -        ; pat_ty <- readExpType (scaledThing pat_ty)
    881 
    -        ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
    869 
    +    NPat _ (L l over_lit) mb_neg eq -> do
    870 
    +      { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
    871 
    +        -- It may be possible to refine linear pattern so that they work in
    872 
    +        -- linear environments. But it is not clear how useful this is.
    873 
    +      ; let orig = LiteralOrigin over_lit
    874 
    +      ; ((lit', mb_neg'), eq')
    875 
    +          <- tcSyntaxOp orig eq [SynType exp_pat_ty, SynAny]
    876 
    +                        (mkCheckExpType boolTy) $
    877 
    +             \ [neg_lit_ty] _ ->
    878 
    +             let new_over_lit lit_ty = newOverloadedLit over_lit
    879 
    +                                         (mkCheckExpType lit_ty)
    880 
    +             in case mb_neg of
    881 
    +               Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
    882 
    +               Just neg -> -- Negative literal
    883 
    +                           -- The 'negate' is re-mappable syntax
    884 
    +                 second Just <$>
    885 
    +                 (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
    886 
    +                  \ [lit_ty] _ -> new_over_lit lit_ty)
    887 
    +                   -- applied to a closed literal: linearity doesn't matter as
    888 
    +                   -- literals are typed in an empty environment, hence have
    889 
    +                   -- all multiplicities.
    890 
    +
    891 
    +      ; res <- thing_inside
    892 
    +      ; pat_ty <- readExpType exp_pat_ty
    893 
    +      ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
    882 894
    883 895 
     {-
    884 896 
     Note [NPlusK patterns]
    ... ... @@ -904,68 +916,67 @@ AST is used for the subtraction operation.
    904 916 
     -}
    905 917
    906 918 
     -- See Note [NPlusK patterns]
    907 
    -  NPlusKPat _ (L nm_loc name)
    908 
    -               (L loc lit) _ ge minus -> do
    909 
    -        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
    910 
    -        ; let pat_exp_ty = scaledThing pat_ty
    911 
    -              orig = LiteralOrigin lit
    912 
    -        ; (lit1', ge')
    913 
    -            <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho]
    914 
    -                                  (mkCheckExpType boolTy) $
    915 
    -               \ [lit1_ty] _ ->
    916 
    -               newOverloadedLit lit (mkCheckExpType lit1_ty)
    917 
    -        ; ((lit2', minus_wrap, bndr_id), minus')
    918 
    -            <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
    919 
    -               \ [lit2_ty, var_ty] _ ->
    920 
    -               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
    921 
    -                  ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
    922 
    -                                     tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
    923 
    -                           -- co :: var_ty ~ idType bndr_id
    924 
    -
    925 
    -                           -- minus_wrap is applicable to minus'
    926 
    -                  ; return (lit2', wrap, bndr_id) }
    927 
    -
    928 
    -        ; pat_ty <- readExpType pat_exp_ty
    929 
    -
    930 
    -        -- The Report says that n+k patterns must be in Integral
    931 
    -        -- but it's silly to insist on this in the RebindableSyntax case
    932 
    -        ; unlessM (xoptM LangExt.RebindableSyntax) $
    933 
    -          do { icls <- tcLookupClass integralClassName
    934 
    -             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
    935 
    -
    936 
    -        ; res <- tcExtendIdEnv1 name bndr_id thing_inside
    937 
    -
    938 
    -        ; let minus'' = case minus' of
    939 
    -                          NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
    940 
    -                                   -- this should be statically avoidable
    941 
    -                                   -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
    942 
    -                          SyntaxExprTc { syn_expr = minus'_expr
    943 
    -                                       , syn_arg_wraps = minus'_arg_wraps
    944 
    -                                       , syn_res_wrap = minus'_res_wrap }
    945 
    -                            -> SyntaxExprTc { syn_expr = minus'_expr
    946 
    -                                            , syn_arg_wraps = minus'_arg_wraps
    947 
    -                                            , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
    948 
    -                             -- Oy. This should really be a record update, but
    949 
    -                             -- we get warnings if we try. #17783
    950 
    -              pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
    951 
    -                               ge' minus''
    952 
    -        ; return (pat', res) }
    919 
    +    NPlusKPat _ (L nm_loc name)
    920 
    +             (L loc lit) _ ge minus -> do
    921 
    +      { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
    922 
    +      ; let orig = LiteralOrigin lit
    923 
    +      ; (lit1', ge')
    924 
    +          <- tcSyntaxOp orig ge [SynType exp_pat_ty, SynRho]
    925 
    +                                (mkCheckExpType boolTy) $
    926 
    +             \ [lit1_ty] _ ->
    927 
    +             newOverloadedLit lit (mkCheckExpType lit1_ty)
    928 
    +      ; ((lit2', minus_wrap, bndr_id), minus')
    929 
    +          <- tcSyntaxOpGen orig minus [SynType exp_pat_ty, SynRho] SynAny $
    930 
    +             \ [lit2_ty, var_ty] _ ->
    931 
    +             do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
    932 
    +                ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
    933 
    +                                   tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
    934 
    +                         -- co :: var_ty ~ idType bndr_id
    935 
    +
    936 
    +                         -- minus_wrap is applicable to minus'
    937 
    +                ; return (lit2', wrap, bndr_id) }
    938 
    +
    939 
    +      ; pat_ty <- readExpType exp_pat_ty
    940 
    +
    941 
    +      -- The Report says that n+k patterns must be in Integral
    942 
    +      -- but it's silly to insist on this in the RebindableSyntax case
    943 
    +      ; unlessM (xoptM LangExt.RebindableSyntax) $
    944 
    +        do { icls <- tcLookupClass integralClassName
    945 
    +           ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
    946 
    +
    947 
    +      ; res <- tcExtendIdEnv1 name bndr_id thing_inside
    948 
    +
    949 
    +      ; let minus'' = case minus' of
    950 
    +                        NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
    951 
    +                                 -- this should be statically avoidable
    952 
    +                                 -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
    953 
    +                        SyntaxExprTc { syn_expr = minus'_expr
    954 
    +                                     , syn_arg_wraps = minus'_arg_wraps
    955 
    +                                     , syn_res_wrap = minus'_res_wrap }
    956 
    +                          -> SyntaxExprTc { syn_expr = minus'_expr
    957 
    +                                          , syn_arg_wraps = minus'_arg_wraps
    958 
    +                                          , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
    959 
    +                           -- Oy. This should really be a record update, but
    960 
    +                           -- we get warnings if we try. #17783
    961 
    +            pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
    962 
    +                             ge' minus''
    963 
    +      ; return (pat', res) }
    953 964
    954 965 
     -- Here we get rid of it and add the finalizers to the global environment.
    955 966 
     -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
    956 
    -  SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
    967 
    +    SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
    957 968 
           { addModFinalizersWithLclEnv mod_finalizers
    958 
    -      ; tc_pat pat_ty penv pat thing_inside }
    969 
    +      ; tc_pat scaled_exp_pat_ty penv pat thing_inside }
    959 970
    960 
    -  SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
    971 
    +    SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
    961 972
    962 
    -  EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
    973 
    +    EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
    963 974
    964 
    -  InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
    975 
    +    InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
    965 976
    966 
    -  XPat (HsPatExpanded lpat rpat) -> do
    967 
    -    { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
    968 
    -    ; return (XPat $ ExpansionPat lpat rpat', res) }
    977 
    +    XPat (HsPatExpanded lpat rpat) -> do
    978 
    +      { (rpat', res) <- tc_pat scaled_exp_pat_ty penv rpat thing_inside
    979 
    +      ; return (XPat $ ExpansionPat lpat rpat', res) }
    969 980
    970 981 
     {-
    971 982 
     Note [Hopping the LIE in lazy patterns]
    ... ... @@ -1295,7 +1306,7 @@ tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside
    1295 1306
    1296 1307 
             ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats
    1297 1308
    1298 
    -        ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty'
    1309 
    +        ; wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing pat_ty) ty'
    1299 1310
    1300 1311 
             ; traceTc "tcPatSynPat" $
    1301 1312 
               vcat [ text "Pat syn:" <+> ppr pat_syn
    ... ... @@ -1405,8 +1416,9 @@ matchExpectedConTy :: PatEnv
    1405 1416 
                            -- In the case of a data family, this would
    1406 1417 
                            -- mention the /family/ TyCon
    1407 1418 
                        -> TcM (HsWrapper, [TcSigmaType])
    1408 
    --- See Note [Matching constructor patterns]
    1409 
    --- Returns a wrapper : pat_ty "->" T ty1 ... tyn
    1419 
    +-- ^ See Note [Matching constructor patterns]
    1420 
    +--
    1421 
    +-- Returns a wrapper : pat_ty ~~> T ty1 ... tyn
    1410 1422 
     matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
    1411 1423 
       | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
    1412 1424 
              -- Comments refer to Note [Matching constructor patterns]

  • compiler/GHC/Tc/Types/Evidence.hs
    ... ... @@ -197,29 +197,29 @@ that it is a no-op. Here's our solution:
    197 197 
         * we /must/ optimise subtype-HsWrappers (that's the point of this Note!)
    198 198 
         * there is little point in attempting to optimise any other HsWrappers
    199 199
    200 
    -Note [WpFun-RR-INVARIANT]
    201 
    -~~~~~~~~~~~~~~~~~~~~~~~~~
    200 
    +Note [WpFun-FRR-INVARIANT]
    201 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~
    202 202 
     Given
    203 203 
       wrap = WpFun wrap1 wrap2 sty1 ty2
    204 204 
       where:  wrap1 :: exp_arg ~~> act_arg
    205 205 
               wrap2 :: act_res ~~> exp_res
    206 206 
               wrap  :: (act_arg -> act_res) ~~> (exp_arg -> exp_res)
    207 207 
     we have
    208 
    -  WpFun-RR-INVARIANT:
    208 
    +  WpFun-FRR-INVARIANT:
    209 209 
           the input (exp_arg) and output (act_arg) types of `wrap1`
    210 210 
           both have a fixed runtime-rep
    211 211
    212 212 
     Reason: We desugar wrap[e] into
    213 213 
         \(x:exp_arg). wrap2[ e wrap1[x] ]
    214 
    -And then, because of Note [Representation polymorphism invariants], we need:
    214 
    +And then, because of Note [Representation polymorphism invariants]:
    215 215
    216 216 
       * `exp_arg` must have a fixed runtime rep,
    217 217 
         so that lambda obeys the the FRR rules
    218 218
    219 219 
       * `act_arg` must have a fixed runtime rep,
    220 
    -    so the that application (e wrap1[x]) obeys the FRR tules
    220 
    +    so that the application (e wrap1[x]) obeys the FRR rules
    221 221
    222 
    -Hence WpFun-INVARIANT.
    222 
    +Hence WpFun-FRR-INVARIANT.
    223 223 
     -}
    224 224
    225 225 
     data HsWrapper
    ... ... @@ -246,7 +246,7 @@ data HsWrapper
    246 246 
            -- (WpFun wrap1 wrap2 (w, t1) t2)[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ]
    247 247 
            --
    248 248 
            -- INVARIANT: both input and output types of `wrap1` have a fixed runtime-rep
    249 
    -       --            See Note [WpFun-RR-INVARIANT]
    249 
    +       --            See Note [WpFun-FRR-INVARIANT]
    250 250 
            --
    251 251 
            -- Typing rules:
    252 252 
            -- If    e     :: act_arg -> act_res
    ... ... @@ -319,7 +319,7 @@ mkWpFun :: HsWrapper -> HsWrapper
    319 319 
     -- ^ Smart constructor for `WpFun`
    320 320 
     -- Just removes clutter and optimises some common cases.
    321 321 
     --
    322 
    --- PRECONDITION: same as Note [WpFun-RR-INVARIANT]
    322 
    +-- PRECONDITION: same as Note [WpFun-FRR-INVARIANT]
    323 323 
     --
    324 324 
     -- Unfortunately, we can't check PRECONDITION with an assertion here, because of
    325 325 
     -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.

  • compiler/GHC/Tc/Utils/Instantiate.hs
    ... ... @@ -277,7 +277,7 @@ skolemiseRequired skolem_info n_req sigma
    277 277 
     topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
    278 278 
     -- Instantiate outer invisible binders (both Inferred and Specified)
    279 279 
     -- If    top_instantiate ty = (wrap, inner_ty)
    280 
    --- then  wrap :: inner_ty "->" ty
    280 
    +-- then  wrap :: inner_ty ~~> ty
    281 281 
     -- NB: returns a type with no (=>),
    282 282 
     --     and no invisible forall at the top
    283 283 
     topInstantiate orig sigma

  • compiler/GHC/Tc/Utils/Unify.hs
    ... ... @@ -66,7 +66,6 @@ module GHC.Tc.Utils.Unify (
    66 66 
     import GHC.Prelude
    67 67
    68 68 
     import GHC.Hs
    69 
    -
    70 69 
     import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) )
    71 70 
     import GHC.Tc.Errors.Ppr   ( pprErrCtxtMsg )
    72 71 
     import GHC.Tc.Utils.Concrete
    ... ... @@ -256,24 +255,24 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected
    256 255 
     --       and res_ty is a RhoType
    257 256 
     -- NB: the returned type is top-instantiated; it's a RhoType
    258 257 
     matchActualFunTys herald ct_orig n_val_args_wanted top_ty
    259 
    -  = go n_val_args_wanted [] top_ty
    258 
    +  = go n_val_args_wanted top_ty
    260 259 
       where
    261 
    -    go n so_far fun_ty
    260 
    +    go n fun_ty
    262 261 
           | not (isRhoTy fun_ty)
    263 262 
           = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty
    264 
    -           ; (wrap2, arg_tys, res_ty) <- go n so_far rho
    263 
    +           ; (wrap2, arg_tys, res_ty) <- go n rho
    265 264 
                ; return (wrap2 <.> wrap1, arg_tys, res_ty) }
    266 265
    267 
    -    go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
    266 
    +    go 0 fun_ty = return (idHsWrapper, [], fun_ty)
    268 267
    269 
    -    go n so_far fun_ty
    270 
    -      = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing
    271 
    -                                           (n_val_args_wanted, top_ty) fun_ty
    272 
    -           ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
    273 
    -           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
    274 
    -           -- NB: arg_ty1 comes from matchActualFunTy, so it has
    275 
    -           -- a syntactically fixed RuntimeRep
    276 
    -           ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) }
    268 
    +    go n fun_ty
    269 
    +      = do { (co1, arg1_ty_frr, res_ty1) <-
    270 
    +                matchActualFunTy herald Nothing (n_val_args_wanted, top_ty) fun_ty
    271 
    +           ; (wrap_res, arg_tys, res_ty) <- go (n-1) res_ty1
    272 
    +           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg1_ty_frr res_ty
    273 
    +              -- This call to mkWpFun satisfies WpFun-FRR-INVARIANT:
    274 
    +              -- 'arg1_ty_frr' comes from matchActualFunTy, so is FRR.
    275 
    +           ; return (wrap_fun2 <.> mkWpCastN co1, arg1_ty_frr:arg_tys, res_ty) }
    277 276
    278 277 
     {-
    279 278 
     ************************************************************************
    ... ... @@ -866,12 +865,30 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
    866 865 
           = assert (isVisibleFunArg af) $
    867 866 
             do { let arg_pos = arity - n_req + 1   -- 1 for the first argument etc
    868 867 
                ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
    869 
    -           ; let arg_sty_frr = Scaled mult arg_ty_frr
    870 
    -           ; (wrap_res, result) <- check (n_req - 1)
    871 
    -                                         (mkCheckExpFunPatTy arg_sty_frr : rev_pat_tys)
    868 
    +           ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr
    869 
    +           ; (res_wrap, result) <- check (n_req - 1)
    870 
    +                                         (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys)
    872 871 
                                              res_ty
    873 
    -           ; let wrap_arg = mkWpCastN arg_co
    874 
    -                 fun_wrap = mkWpFun wrap_arg wrap_res arg_sty_frr res_ty
    872 
    +
    873 
    +            -- arg_co :: arg_ty ~ arg_ty_frr
    874 
    +            -- res_wrap :: act_res_ty ~~> res_ty
    875 
    +           ; let fun_wrap1 -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty_frr -> res_ty)
    876 
    +                   = mkWpFun idHsWrapper res_wrap scaled_arg_ty_frr res_ty
    877 
    +                       -- Satisfies WpFun-FRR-INVARIANT because arg_sty_frr is FRR
    878 
    +
    879 
    +                 fun_wrap2 -- :: (arg_ty_frr -> res_ty) ~~> (arg_ty -> res_ty)
    880 
    +                   = mkWpCastN (mkFunCo Nominal af (mkNomReflCo mult) (mkSymCo arg_co) (mkNomReflCo res_ty))
    881 
    +
    882 
    +                 fun_wrap -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty -> res_ty)
    883 
    +                   = fun_wrap2 <.> fun_wrap1
    884 
    +
    885 
    +-- NB: in the common case, 'arg_ty' is already FRR (in the sense of
    886 
    +--     Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete), hence 'arg_co' is 'Refl'.
    887 
    +--     Then 'fun_wrap' will collapse down to 'fun_wrap1'. This applies recursively;
    888 
    +--     as 'mkWpFun WpHole WpHole' is 'WpHole', this means that 'fun_wrap' will
    889 
    +--     typically just be 'WpHole'; no clutter.
    890 
    +--     This is important because 'matchExpectedFunTys' is called a lot.
    891 
    +
    875 892 
                ; return (fun_wrap, result) }
    876 893
    877 894 
         ----------------------------
    ... ... @@ -1404,7 +1421,7 @@ tcSubTypeMono rn_expr act_ty exp_ty
    1404 1421
    1405 1422 
     ------------------------
    1406 1423 
     tcSubTypePat :: CtOrigin -> UserTypeCtxt
    1407 
    -            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
    1424 
    +             -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
    1408 1425 
     -- Used in patterns; polarity is backwards compared
    1409 1426 
     --   to tcSubType
    1410 1427 
     -- If wrap = tc_sub_type_et t1 t2

  • testsuite/tests/rep-poly/T26528.hs
    1 
    +{-# LANGUAGE GHC2024, TypeFamilies #-}
    2 
    +
    3 
    +module T26528 where
    4 
    +
    5 
    +import Data.Kind
    6 
    +import GHC.Exts
    7 
    +
    8 
    +type F :: Type -> RuntimeRep
    9 
    +type family F a where
    10 
    +  F Int = LiftedRep
    11 
    +
    12 
    +g :: forall (r::RuntimeRep).
    13 
    +     (forall (a :: TYPE r). a -> forall b. b -> b) -> Int
    14 
    +g _ = 3
    15 
    +{-# NOINLINE g #-}
    16 
    +
    17 
    +foo = g @(F Int) (\x y -> y)

  • testsuite/tests/rep-poly/all.T
    ... ... @@ -42,6 +42,7 @@ test('T23883b', normal, compile_fail, [''])
    42 42 
     test('T23883c', normal, compile_fail, [''])
    43 43 
     test('T23903', normal, compile_fail, [''])
    44 44 
     test('T26107', js_broken(22364), compile, ['-O'])
    45 
    +test('T26528', normal, compile, [''])
    45 46
    46 47 
     test('EtaExpandDataCon', normal, compile, ['-O'])
    47 48 
     test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help