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

Commits:

16 changed files:

Changes:

  • compiler/GHC/Core/Make.hs
    ... ... @@ -111,7 +111,7 @@ sortQuantVars vs = sorted_tcvs ++ ids
    111 111
    112 112 
     -- | Bind a binding group over an expression, using a @let@ or @case@ as
    113 113 
     -- appropriate (see "GHC.Core#let_can_float_invariant")
    114 
    -mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
    114 
    +mkCoreLet :: HasDebugCallStack => CoreBind -> CoreExpr -> CoreExpr
    115 115 
     mkCoreLet (NonRec bndr rhs) body        -- See Note [Core let-can-float invariant]
    116 116 
       = bindNonRec bndr rhs body
    117 117 
     mkCoreLet bind body
    ... ... @@ -133,7 +133,7 @@ mkCoreTyLams binders body = mkCast lam co
    133 133
    134 134 
     -- | Bind a list of binding groups over an expression. The leftmost binding
    135 135 
     -- group becomes the outermost group in the resulting expression
    136 
    -mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
    136 
    +mkCoreLets :: HasDebugCallStack => [CoreBind] -> CoreExpr -> CoreExpr
    137 137 
     mkCoreLets binds body = foldr mkCoreLet body binds
    138 138
    139 139 
     -- | Construct an expression which represents the application of a number of

  • compiler/GHC/Core/PatSyn.hs
    ... ... @@ -9,7 +9,7 @@
    9 9
    10 10 
     module GHC.Core.PatSyn (
    11 11 
             -- * Main data types
    12 
    -        PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn,
    12 
    +        PatSyn(..), PatSynMatcher, PatSynBuilder, mkPatSyn,
    13 13
    14 14 
             -- ** Type deconstruction
    15 15 
             patSynName, patSynArity, patSynVisArity,

  • compiler/GHC/HsToCore/Utils.hs
    ... ... @@ -259,12 +259,12 @@ wrapBind new old body -- NB: this function must deal with term
    259 259 
     seqVar :: Var -> CoreExpr -> CoreExpr
    260 260 
     seqVar var body = mkDefaultCase (Var var) var body
    261 261
    262 
    -mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr
    262 
    +mkCoLetMatchResult :: HasDebugCallStack => CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr
    263 263 
     mkCoLetMatchResult bind = fmap (mkCoreLet bind)
    264 264
    265 265 
     -- (mkViewMatchResult var' viewExpr mr) makes the expression
    266 266 
     -- let var' = viewExpr in mr
    267 
    -mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
    267 
    +mkViewMatchResult :: HasDebugCallStack => Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
    268 268 
     mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr
    269 269
    270 270 
     mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr

  • compiler/GHC/Tc/Module.hs
    ... ... @@ -579,7 +579,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls
    579 579 
             -- Zonk the final code.  This must be done last.
    580 580 
             -- Even simplifyTop may do some unification.
    581 581 
             -- This pass also warns about missing type signatures
    582 
    -      ; (id_env, ev_binds', binds', fords', imp_specs', rules')
    582 
    +      ; (id_env, ev_binds', binds', fords', imp_specs', rules', pat_syns')
    583 583 
                 <- zonkTcGblEnv new_ev_binds tcg_env
    584 584
    585 585 
           --------- Run finalizers --------------
    ... ... @@ -597,6 +597,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls
    597 597 
                                        , tcg_imp_specs = []
    598 598 
                                        , tcg_rules     = []
    599 599 
                                        , tcg_fords     = []
    600 
    +                                   , tcg_patsyns   = []
    600 601 
                                        , tcg_type_env  = tcg_type_env tcg_env
    601 602 
                                                          `plusTypeEnv` id_env }
    602 603 
           ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env
    ... ... @@ -628,7 +629,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls
    628 629 
           -- Zonk the new bindings arising from running the finalisers,
    629 630 
           -- and main. This won't give rise to any more finalisers as you
    630 631 
           -- can't nest finalisers inside finalisers.
    631 
    -      ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
    632 
    +      ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf, patsyns_mf)
    632 633 
                 <- zonkTcGblEnv main_ev_binds tcg_env
    633 634
    634 635 
           ; let { !final_type_env = tcg_type_env tcg_env
    ... ... @@ -642,24 +643,26 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls
    642 643 
                               , tcg_ev_binds  = ev_binds' `unionBags` ev_binds_mf
    643 644 
                               , tcg_imp_specs = imp_specs' ++ imp_specs_mf
    644 645 
                               , tcg_rules     = rules'     ++ rules_mf
    645 
    -                          , tcg_fords     = fords'     ++ fords_mf } } ;
    646 
    +                          , tcg_fords     = fords'     ++ fords_mf
    647 
    +                          , tcg_patsyns   = pat_syns'  ++ patsyns_mf } } ;
    646 648
    647 649 
           ; setGlobalTypeEnv tcg_env' final_type_env
    648 650 
        }
    649 651
    650 652 
     zonkTcGblEnv :: Bag EvBind -> TcGblEnv
    651 653 
                  -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
    652 
    -                       [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
    654 
    +                       [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc], [PatSyn])
    653 655 
     zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds     = binds
    654 656 
                                             , tcg_ev_binds  = cur_ev_binds
    655 657 
                                             , tcg_imp_specs = imp_specs
    656 658 
                                             , tcg_rules     = rules
    657 
    -                                        , tcg_fords     = fords })
    659 
    +                                        , tcg_fords     = fords
    660 
    +                                        , tcg_patsyns   = pat_syns })
    658 661 
       = {-# SCC "zonkTopDecls" #-}
    659 662 
         setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering
    660 663 
                             --   error messages during zonking (notably levity errors)
    661 664 
         do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds
    662 
    -       ; zonkTopDecls all_ev_binds binds rules imp_specs fords }
    665 
    +       ; zonkTopDecls all_ev_binds binds rules imp_specs fords pat_syns }
    663 666
    664 667 
     -- | Runs TH finalizers and renames and typechecks the top-level declarations
    665 668 
     -- that they could introduce.

  • compiler/GHC/Tc/TyCl/PatSyn.hs
    ... ... @@ -23,7 +23,6 @@ import GHC.Hs
    23 23 
     import GHC.Tc.Gen.Pat
    24 24 
     import GHC.Tc.Utils.Env
    25 25 
     import GHC.Tc.Utils.TcMType
    26 
    -import GHC.Tc.Zonk.Type
    27 26 
     import GHC.Tc.Errors.Types
    28 27 
     import GHC.Tc.Utils.Monad
    29 28 
     import GHC.Tc.Zonk.TcType
    ... ... @@ -37,10 +36,10 @@ import GHC.Tc.Types.Origin
    37 36 
     import GHC.Tc.TyCl.Build
    38 37
    39 38 
     import GHC.Core.Multiplicity
    40 
    -import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp )
    39 
    +import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp, definitelyLiftedType )
    41 40 
     import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
    42 
    -import GHC.Core.TyCo.Tidy( tidyForAllTyBinders, tidyTypes, tidyType )
    43 41 
     import GHC.Core.Predicate
    42 
    +import GHC.Core.TyCo.Tidy
    44 43
    45 44 
     import GHC.Types.Name
    46 45 
     import GHC.Types.Name.Reader
    ... ... @@ -51,7 +50,7 @@ import GHC.Utils.Panic
    51 50 
     import GHC.Utils.Outputable
    52 51 
     import GHC.Data.FastString
    53 52 
     import GHC.Types.Var
    54 
    -import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSetList )
    53 
    +import GHC.Types.Var.Env( mkInScopeSetList, emptyTidyEnv )
    55 54 
     import GHC.Types.Id
    56 55 
     import GHC.Types.Id.Info( RecSelParent(..) )
    57 56 
     import GHC.Tc.Gen.Bind
    ... ... @@ -672,27 +671,31 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn
    672 671 
                      (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
    673 672 
                      (args, arg_tys)
    674 673 
                      pat_ty field_labels
    675 
    -  = do { -- Zonk everything.  We are about to build a final PatSyn
    676 
    -         -- so there had better be no unification variables in there
    677 
    -
    678 
    -       (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <-
    679 
    -         initZonkEnv NoFlexi $
    680 
    -         runZonkBndrT (zonkTyVarBindersX   univ_tvs) $ \ univ_tvs' ->
    681 
    -         do { req_theta'  <- zonkTcTypesToTypesX req_theta
    682 
    -            ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' ->
    683 
    -         do { prov_theta' <- zonkTcTypesToTypesX prov_theta
    684 
    -            ; pat_ty'     <- zonkTcTypeToTypeX   pat_ty
    685 
    -            ; arg_tys'    <- zonkTcTypesToTypesX arg_tys
    674 
    +  = do { -- Don't do a final zonk-to-type yet, as the pattern synonym may still
    675 
    +         -- contain unfilled metavariables.
    676 
    +         -- See Note [Metavariables in pattern synonyms].
    677 
    +
    678 
    +         -- We still need to zonk, however, in order for instantiation to work
    679 
    +         -- correctly. If we don't zonk, we are at risk of quantifying
    680 
    +         -- 'alpha -> beta' to 'forall a. a -> beta' even though 'beta := alpha'.
    681 
    +       ; (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <-
    682 
    +         liftZonkM $
    683 
    +         do { univ_tvs'   <- traverse zonkInvisTVBinder univ_tvs
    684 
    +            ; req_theta'  <- zonkTcTypes req_theta
    685 
    +            ; ex_tvs'     <- traverse zonkInvisTVBinder ex_tvs
    686 
    +            ; prov_theta' <- zonkTcTypes prov_theta
    687 
    +            ; pat_ty'     <- zonkTcType   pat_ty
    688 
    +            ; arg_tys'    <- zonkTcTypes arg_tys
    686 689
    687 690 
                 ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs'
    691 
    +                  req_theta  = tidyTypes env1 req_theta'
    688 692 
                       (env2, ex_tvs)   = tidyForAllTyBinders env1 ex_tvs'
    689 
    -                  req_theta  = tidyTypes env2 req_theta'
    690 693 
                       prov_theta = tidyTypes env2 prov_theta'
    691 694 
                       arg_tys    = tidyTypes env2 arg_tys'
    692 695 
                       pat_ty     = tidyType  env2 pat_ty'
    693 696
    694 697 
                 ; return (univ_tvs, req_theta,
    695 
    -                       ex_tvs, prov_theta, arg_tys, pat_ty) } }
    698 
    +                       ex_tvs, prov_theta, arg_tys, pat_ty) }
    696 699
    697 700 
            ; traceTc "tc_patsyn_finish {" $
    698 701 
                ppr (unLoc lname) $$ ppr (unLoc lpat') $$
    ... ... @@ -734,6 +737,48 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn
    734 737 
            ; traceTc "tc_patsyn_finish }" empty
    735 738 
            ; return (matcher_bind, tcg_env) }
    736 739
    740 
    +{- Note [Metavariables in pattern synonyms]
    741 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    742 
    +Unlike data constructors, the types of pattern synonyms are allowed to contain
    743 
    +metavariables, because of view patterns. Example (from ticket #26465):
    744 
    +
    745 
    +  f :: Eq a => a -> Maybe a
    746 
    +  f = ...
    747 
    +
    748 
    +  g = f
    749 
    +    -- Due to the monomorphism restriction, we infer
    750 
    +    -- g :: alpha -> Maybe alpha, with [W] Eq alpha
    751 
    +
    752 
    +  pattern P x <- (g -> Just x)
    753 
    +    -- Infer: P :: alpha -> alpha
    754 
    +
    755 
    +Note that:
    756 
    +
    757 
    +  1. 'g' is a top-level function binding whose inferred type contains metavariables
    758 
    +     (due to type variable promotion, as described in Note [Deciding quantification] in GHC.Tc.Solver)
    759 
    +  2. 'P' is a pattern synonym without a type signature which uses 'g' in a view pattern.
    760 
    +
    761 
    +In this way, promoted metavariables of top-level functions can sneak their way
    762 
    +into pattern synonym definitions.
    763 
    +
    764 
    +To account for this fact, we do not attempt a final zonk-to-type in
    765 
    +'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'. Indeed, GHC may fill in the metavariables
    766 
    +when typechecking the rest of the module. Following on from the above example,
    767 
    +we might have a later binding:
    768 
    +
    769 
    +  y = g 'c'
    770 
    +    -- fixes alpha := Char
    771 
    +
    772 
    +or
    773 
    +
    774 
    +  h (P b) = not b
    775 
    +    -- fixes alpha := Bool
    776 
    +
    777 
    +We instead perform the final zonk-to-type at the very end, in the call
    778 
    +to 'GHC.Tc.Zonk.Type.zonkPatSyn' in 'GHC.Tc.Zonk.Type.zonkTopDecls'. In this way,
    779 
    +pattern synonyms are treated the same as top-level function bindings.
    780 
    +-}
    781 
    +
    737 782 
     {-
    738 783 
     ************************************************************************
    739 784 
     *                                                                      *
    ... ... @@ -870,9 +915,11 @@ mkPatSynBuilder dir (L _ name)
    870 915 
       | otherwise
    871 916 
       = do { builder_name <- newImplicitBinder name mkBuilderOcc
    872 917 
            ; let theta          = req_theta ++ prov_theta
    873 
    -             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
    874 
    -                              -- NB: pattern arguments cannot be representation-polymorphic,
    875 
    -                              -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here.
    918 
    +             need_dummy_arg = null arg_tys && null theta && not (definitelyLiftedType pat_ty)
    919 
    +               -- At this point, the representation of 'pat_ty' might still be unknown (see T26465c),
    920 
    +               -- so use a conservative test that handles an unknown representation.
    921 
    +               -- Ideally, we'd defer making the builder until the representation is settled,
    922 
    +               -- but that would be a lot more work.
    876 923 
                  builder_sigma  = add_void need_dummy_arg $
    877 924 
                                   mkInvisForAllTys univ_bndrs $
    878 925 
                                   mkInvisForAllTys ex_bndrs $

  • compiler/GHC/Tc/Zonk/Type.hs
    ... ... @@ -37,9 +37,6 @@ module GHC.Tc.Zonk.Type (
    37 37 
     import GHC.Prelude
    38 38
    39 39 
     import GHC.Builtin.Types
    40 
    -
    41 
    -import GHC.Core.TyCo.Ppr ( pprTyVar )
    42 
    -
    43 40 
     import GHC.Hs
    44 41
    45 42 
     import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)
    ... ... @@ -60,8 +57,11 @@ import GHC.Tc.Zonk.TcType
    60 57 
         , checkCoercionHole
    61 58 
         , zonkCoVar )
    62 59
    63 
    -import GHC.Core.Type
    64 60 
     import GHC.Core.Coercion
    61 
    +import GHC.Core.ConLike
    62 
    +import GHC.Core.PatSyn (PatSyn(..))
    63 
    +import GHC.Core.TyCo.Ppr ( pprTyVar )
    64 
    +import GHC.Core.Type
    65 65 
     import GHC.Core.TyCon
    66 66
    67 67 
     import GHC.Utils.Outputable
    ... ... @@ -93,6 +93,7 @@ import Control.Monad
    93 93 
     import Control.Monad.Trans.Class ( lift )
    94 94 
     import Data.List.NonEmpty ( NonEmpty )
    95 95 
     import Data.Foldable ( toList )
    96 
    +import Data.Traversable ( for )
    96 97
    97 98 
     {- Note [What is zonking?]
    98 99 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -470,7 +471,7 @@ commitFlexi DefaultFlexi tv zonked_kind
    470 471 
            ; return manyDataConTy }
    471 472 
       | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv
    472 473 
       = do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin)
    473 
    -       ; return (anyTypeOfKind zonked_kind) }
    474 
    +       ; newZonkAnyType zonked_kind }
    474 475 
       | otherwise
    475 476 
       = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)
    476 477 
               -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)
    ... ... @@ -647,23 +648,25 @@ zonkTopDecls :: Bag EvBind
    647 648 
                  -> LHsBinds GhcTc
    648 649 
                  -> [LRuleDecl GhcTc] -> [LTcSpecPrag]
    649 650 
                  -> [LForeignDecl GhcTc]
    651 
    +             -> [PatSyn]
    650 652 
                  -> TcM (TypeEnv,
    651 653 
                          Bag EvBind,
    652 654 
                          LHsBinds GhcTc,
    653 655 
                          [LForeignDecl GhcTc],
    654 656 
                          [LTcSpecPrag],
    655 
    -                     [LRuleDecl    GhcTc])
    656 
    -zonkTopDecls ev_binds binds rules imp_specs fords
    657 
    +                     [LRuleDecl    GhcTc],
    658 
    +                     [PatSyn])
    659 
    +zonkTopDecls ev_binds binds rules imp_specs fords pat_syns
    657 660 
       = initZonkEnv DefaultFlexi $
    658 661 
         runZonkBndrT (zonkEvBinds ev_binds)   $ \ ev_binds' ->
    659 662 
         runZonkBndrT (zonkRecMonoBinds binds) $ \ binds'    ->
    660 663 
          -- Top level is implicitly recursive
    661 
    -  do  { rules' <- zonkRules rules
    662 
    -      ; specs' <- zonkLTcSpecPrags imp_specs
    663 
    -      ; fords' <- zonkForeignExports fords
    664 
    -      ; ty_env <- zonkEnvIds <$> getZonkEnv
    665 
    -      ; return (ty_env, ev_binds', binds', fords', specs', rules') }
    666 
    -
    664 
    +  do  { rules'    <- zonkRules rules
    665 
    +      ; specs'    <- zonkLTcSpecPrags imp_specs
    666 
    +      ; fords'    <- zonkForeignExports fords
    667 
    +      ; pat_syns' <- traverse zonkPatSyn pat_syns
    668 
    +      ; ty_env    <- zonkEnvIds <$> getZonkEnv
    669 
    +      ; return (ty_env, ev_binds', binds', fords', specs', rules', pat_syns') }
    667 670
    668 671 
     ---------------------------------------------
    669 672 
     zonkLocalBinds :: HsLocalBinds GhcTc
    ... ... @@ -1549,7 +1552,8 @@ zonk_pat (SumPat tys pat alt arity )
    1549 1552 
             ; pat' <- zonkPat pat
    1550 1553 
             ; return (SumPat tys' pat' alt arity) }
    1551 1554
    1552 
    -zonk_pat p@(ConPat { pat_args = args
    1555 
    +zonk_pat p@(ConPat { pat_con = L con_loc con
    1556 
    +                   , pat_args = args
    1553 1557 
                        , pat_con_ext = p'@(ConPatTc
    1554 1558 
                          { cpt_tvs = tyvars
    1555 1559 
                          , cpt_dicts = evs
    ... ... @@ -1568,8 +1572,15 @@ zonk_pat p@(ConPat { pat_args = args
    1568 1572 
             ; new_binds   <- zonkTcEvBinds binds
    1569 1573 
             ; new_wrapper <- zonkCoFn wrapper
    1570 1574 
             ; new_args    <- zonkConStuff args
    1575 
    +        ; new_con     <- case con of
    1576 
    +            RealDataCon {} -> return con
    1577 
    +              -- Data constructors never contain metavariables: they are
    1578 
    +              -- fully zonked before we look at any value bindings.
    1579 
    +            PatSynCon ps   -> PatSynCon <$> noBinders (zonkPatSyn ps)
    1580 
    +              -- Pattern synonyms can contain metavariables, see e.g. T26465c.
    1571 1581 
             ; pure $ p
    1572 
    -                 { pat_args = new_args
    1582 
    +                 { pat_con = L con_loc new_con
    1583 
    +                 , pat_args = new_args
    1573 1584 
                      , pat_con_ext = p'
    1574 1585 
                        { cpt_arg_tys = new_tys
    1575 1586 
                        , cpt_tvs = new_tyvars
    ... ... @@ -1615,14 +1626,14 @@ zonk_pat (InvisPat ty tp)
    1615 1626 
            ; return (InvisPat ty' tp) }
    1616 1627
    1617 1628 
     zonk_pat (XPat ext) = case ext of
    1618 
    -  { ExpansionPat orig pat->
    1629 
    +  { ExpansionPat orig pat ->
    1619 1630 
         do { pat' <- zonk_pat pat
    1620 1631 
            ; return $ XPat $ ExpansionPat orig pat' }
    1621 1632 
       ; CoPat co_fn pat ty ->
    1622 
    -    do { co_fn' <- zonkCoFn co_fn
    1623 
    -       ; pat'   <- zonkPat (noLocA pat)
    1624 
    -       ; ty'    <- noBinders $ zonkTcTypeToTypeX ty
    1625 
    -       ; return (XPat $ CoPat co_fn' (unLoc pat') ty')
    1633 
    +    do { co_fn'   <- zonkCoFn co_fn
    1634 
    +       ; pat'     <- zonk_pat pat
    1635 
    +       ; ty'      <- noBinders $ zonkTcTypeToTypeX ty
    1636 
    +       ; return (XPat $ CoPat co_fn' pat' ty')
    1626 1637 
            } }
    1627 1638
    1628 1639 
     zonk_pat pat = pprPanic "zonk_pat" (ppr pat)
    ... ... @@ -1653,6 +1664,45 @@ zonkPats = traverse zonkPat
    1653 1664 
     {-# SPECIALISE zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc] #-}
    1654 1665 
     {-# SPECIALISE zonkPats :: NonEmpty (LPat GhcTc) -> ZonkBndrTcM (NonEmpty (LPat GhcTc)) #-}
    1655 1666
    1667 
    +---------------------------
    1668 
    +
    1669 
    +-- | Perform a final zonk-to-type for a pattern synonym.
    1670 
    +--
    1671 
    +-- See Note [Metavariables in pattern synonyms] in GHC.Tc.TyCl.PatSyn.
    1672 
    +zonkPatSyn :: PatSyn -> ZonkTcM PatSyn
    1673 
    +zonkPatSyn
    1674 
    +  ps@( MkPatSyn
    1675 
    +     { psArgs       = arg_tys
    1676 
    +     , psUnivTyVars = univ_tvs
    1677 
    +     , psReqTheta   = req_theta
    1678 
    +     , psExTyVars   = ex_tvs
    1679 
    +     , psProvTheta  = prov_theta
    1680 
    +     , psResultTy   = res_ty
    1681 
    +     , psMatcher    = (matcherNm, matcherTy, matcherDummyArg)
    1682 
    +     , psBuilder    = mbBuilder
    1683 
    +     }) =
    1684 
    +  runZonkBndrT (zonkTyVarBindersX univ_tvs) $ \ univ_tvs' ->
    1685 
    +  do { req_theta'  <- zonkTcTypesToTypesX req_theta
    1686 
    +     ; res_ty'     <- zonkTcTypeToTypeX   res_ty
    1687 
    +     ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' ->
    1688 
    +  do { prov_theta' <- zonkTcTypesToTypesX prov_theta
    1689 
    +     ; arg_tys'    <- zonkTcTypesToTypesX arg_tys
    1690 
    +     ; matcherTy'  <- zonkTcTypeToTypeX   matcherTy
    1691 
    +     ; mbBuilder'  <- for mbBuilder $ \ (builderNm, builderTy, builderDummyArg) ->
    1692 
    +                        do { builderTy' <- zonkTcTypeToTypeX builderTy
    1693 
    +                           ; return (builderNm, builderTy', builderDummyArg) }
    1694 
    +     ; return $
    1695 
    +        ps
    1696 
    +          { psArgs       = arg_tys'
    1697 
    +          , psUnivTyVars = univ_tvs'
    1698 
    +          , psReqTheta   = req_theta'
    1699 
    +          , psExTyVars   = ex_tvs'
    1700 
    +          , psProvTheta  = prov_theta'
    1701 
    +          , psResultTy   = res_ty'
    1702 
    +          , psMatcher    = (matcherNm, matcherTy', matcherDummyArg)
    1703 
    +          , psBuilder    = mbBuilder'
    1704 
    +          } } }
    1705 
    +
    1656 1706 
     {-
    1657 1707 
     ************************************************************************
    1658 1708 
     *                                                                      *

  • compiler/Language/Haskell/Syntax/Binds.hs
    ... ... @@ -233,7 +233,7 @@ data HsBindLR idL idR
    233 233 
             var_rhs    :: LHsExpr idR    -- ^ Located only for consistency
    234 234 
         }
    235 235
    236 
    -  -- | Patterns Synonym Binding
    236 
    +  -- | Pattern Synonym Binding
    237 237 
       | PatSynBind
    238 238 
             (XPatSynBind idL idR)
    239 239 
             (PatSynBind idL idR)

  • testsuite/tests/patsyn/should_compile/T26465b.hs
    1 
    +{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
    2 
    +
    3 
    +module T26465b where
    4 
    +
    5 
    +-- Variant of T26465 which should be accepted
    6 
    +
    7 
    +f :: Eq a => a -> Maybe a
    8 
    +f _ = Nothing
    9 
    +
    10 
    +-- Monomorphism restriction bites
    11 
    +-- Eq a[tau:0] => a[tau:0] -> Maybe a[tau:0]
    12 
    +g = f
    13 
    +
    14 
    +pattern P x <- ( g -> Just x )
    15 
    +
    16 
    +x = g (1 :: Int)

  • testsuite/tests/patsyn/should_compile/T26465c.hs
    1 
    +
    2 
    +{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
    3 
    +
    4 
    +{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
    5 
    +
    6 
    +module T26465c where
    7 
    +
    8 
    +-- Rep-poly variant of T26465b
    9 
    +
    10 
    +import Data.Kind
    11 
    +  ( Constraint )
    12 
    +import GHC.Exts
    13 
    +  ( TYPE, Int#, isTrue#, (>=#) )
    14 
    +
    15 
    +
    16 
    +type HasP :: forall r. TYPE r -> Constraint
    17 
    +class HasP a where
    18 
    +  getP :: a -> (# (# #) | (# #) #)
    19 
    +  mk :: (# #) -> a
    20 
    +
    21 
    +instance HasP Int where
    22 
    +  getP i = if i >= 0 then (# | (# #) #) else (# (# #) | #)
    23 
    +  mk _ = 1
    24 
    +instance HasP Int# where
    25 
    +  getP i# = if isTrue# ( i# >=# 0# ) then (# | (# #) #) else (# (# #) | #)
    26 
    +  mk _ = 1#
    27 
    +
    28 
    +g1 = getP
    29 
    +g2 = getP
    30 
    +
    31 
    +m1 = mk
    32 
    +m2 = mk
    33 
    +
    34 
    +-- NB: deliberately use no arguments to make this test harder (so that we run
    35 
    +-- into the 'need_dummy_arg' logic of 'GHC.Tc.TyCl.PatSyn.mkPatSynBuilder').
    36 
    +pattern P1 <- ( g1 -> (# | (# #) #) )
    37 
    +  where P1 = m1 (# #)
    38 
    +pattern P2 <- ( g2 -> (# | (# #) #) )
    39 
    +  where P2 = m2 (# #)
    40 
    +
    41 
    +y1 :: Int -> Int
    42 
    +y1 P1 = P1
    43 
    +
    44 
    +y2 :: Int# -> Int#
    45 
    +y2 P2 = P2

  • testsuite/tests/patsyn/should_compile/T26465d.hs
    1 
    +
    2 
    +{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
    3 
    +
    4 
    +{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
    5 
    +
    6 
    +module T26465d where
    7 
    +
    8 
    +-- Should-fail variant of T26465c (but with -fdefer-type-errors)
    9 
    +
    10 
    +import Data.Kind
    11 
    +  ( Constraint )
    12 
    +import GHC.Exts
    13 
    +  ( TYPE )
    14 
    +
    15 
    +type HasP :: forall r. TYPE r -> Constraint
    16 
    +class HasP a where
    17 
    +  getP :: a -> (# (# #) | (# #) #)
    18 
    +  mk :: (# #) -> a
    19 
    +
    20 
    +g = getP
    21 
    +m = mk
    22 
    +
    23 
    +-- NB: deliberately use no arguments to make this test harder (so that we run
    24 
    +-- into the 'need_dummy_arg' logic of 'GHC.Tc.TyCl.PatSyn.mkPatSynBuilder').
    25 
    +pattern P1 <- ( g -> (# | (# #) #) )
    26 
    +  where P1 = m (# #)
    27 
    +
    28 
    +test P1 = P1

  • testsuite/tests/patsyn/should_compile/T26465d.stderr
    1 
    +T26465d.hs:20:5: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
    2 
    +    • No instance for ‘HasP a0’ arising from a use of ‘getP’
    3 
    +    • In the expression: getP
    4 
    +      In an equation for ‘g’: g = getP
    5 
    +
    6 
    +T26465d.hs:21:5: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
    7 
    +    • No instance for ‘HasP a0’ arising from a use of ‘mk’
    8 
    +    • In the expression: mk
    9 
    +      In an equation for ‘m’: m = mk
    10 
    +

  • testsuite/tests/patsyn/should_compile/all.T
    ... ... @@ -73,6 +73,9 @@ test('T13752a', normal, compile, [''])
    73 73 
     test('T13768', normal, compile, [''])
    74 74 
     test('T14058', [extra_files(['T14058.hs', 'T14058a.hs'])],
    75 75 
                    multimod_compile, ['T14058', '-v0'])
    76 
    +test('T26465b', normal, compile, [''])
    77 
    +test('T26465c', normal, compile, [''])
    78 
    +test('T26465d', normal, compile, ['-fdefer-type-errors'])
    76 79 
     test('T14326', normal, compile, [''])
    77 80 
     test('T14380', normal, compile, [''])
    78 81 
     test('T14394', normal, ghci_script, ['T14394.script'])

  • testsuite/tests/patsyn/should_fail/T26465.hs
    1 
    +{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
    2 
    +
    3 
    +module T26465 where
    4 
    +
    5 
    +f :: Eq a => a -> Maybe a
    6 
    +f _ = Nothing
    7 
    +
    8 
    +-- Monomorphism restriction bites
    9 
    +-- Eq a[tau:0] => a[tau:0] -> Maybe a[tau:0]
    10 
    +g = f
    11 
    +
    12 
    +pattern P x <- ( g -> Just x )

  • testsuite/tests/patsyn/should_fail/T26465.stderr
    1 
    +T26465.hs:10:5: error: [GHC-39999]
    2 
    +    • Ambiguous type variable ‘a0’ arising from a use of ‘f’
    3 
    +      prevents the constraint ‘(Eq a0)’ from being solved.
    4 
    +      Relevant bindings include
    5 
    +        g :: a0 -> Maybe a0 (bound at T26465.hs:10:1)
    6 
    +      Probable fix: use a type annotation to specify what ‘a0’ should be.
    7 
    +      Potentially matching instances:
    8 
    +        instance Eq Ordering -- Defined in ‘GHC.Internal.Classes’
    9 
    +        instance Eq Integer -- Defined in ‘GHC.Internal.Bignum.Integer’
    10 
    +        ...plus 24 others
    11 
    +        ...plus five instances involving out-of-scope types
    12 
    +        (use -fprint-potential-instances to see them all)
    13 
    +    • In the expression: f
    14 
    +      In an equation for ‘g’: g = f
    15 
    +

  • testsuite/tests/patsyn/should_fail/all.T
    ... ... @@ -35,6 +35,7 @@ test('T12165', normal, compile_fail, [''])
    35 35 
     test('T12819', normal, compile_fail, [''])
    36 36 
     test('UnliftedPSBind', normal, compile_fail, [''])
    37 37 
     test('T15695', normal, compile, [''])   # It has -fdefer-type-errors inside
    38 
    +test('T26465', normal, compile_fail, [''])
    38 39 
     test('T13349', normal, compile_fail, [''])
    39 40 
     test('T13470', normal, compile_fail, [''])
    40 41 
     test('T14112', normal, compile_fail, [''])

  • testsuite/tests/th/T8761.stderr
    ... ... @@ -123,29 +123,29 @@ T8761.hs:(71,1)-(105,39): Splicing declarations
    123 123 
         pattern Puep x y <- (MkExProv y, x)
    124 124 
     pattern T8761.P :: GHC.Internal.Types.Bool
    125 125 
     pattern T8761.Pe :: () => forall (a_0 :: *) . a_0 -> T8761.Ex
    126 
    -pattern T8761.Pu :: forall (a_0 :: *) . a_0 -> a_0
    127 
    -pattern T8761.Pue :: forall (a_0 :: *) . () => forall (b_1 :: *) .
    128 
    -                                               a_0 -> b_1 -> (a_0, T8761.Ex)
    129 
    -pattern T8761.Pur :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0,
    130 
    -                                          GHC.Internal.Classes.Eq a_0) =>
    131 
    -                     a_0 -> [a_0]
    132 
    -pattern T8761.Purp :: forall (a_0 :: *) (b_1 :: *) . (GHC.Internal.Num.Num a_0,
    133 
    -                                                      GHC.Internal.Classes.Eq a_0) =>
    134 
    -                      GHC.Internal.Show.Show b_1 =>
    135 
    -                      a_0 -> b_1 -> ([a_0], T8761.UnivProv b_1)
    136 
    -pattern T8761.Pure :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0,
    137 
    -                                           GHC.Internal.Classes.Eq a_0) =>
    138 
    -                      forall (b_1 :: *) . a_0 -> b_1 -> ([a_0], T8761.Ex)
    139 
    -pattern T8761.Purep :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0,
    140 
    -                                            GHC.Internal.Classes.Eq a_0) =>
    126 
    +pattern T8761.Pu :: forall (a0_0 :: *) . a0_0 -> a0_0
    127 
    +pattern T8761.Pue :: forall (a0_0 :: *) . () => forall (b_1 :: *) .
    128 
    +                                                a0_0 -> b_1 -> (a0_0, T8761.Ex)
    129 
    +pattern T8761.Pur :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0,
    130 
    +                                           GHC.Internal.Classes.Eq a0_0) =>
    131 
    +                     a0_0 -> [a0_0]
    132 
    +pattern T8761.Purp :: forall (a0_0 :: *) (b0_1 :: *) . (GHC.Internal.Num.Num a0_0,
    133 
    +                                                        GHC.Internal.Classes.Eq a0_0) =>
    134 
    +                      GHC.Internal.Show.Show b0_1 =>
    135 
    +                      a0_0 -> b0_1 -> ([a0_0], T8761.UnivProv b0_1)
    136 
    +pattern T8761.Pure :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0,
    137 
    +                                            GHC.Internal.Classes.Eq a0_0) =>
    138 
    +                      forall (b_1 :: *) . a0_0 -> b_1 -> ([a0_0], T8761.Ex)
    139 
    +pattern T8761.Purep :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0,
    140 
    +                                             GHC.Internal.Classes.Eq a0_0) =>
    141 141 
                            forall (b_1 :: *) . GHC.Internal.Show.Show b_1 =>
    142 
    -                       a_0 -> b_1 -> ([a_0], T8761.ExProv)
    142 
    +                       a0_0 -> b_1 -> ([a0_0], T8761.ExProv)
    143 143 
     pattern T8761.Pep :: () => forall (a_0 :: *) . GHC.Internal.Show.Show a_0 =>
    144 144 
                                a_0 -> T8761.ExProv
    145 
    -pattern T8761.Pup :: forall (a_0 :: *) . () => GHC.Internal.Show.Show a_0 =>
    146 
    -                                               a_0 -> T8761.UnivProv a_0
    147 
    -pattern T8761.Puep :: forall (a_0 :: *) . () => forall (b_1 :: *) . GHC.Internal.Show.Show b_1 =>
    148 
    -                                                a_0 -> b_1 -> (T8761.ExProv, a_0)
    145 
    +pattern T8761.Pup :: forall (a0_0 :: *) . () => GHC.Internal.Show.Show a0_0 =>
    146 
    +                                                a0_0 -> T8761.UnivProv a0_0
    147 
    +pattern T8761.Puep :: forall (a0_0 :: *) . () => forall (b_1 :: *) . GHC.Internal.Show.Show b_1 =>
    148 
    +                                                 a0_0 -> b_1 -> (T8761.ExProv, a0_0)
    149 149 
     T8761.hs:(108,1)-(117,25): Splicing declarations
    150 150 
         do infos <- mapM
    151 151 
                       reify

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