diff options
author | Ben Gamari <ben@smart-cactus.org> | 2017-11-21 14:28:58 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-11-21 16:36:43 -0500 |
commit | 314bc31489f1f4cd69e913c3b1e33236b2bdf553 (patch) | |
tree | b960f9b02ec06f9d61df019f53655b4e53847bd7 /compiler/deSugar/Match.hs | |
parent | 0b20d9c51d627febab34b826fccf522ca8bac323 (diff) | |
download | haskell-314bc31489f1f4cd69e913c3b1e33236b2bdf553.tar.gz |
Revert "trees that grow" work
As documented in #14490, the Data instances currently blow up
compilation time by too much to stomach. Alan will continue working on
this in a branch and we will perhaps merge to 8.2 before 8.2.1 to avoid
having to perform painful cherry-picks in 8.2 minor releases.
Reverts haddock submodule.
This reverts commit 47ad6578ea460999b53eb4293c3a3b3017a56d65.
This reverts commit e3ec2e7ae94524ebd111963faf34b84d942265b4.
This reverts commit 438dd1cbba13d35f3452b4dcef3f94ce9a216905.
This reverts commit 0ff152c9e633accca48815e26e59d1af1fe44ceb.
Diffstat (limited to 'compiler/deSugar/Match.hs')
-rw-r--r-- | compiler/deSugar/Match.hs | 107 |
1 files changed, 52 insertions, 55 deletions
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 4cb8bf35ba..7a3ee6853c 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 x pats ty (Just _)) = ListPat x pats ty Nothing +getOLPat (ListPat pats ty (Just _)) = ListPat 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 (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 +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 -- 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 ty pats) +tidy1 _ (PArrPat pats ty) = return (idDsWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] -tidy1 _ (TuplePat tys pats boxity) +tidy1 _ (TuplePat pats boxity tys) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys -tidy1 _ (SumPat tys pat alt arity) +tidy1 _ (SumPat pat alt arity tys) = 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 ty (L _ lit) mb_neg eq) +tidy1 _ (NPat (L _ lit) mb_neg eq ty) = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty) -- Everything else goes through unchanged... @@ -484,14 +484,13 @@ 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 _ (SigPat _ (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 _ (SigPatOut (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 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) +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) -- Discard bang around strict pattern tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p @@ -527,7 +526,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 noExt (L l p)) +tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan @@ -538,16 +537,15 @@ 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 noExt arg)] + PrefixCon [L l (BangPat 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 noExt arg) })] }) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))] + = PrefixCon [L l (BangPat (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -977,18 +975,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', @@ -996,20 +994,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 @@ -1031,8 +1029,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 --------- @@ -1073,7 +1071,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)) @@ -1081,15 +1079,14 @@ 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) {- |