From 04feba252e40d16101b92948cd1e13c7bc1f3062 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 2 Feb 2006 12:44:05 +0000 Subject: [PATCH] Record the type in TuplePat (necessary for GADTs) We must record the type of a TuplePat after typechecking, just like a ConPatOut, so that desugaring works correctly for GADTs. See comments with the declaration of HsPat.TuplePat, and test gadt15 --- ghc/compiler/deSugar/Check.lhs | 20 ++++++------- ghc/compiler/deSugar/DsExpr.lhs | 4 +-- ghc/compiler/deSugar/DsListComp.lhs | 11 ++++--- ghc/compiler/deSugar/DsMeta.hs | 16 +++++------ ghc/compiler/deSugar/DsUtils.lhs | 2 +- ghc/compiler/deSugar/Match.lhs | 13 ++++----- ghc/compiler/deSugar/MatchCon.lhs | 2 ++ ghc/compiler/hsSyn/Convert.lhs | 2 +- ghc/compiler/hsSyn/HsPat.lhs | 54 +++++++++++++++++++++-------------- ghc/compiler/hsSyn/HsUtils.lhs | 26 ++++++++--------- ghc/compiler/parser/RdrHsSyn.lhs | 2 +- ghc/compiler/rename/RnTypes.lhs | 5 ++-- ghc/compiler/typecheck/TcExpr.lhs | 6 ++-- ghc/compiler/typecheck/TcHsSyn.lhs | 16 +++++++---- ghc/compiler/typecheck/TcPat.lhs | 4 +-- ghc/compiler/types/Generics.lhs | 2 +- 16 files changed, 101 insertions(+), 84 deletions(-) diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 97b4257..693368b 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -11,7 +11,7 @@ module Check ( check , ExhaustivePat ) where import HsSyn -import TcHsSyn ( hsPatType ) +import TcHsSyn ( hsPatType, mkVanillaTuplePat ) import TcType ( tcTyConAppTyCon ) import DsUtils ( EquationInfo(..), MatchResult(..), CanItFail(..), firstPat ) @@ -145,7 +145,7 @@ untidy b (L loc p) = L loc (untidy' b p) untidy' _ p@(ConPatIn name (PrefixCon [])) = p untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty - untidy' _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed + untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" @@ -557,9 +557,9 @@ make_con (ConPatOut (L _ id) _ _ _ _ _) (lp:lq:ps, constraints) | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) where q = unLoc lq -make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) _) (ps, constraints) - | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints) - | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) +make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) ty) (ps, constraints) + | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints) + | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) | otherwise = (nlConPat name pats_con : rest_pats, constraints) where name = getName id @@ -609,7 +609,7 @@ has_nplusk_pat (AsPat _ p) = has_nplusk_lpat p has_nplusk_pat (SigPatOut p _ ) = has_nplusk_lpat p has_nplusk_pat (ConPatOut _ _ _ _ ps ty) = any has_nplusk_lpat (hsConArgs ps) has_nplusk_pat (ListPat ps _) = any has_nplusk_lpat ps -has_nplusk_pat (TuplePat ps _) = any has_nplusk_lpat ps +has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps has_nplusk_pat (PArrPat ps _) = any has_nplusk_lpat ps has_nplusk_pat (LazyPat p) = False has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat @@ -643,10 +643,10 @@ simplify_pat (PArrPat ps ty) (PrefixCon (map simplify_lpat ps)) (mkPArrTy ty) -simplify_pat (TuplePat ps boxity) +simplify_pat (TuplePat ps boxity ty) = mk_simple_con_pat (tupleCon boxity arity) (PrefixCon (map simplify_lpat ps)) - (mkTupleTy boxity arity (map hsPatType ps)) + ty where arity = length ps @@ -667,9 +667,9 @@ simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2) simplify_pat (DictPat dicts methods) = case num_of_d_and_ms of - 0 -> simplify_pat (TuplePat [] Boxed) + 0 -> simplify_pat (TuplePat [] Boxed unitTy) 1 -> simplify_pat (head dict_and_method_pats) - _ -> simplify_pat (TuplePat (map noLoc dict_and_method_pats) Boxed) + _ -> simplify_pat (mkVanillaTuplePat (map noLoc dict_and_method_pats) Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index df7156a..164316c 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -26,7 +26,7 @@ import DsMeta ( dsBracket ) #endif import HsSyn -import TcHsSyn ( hsPatType ) +import TcHsSyn ( hsPatType, mkVanillaTuplePat ) -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not @@ -736,7 +736,7 @@ dsMDo tbl stmts body result_ty mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat [p] = p - mk_tup_pat ps = noLoc $ TuplePat ps Boxed + mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id mk_ret_tup [r] = r diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 7eb62ff..6bb41a9 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import BasicTypes ( Boxity(..) ) import HsSyn -import TcHsSyn ( hsPatType ) +import TcHsSyn ( hsPatType, mkVanillaTuplePat ) import CoreSyn import DsMonad -- the monadery used in the desugarer @@ -157,7 +157,7 @@ deListComp (ParStmt stmtss_w_bndrs : quals) body list bndrs_s = map snd stmtss_w_bndrs -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above - pat = noLoc (TuplePat pats Boxed) + pat = mkTuplePat pats pats = map mk_hs_tuple_pat bndrs_s -- Types of (x1,..,xn), (y1,..,yn) etc @@ -263,8 +263,7 @@ mk_hs_tuple_expr [id] = nlHsVar id mk_hs_tuple_expr ids = noLoc $ ExplicitTuple [ nlHsVar i | i <- ids ] Boxed mk_hs_tuple_pat :: [Id] -> LPat Id -mk_hs_tuple_pat [b] = nlVarPat b -mk_hs_tuple_pat bs = noLoc $ TuplePat (map nlVarPat bs) Boxed +mk_hs_tuple_pat bs = mkTuplePat (map nlVarPat bs) \end{code} @@ -505,9 +504,9 @@ parrElemType e = -- Smart constructor for source tuple patterns -- -mkTuplePat :: [LPat id] -> LPat id +mkTuplePat :: [LPat Id] -> LPat Id mkTuplePat [lpat] = lpat -mkTuplePat lpats = noLoc $ TuplePat lpats Boxed +mkTuplePat lpats = noLoc $ mkVanillaTuplePat lpats Boxed -- Smart constructor for source tuple expressions -- diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 85de165..88b0ba9 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -799,14 +799,14 @@ repLP :: LPat Name -> DsM (Core TH.PatQ) repLP (L _ p) = repP p repP :: Pat Name -> DsM (Core TH.PatQ) -repP (WildPat _) = repPwild -repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } -repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } -repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } -repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } -repP (ParPat p) = repLP p -repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } -repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs } +repP (WildPat _) = repPwild +repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } +repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } +repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } +repP (ParPat p) = repLP p +repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } +repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 5472d7b..70944f8 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -586,7 +586,7 @@ mkSelectorBinds pat val_expr is_simple_lpat p = is_simple_pat (unLoc p) - is_simple_pat (TuplePat ps Boxed) = all is_triv_lpat ps + is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps) is_simple_pat (VarPat _) = True is_simple_pat (ParPat p) = is_simple_lpat p diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index c0ad86d..19cace8 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -10,7 +10,7 @@ module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where import DynFlags ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( hsPatType ) +import TcHsSyn ( mkVanillaTuplePat ) import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( bindNonRec, exprType ) @@ -25,7 +25,7 @@ import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyN import PrelInfo ( pAT_ERROR_ID ) import TcType ( Type, tcTyConAppArgs ) import Type ( splitFunTysN, mkTyVarTys ) -import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, +import TysWiredIn ( consDataCon, mkListTy, unitTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import ListSetOps ( runs ) @@ -452,18 +452,17 @@ tidy1 v wrap (PArrPat pats ty) arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) -tidy1 v wrap (TuplePat pats boxity) +tidy1 v wrap (TuplePat pats boxity ty) = returnDs (wrap, unLoc tuple_ConPat) where arity = length pats - tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats - (mkTupleTy boxity arity (map hsPatType pats)) + tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty tidy1 v wrap (DictPat dicts methods) = case num_of_d_and_ms of - 0 -> tidy1 v wrap (TuplePat [] Boxed) + 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats)) - _ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed) + _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map nlVarPat (dicts ++ methods) diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 90675fb..6ff502a 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -8,6 +8,8 @@ module MatchCon ( matchConFamily ) where #include "HsVersions.h" +import Id( idType ) + import {-# SOURCE #-} Match ( match ) import HsSyn ( Pat(..), HsConDetails(..) ) diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 1a35106..6c14c11 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -437,7 +437,7 @@ cvtp (TH.LitP l) | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } cvtp (TupP [p]) = cvtp p -cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed } +cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 ; return $ ConPatIn s' (InfixCon p1' p2') } diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 4880120..eca7dd1 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -60,6 +60,18 @@ data Pat id | TuplePat [LPat id] -- Tuple Boxity -- UnitPat is TuplePat [] + PostTcType + -- You might think that the PostTcType was redundant, but it's essential + -- data T a where + -- T1 :: Int -> T Int + -- f :: (T a, a) -> Int + -- f (T1 x, z) = z + -- When desugaring, we must generate + -- f = /\a. \v::a. case v of (t::T a, w::a) -> + -- case t of (T1 (x::Int)) -> + -- Note the (w::a), NOT (w::Int), because we have not yet + -- refined 'a' to Int. So we must know that the second component + -- of the tuple is of type 'a' not Int. See selectMatchVar | PArrPat [LPat id] -- Syntactic parallel array PostTcType -- The type of the elements @@ -145,16 +157,16 @@ pprPatBndr var -- Print with type info if -dppr-debug is on pprPat :: (OutputableBndr name) => Pat name -> SDoc -pprPat (VarPat var) = pprPatBndr var -pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs)) -pprPat (WildPat _) = char '_' -pprPat (LazyPat pat) = char '~' <> ppr pat -pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) -pprPat (ParPat pat) = parens (ppr pat) +pprPat (VarPat var) = pprPatBndr var +pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs)) +pprPat (WildPat _) = char '_' +pprPat (LazyPat pat) = char '~' <> ppr pat +pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) +pprPat (ParPat pat) = parens (ppr pat) -pprPat (ListPat pats _) = brackets (interpp'SP pats) -pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) -pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats) +pprPat (ListPat pats _) = brackets (interpp'SP pats) +pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats) pprPat (ConPatIn con details) = pprUserCon con details pprPat (ConPatOut con tvs dicts binds details _) @@ -253,7 +265,7 @@ isConPat (ConPatIn _ _) = True isConPat (ConPatOut _ _ _ _ _ _) = True isConPat (ListPat _ _) = True isConPat (PArrPat _ _) = True -isConPat (TuplePat _ _) = True +isConPat (TuplePat _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 isConPat other = False @@ -279,17 +291,17 @@ isIrrefutableHsPat pat where go (L _ pat) = go1 pat - go1 (WildPat _) = True - go1 (VarPat _) = True - go1 (VarPatOut _ _) = True - go1 (LazyPat pat) = True - go1 (ParPat pat) = go pat - go1 (AsPat _ pat) = go pat - go1 (SigPatIn pat _) = go pat - go1 (SigPatOut pat _) = go pat - go1 (TuplePat pats _) = all go pats - go1 (ListPat pats _) = False - go1 (PArrPat pats _) = False -- ? + go1 (WildPat _) = True + go1 (VarPat _) = True + go1 (VarPatOut _ _) = True + go1 (LazyPat pat) = True + go1 (ParPat pat) = go pat + go1 (AsPat _ pat) = go pat + go1 (SigPatIn pat _) = go pat + go1 (SigPatOut pat _) = go pat + go1 (TuplePat pats _ _) = all go pats + go1 (ListPat pats _) = False + go1 (PArrPat pats _) = False -- ? go1 (ConPatIn _ _) = False -- Conservative go1 (ConPatOut (L _ con) _ _ _ details _) diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index 0ff936d..df4885f 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -200,7 +200,7 @@ nlWildConPat :: DataCon -> LPat RdrName nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) -nlTuplePat pats box = noLoc (TuplePat pats box) +nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id @@ -381,7 +381,7 @@ collectl (L l pat) bndrs go (ListPat pats _) = foldr collectl bndrs pats go (PArrPat pats _) = foldr collectl bndrs pats - go (TuplePat pats _) = foldr collectl bndrs pats + go (TuplePat pats _ _) = foldr collectl bndrs pats go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps) go (ConPatOut c _ ds bs ps _) = map noLoc ds @@ -407,15 +407,15 @@ collectSigTysFromPat pat = collect_lpat pat [] collect_lpat pat acc = collect_pat (unLoc pat) acc -collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) -collect_pat (TypePat ty) acc = ty:acc - -collect_pat (LazyPat pat) acc = collect_lpat pat acc -collect_pat (AsPat a pat) acc = collect_lpat pat acc -collect_pat (ParPat pat) acc = collect_lpat pat acc -collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats -collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats -collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats -collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) -collect_pat other acc = acc -- Literals, vars, wildcard +collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) +collect_pat (TypePat ty) acc = ty:acc + +collect_pat (LazyPat pat) acc = collect_lpat pat acc +collect_pat (AsPat a pat) acc = collect_lpat pat acc +collect_pat (ParPat pat) acc = collect_lpat pat acc +collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats +collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats +collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats +collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) +collect_pat other acc = acc -- Literals, vars, wildcard \end{code} diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 75229a8..5c5f7d1 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -557,7 +557,7 @@ checkAPat loc e = case e of return (PArrPat ps placeHolderType) ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> - return (TuplePat ps b) + return (TuplePat ps b placeHolderType) RecordCon c _ fs -> mapM checkPatField fs >>= \fs -> return (ConPatIn c (RecCon fs)) diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index a75d989..bfd0289 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -617,10 +617,11 @@ rnPat (PArrPat pats _) where implicit_fvs = mkFVs [lengthPName, indexPName] -rnPat (TuplePat pats boxed) +rnPat (TuplePat pats boxed _) = checkTupSize tup_size `thenM_` rnLPats pats `thenM` \ (patslist, fvs) -> - returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name) + returnM (TuplePat patslist boxed placeHolderType, + fvs `addOneFV` tycon_name) where tup_size = length pats tycon_name = tupleTyCon_name boxed tup_size diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index f0858f3..745de00 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -40,14 +40,12 @@ import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) ) import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( tcOverloadedLit, badFieldCon ) import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox, - tcInstBoxyTyVar, tcInstTyVar, zonkTcType ) + tcInstBoxyTyVar, tcInstTyVar ) import TcType ( TcType, TcSigmaType, TcRhoType, BoxySigmaType, BoxyRhoType, ThetaType, - tcSplitFunTys, mkTyVarTys, mkFunTys, - tcMultiSplitSigmaTy, tcSplitFunTysN, + mkTyVarTys, mkFunTys, tcMultiSplitSigmaTy, tcSplitFunTysN, isSigmaTy, mkFunTy, mkTyConApp, isLinearPred, exactTyVarsOfType, exactTyVarsOfTypes, mkTyVarTy, - tidyOpenType, zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar, lookupTyVar ) import Kind ( argTypeKind ) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 3bf8b4a..4289c2c 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -11,7 +11,7 @@ module TcHsSyn ( mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp, hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, - nlHsIntLit, + nlHsIntLit, mkVanillaTuplePat, -- re-exported from TcMonad @@ -66,6 +66,11 @@ import Outputable Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@, then something is wrong. \begin{code} +mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id +-- A vanilla tuple pattern simply gets its type from its sub-patterns +mkVanillaTuplePat pats box + = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats)) + hsPatType :: OutPat Id -> Type hsPatType pat = pat_type (unLoc pat) @@ -78,7 +83,7 @@ pat_type (LitPat lit) = hsLitType lit pat_type (AsPat var pat) = idType (unLoc var) pat_type (ListPat _ ty) = mkListTy ty pat_type (PArrPat _ ty) = mkPArrTy ty -pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats) +pat_type (TuplePat pats box ty) = ty pat_type (ConPatOut _ _ _ _ _ ty) = ty pat_type (SigPatOut pat ty) = ty pat_type (NPat lit _ _ ty) = ty @@ -723,9 +728,10 @@ zonk_pat env (PArrPat pats ty) ; (env', pats') <- zonkPats env pats ; return (env', PArrPat pats' ty') } -zonk_pat env (TuplePat pats boxed) - = do { (env', pats') <- zonkPats env pats - ; return (env', TuplePat pats' boxed) } +zonk_pat env (TuplePat pats boxed ty) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', TuplePat pats' boxed ty') } zonk_pat env (ConPatOut n tvs dicts binds stuff ty) = ASSERT( all isImmutableTyVar tvs ) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 4244763..2ab8d19 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -336,7 +336,7 @@ tc_pat pstate (PArrPat pats _) pat_ty thing_inside ; ifM (null pats) (zapToMonotype pat_ty) -- c.f. ExplicitPArr in TcExpr ; return (PArrPat pats' elt_ty, pats_tvs, res) } -tc_pat pstate (TuplePat pats boxity) pat_ty thing_inside +tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length pats)) pat_ty ; (pats', pats_tvs, res) <- tc_lpats pstate pats arg_tys thing_inside @@ -344,7 +344,7 @@ tc_pat pstate (TuplePat pats boxity) pat_ty thing_inside -- so that we can experiment with lazy tuple-matching. -- This is a pretty odd place to make the switch, but -- it was easy to do. - ; let unmangled_result = TuplePat pats' boxity + ; let unmangled_result = TuplePat pats' boxity pat_ty possibly_mangled_result | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result) | otherwise = unmangled_result diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index a9de7c9..2c97364 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -523,7 +523,7 @@ bimapTuple eps toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) } where names = takeList eps gs_RDR - tuple_pat = TuplePat (map nlVarPat names) Boxed + tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType eps_w_names = eps `zip` names to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed -- 1.7.10.4