diff options
Diffstat (limited to 'compiler/GHC/HsToCore/Match/Constructor.hs')
| -rw-r--r-- | compiler/GHC/HsToCore/Match/Constructor.hs | 41 |
1 files changed, 30 insertions, 11 deletions
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index 9c7ad46c22..96ab10fa4c 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -25,6 +25,7 @@ import GHC.HsToCore.Binds import GHC.Core.ConLike import GHC.Types.Basic ( Origin(..) ) import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.Core ( CoreExpr ) @@ -98,7 +99,13 @@ matchConFamily :: NonEmpty Id -> DsM (MatchResult CoreExpr) -- Each group of eqns is for a single constructor matchConFamily (var :| vars) ty groups - = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups + = do let mult = idMult var + -- Each variable in the argument list correspond to one column in the + -- pattern matching equations. Its multiplicity is the context + -- multiplicity of the pattern. We extract that multiplicity, so that + -- 'matchOneconLike' knows the context multiplicity, in case it needs + -- to come up with new variables. + alts <- mapM (fmap toRealAlt . matchOneConLike vars ty mult) groups return (mkCoAlgCaseMatchResult var ty alts) where toRealAlt alt = case alt_pat alt of @@ -110,7 +117,8 @@ matchPatSyn :: NonEmpty Id -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchPatSyn (var :| vars) ty eqns - = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns + = do let mult = idMult var + alt <- fmap toSynAlt $ matchOneConLike vars ty mult eqns return (mkCoSynCaseMatchResult var ty alt) where toSynAlt alt = case alt_pat alt of @@ -121,9 +129,10 @@ type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc)) matchOneConLike :: [Id] -> Type + -> Mult -> NonEmpty EquationInfo -> DsM (CaseAlt ConLike) -matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor +matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) -- ex_tvs can only be tyvars as data types in source -- Haskell cannot mention covar yet (Aug 2018). @@ -163,8 +172,15 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor , eqn_pats = conArgPats val_arg_tys args ++ pats } ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) - - ; arg_vars <- selectConMatchVars val_arg_tys args1 + ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys + -- The 'val_arg_tys' are taken from the data type definition, they + -- do not take into account the context multiplicity, therefore we + -- need to scale them back to get the correct context multiplicity + -- to desugar the sub-pattern in each field. We need to know these + -- multiplicity because of the invariant that, in Core, binders in a + -- constructor pattern must be scaled by the multiplicity of the + -- case. See Note [Case expression invariants]. + ; arg_vars <- selectConMatchVars scaled_arg_tys args1 -- Use the first equation as a source of -- suggestions for the new variables @@ -229,12 +245,15 @@ same_fields flds1 flds2 ----------------- -selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] -selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys -selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) -selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] +selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] +selectConMatchVars arg_tys con = case con of + (RecCon {}) -> newSysLocalsDsNoLP arg_tys + (PrefixCon ps) -> selectMatchVars (zipMults arg_tys ps) + (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2]) + where + zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b)) -conArgPats :: [Type] -- Instantiated argument types +conArgPats :: [Scaled Type]-- Instantiated argument types -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway -> ConArgPats @@ -242,7 +261,7 @@ conArgPats :: [Type] -- Instantiated argument types conArgPats _arg_tys (PrefixCon ps) = map unLoc ps conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) - | null rpats = map WildPat arg_tys + | null rpats = map WildPat (map scaledThing arg_tys) -- Important special case for C {}, which can be used for a -- datacon that isn't declared to have fields at all | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats |