diff options
Diffstat (limited to 'compiler/deSugar/Match.hs')
| -rw-r--r-- | compiler/deSugar/Match.hs | 107 |
1 files changed, 55 insertions, 52 deletions
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 5f9f8dca8b..c4fb7e7f30 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -251,7 +251,7 @@ matchBangs [] _ _ = panic "matchBangs" matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) - = do { let CoPat co pat _ = firstPat eqn1 + = do { let CoPat _ co pat _ = firstPat eqn1 ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' ; match_result <- match (var':vars) ty $ @@ -267,7 +267,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable - let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 + let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' @@ -284,7 +284,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView - = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 + = do { let ListPat _ _ elt_ty (Just (_,e)) = firstPat eqn1 ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern @@ -299,13 +299,13 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) decomposeFirstPat _ _ = panic "decomposeFirstPat" getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc -getCoPat (CoPat _ pat _) = pat +getCoPat (CoPat _ _ pat _) = pat getCoPat _ = panic "getCoPat" -getBangPat (BangPat pat ) = unLoc pat +getBangPat (BangPat _ pat ) = unLoc pat getBangPat _ = panic "getBangPat" -getViewPat (ViewPat _ pat _) = unLoc pat +getViewPat (ViewPat _ _ pat) = unLoc pat getViewPat _ = panic "getViewPat" -getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing +getOLPat (ListPat x pats ty (Just _)) = ListPat x pats ty Nothing getOLPat _ = panic "getOLPat" {- @@ -398,19 +398,19 @@ tidy1 :: Id -- The Id being scrutinised -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v (ParPat pat) = tidy1 v (unLoc pat) -tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) -tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p +tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat) +tidy1 v (SigPat _ pat) = tidy1 v (unLoc pat) +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v (VarPat (L _ var)) +tidy1 v (VarPat _ (L _ var)) = return (wrapBind var v, WildPat (idType var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v (AsPat (L _ var) pat) +tidy1 v (AsPat _ (L _ var) pat) = do { (wrap, pat') <- tidy1 v (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -425,7 +425,7 @@ tidy1 v (AsPat (L _ var) pat) The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v (LazyPat pat) +tidy1 v (LazyPat _ pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. @@ -441,7 +441,7 @@ tidy1 v (LazyPat pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ (ListPat pats ty Nothing) +tidy1 _ (ListPat _ pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) @@ -450,29 +450,29 @@ tidy1 _ (ListPat pats ty Nothing) -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -tidy1 _ (PArrPat pats ty) +tidy1 _ (PArrPat ty pats) = return (idDsWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] -tidy1 _ (TuplePat pats boxity tys) +tidy1 _ (TuplePat tys pats boxity) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys -tidy1 _ (SumPat pat alt arity tys) +tidy1 _ (SumPat tys pat alt arity) = return (idDsWrapper, unLoc sum_ConPat) where sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (LitPat lit) +tidy1 _ (LitPat _ lit) = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (NPat (L _ lit) mb_neg eq ty) +tidy1 _ (NPat ty (L _ lit) mb_neg eq) = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty) -- Everything else goes through unchanged... @@ -484,13 +484,14 @@ tidy1 _ non_interesting_pat tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang -tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p -tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p +tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p +tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time -tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) -tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) +tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p))) +tidy_bang_pat v l (CoPat x w p t) + = tidy1 v (CoPat x w (BangPat noExt (L l p)) t) -- Discard bang around strict pattern tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p @@ -526,7 +527,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc) -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) +tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan @@ -537,15 +538,16 @@ push_bang_into_newtype_arg :: SrcSpan -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = ASSERT( null args) - PrefixCon [L l (BangPat arg)] + PrefixCon [L l (BangPat noExt arg)] push_bang_into_newtype_arg l _ty (RecCon rf) | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds) - RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] }) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg + = L l (BangPat noExt arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [L l (BangPat (noLoc (WildPat ty)))] + = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -975,18 +977,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens - exp (HsPar (L _ e)) e' = exp e e' - exp e (HsPar (L _ e')) = exp e e' + exp (HsPar _ (L _ e)) e' = exp e e' + exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers - exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' - exp (HsVar i) (HsVar i') = i == i' - exp (HsConLikeOut c) (HsConLikeOut c') = c == c' + exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' + exp (HsVar _ i) (HsVar _ i') = i == i' + exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' -- the instance for IPName derives using the id, so this works if the -- above does - exp (HsIPVar i) (HsIPVar i') = i == i' - exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x' - exp (HsOverLit l) (HsOverLit l') = + exp (HsIPVar _ i) (HsIPVar _ i') = i == i' + exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' + exp (HsOverLit _ l) (HsOverLit _ l') = -- Overloaded lits are equal if they have the same type -- and the data is the same. -- this is coarser than comparing the SyntaxExpr's in l and l', @@ -994,20 +996,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- because these expressions get written as a bunch of different variables -- (presumably to improve sharing) eqType (overLitType l) (overLitType l') && l == l' - exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' + exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? - exp (OpApp l o _ ri) (OpApp l' o' _ ri') = + exp (OpApp _ l o ri) (OpApp _ l' o' ri') = lexp l l' && lexp o o' && lexp ri ri' - exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n' - exp (SectionL e1 e2) (SectionL e1' e2') = + exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' + exp (SectionL _ e1 e2) (SectionL _ e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (SectionR e1 e2) (SectionR e1' e2') = + exp (SectionR _ e1 e2) (SectionR _ e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = + exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = eq_list tup_arg es1 es2 - exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e' - exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = + exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' + exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' -- Enhancement: could implement equality for more expressions @@ -1029,8 +1031,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 wrap res_wrap1 res_wrap2 --------- - tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2 - tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 + tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False --------- @@ -1071,7 +1073,7 @@ patGroup _ (ConPatOut { pat_con = L _ con | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) = +patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) = case (oval, isJust mb_neg) of (HsIntegral i, False) -> PgN (fromInteger (il_value i)) (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) @@ -1079,14 +1081,15 @@ patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) = (HsFractional r, True ) -> PgN (-fl_value r) (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) PgOverS s -patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) = +patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern -patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList -patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) +patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) + -- Type of innelexp pattern +patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat _ _ _ (Just _)) = PgOverloadedList +patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) patGroup _ pat = pprPanic "patGroup" (ppr pat) {- |