Fix egregious instantiation bug in matchOneConLike (fixing Trac #9023)
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 5 Jun 2014 10:03:45 +0000 (11:03 +0100)
committerAustin Seipp <austin@well-typed.com>
Thu, 3 Jul 2014 15:14:43 +0000 (10:14 -0500)
We simply weren't giving anything like the right instantiating types
to patSynInstArgTys in matchOneConLike.

To get these instantiating types would have involved matching the
result type of the pattern synonym with the pattern type, which is
tiresome.  So instead I changed ConPatOut so that instead of recording
the type of the *whole* pattern (in old field pat_ty), it not records
the *instantiating* types (in new field pat_arg_tys).  Then we canuse
TcHsSyn.conLikeResTy to get the pattern type when needed.

There are lots of knock-on incidental effects, but they mostly made
the code simpler, so I'm happy.

(cherry picked from commit 0a55a3cada2fea37586b1a270c1511ed9957dbd4)

14 files changed:
compiler/basicTypes/PatSyn.lhs
compiler/deSugar/Check.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/deSugar/MatchLit.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsUtils.lhs
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnPat.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcPat.lhs

index 29c1193..b3c8501 100644 (file)
@@ -14,7 +14,8 @@ module PatSyn (
         patSynId, patSynType, patSynArity, patSynIsInfix,
         patSynArgs, patSynTyDetails,
         patSynWrapper, patSynMatcher,
-        patSynExTyVars, patSynSig, patSynInstArgTys
+        patSynExTyVars, patSynSig, 
+        patSynInstArgTys, patSynInstResTy
     ) where
 
 #include "HsVersions.h"
@@ -124,7 +125,7 @@ data PatSyn
         psExTyVars    :: [TyVar],     -- Existentially-quantified type vars
         psProvTheta   :: ThetaType,   -- Provided dictionaries
         psReqTheta    :: ThetaType,   -- Required dictionaries
-        psOrigResTy   :: Type,
+        psOrigResTy   :: Type,        -- Mentions only psUnivTyVars
 
         -- See Note [Matchers and wrappers for pattern synonyms]
         psMatcher     :: Id,
@@ -262,6 +263,13 @@ patSynMatcher :: PatSyn -> Id
 patSynMatcher = psMatcher
 
 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
+-- Return the types of the argument patterns
+-- e.g.  data D a = forall b. MkD a b (b->a)
+--       pattern P f x y = MkD (x,True) y f
+--          D :: forall a. forall b. a -> b -> (b->a) -> D a
+--          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
+--   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
+-- NB: the inst_tys should be both universal and existential
 patSynInstArgTys ps inst_tys
   = ASSERT2( length tyvars == length inst_tys
           , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
@@ -269,4 +277,17 @@ patSynInstArgTys ps inst_tys
   where
     (univ_tvs, ex_tvs, _, _) = patSynSig ps
     tyvars = univ_tvs ++ ex_tvs
+
+patSynInstResTy :: PatSyn -> [Type] -> Type
+-- Return the type of whole pattern
+-- E.g.  pattern P x y = Just (x,x,y)
+--         P :: a -> b -> Just (a,a,b)
+--         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
+-- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
+patSynInstResTy ps inst_tys
+  = ASSERT2( length univ_tvs == length inst_tys
+           , ptext (sLit "patSynInstResTy") <+> ppr ps $$ ppr univ_tvs $$ ppr inst_tys )
+    substTyWith univ_tvs inst_tys (psOrigResTy ps)
+  where
+    (univ_tvs, _, _, _) = patSynSig ps
 \end{code}
index 960475c..409c05b 100644 (file)
@@ -21,7 +21,6 @@ import Name
 import TysWiredIn
 import PrelNames
 import TyCon
-import Type
 import SrcLoc
 import UniqSet
 import Util
@@ -144,7 +143,7 @@ untidy b (L loc p) = L loc (untidy' b p)
     untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
     untidy' b (ConPatIn name ps)     = pars b (L loc (ConPatIn name (untidy_con ps)))
     untidy' _ (ListPat pats ty Nothing)     = ListPat (map untidy_no_pars pats) ty Nothing   
-    untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
+    untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys
     untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"    
     untidy' _ (PArrPat _ _)          = panic "Check.untidy: Shouldn't get a parallel array here!"
     untidy' _ (SigPatIn _ _)         = panic "Check.untidy: SigPat"
@@ -468,8 +467,8 @@ get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
      where
        used_set :: UniqSet DataCon
        used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]
-       (ConPatOut { pat_ty = ty }) = head used_cons
-       Just (ty_con, inst_tys) = splitTyConApp_maybe ty
+       (ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons
+       ty_con      = dataConTyCon con1
        unused_cons = filterOut is_used (tyConDataCons ty_con)
        is_used con = con `elementOfUniqSet` used_set
                      || dataConCannotMatch inst_tys con
@@ -593,9 +592,9 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
      | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints)
    where q  = unLoc lq
 
-make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_ty = 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)
+make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints)
+      | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : 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
@@ -696,17 +695,16 @@ tidy_pat (CoPat _ pat _)  = tidy_pat pat
 tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
 tidy_pat (ViewPat _ _ ty)     = WildPat ty
 tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
-tidy_pat (ConPatOut { pat_con = L _ PatSynCon{}, pat_ty = ty })
-  = WildPat ty
+tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys })
+  = WildPat (patSynInstResTy syn tys)
 
 tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })
   = pat { pat_args = tidy_con con ps }
 
 tidy_pat (ListPat ps ty Nothing)
-  = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
-                                  (mkNilPat list_ty)
+  = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty])
+                                  (mkNilPat ty)
                                   (map tidy_lpat ps)
-  where list_ty = mkListTy ty
 
 -- introduce fake parallel array constructors to be able to handle parallel
 -- arrays with the existing machinery for constructor pattern
@@ -714,11 +712,11 @@ tidy_pat (ListPat ps ty Nothing)
 tidy_pat (PArrPat ps ty)
   = unLoc $ mkPrefixConPat (parrFakeCon (length ps))
                            (map tidy_lpat ps)
-                           (mkPArrTy ty)
+                           [ty]
 
-tidy_pat (TuplePat ps boxity ty)
+tidy_pat (TuplePat ps boxity tys)
   = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)
-                           (map tidy_lpat ps) ty
+                           (map tidy_lpat ps) tys
   where
     arity = length ps
 
@@ -735,8 +733,8 @@ tidy_lit_pat :: HsLit -> Pat Id
 -- overlap with each other, or even explicit lists of Chars.
 tidy_lit_pat lit
   | HsString s <- lit
-  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
-                  (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
+                  (mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s)
   | otherwise
   = tidyLitPat lit
 
index 859309d..a9b7003 100644 (file)
@@ -548,7 +548,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
                                          , pat_dicts = eqs_vars ++ theta_vars
                                          , pat_binds = emptyTcEvBinds
                                          , pat_args = PrefixCon $ map nlVarPat arg_ids
-                                         , pat_ty = in_ty
+                                         , pat_arg_tys = in_inst_tys
                                          , pat_wrap = idHsWrapper }
            ; let wrapped_rhs | null eq_spec = rhs
                              | otherwise    = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
index 2ad70c6..05c2170 100644 (file)
@@ -709,8 +709,7 @@ mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
 
 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 (boxityNormalTupleSort box) (map hsLPatType pats))
+mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
 
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTup :: [Id] -> LHsExpr Id
index b42a720..2a865a9 100644 (file)
@@ -552,9 +552,8 @@ tidy1 v (LazyPat pat)
 tidy1 _ (ListPat pats ty Nothing)
   = return (idDsWrapper, unLoc list_ConPat)
   where
-    list_ty     = mkListTy ty
-    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
-                        (mkNilPat list_ty)
+    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
+                        (mkNilPat ty)
                         pats
 
 -- Introduce fake parallel array constructors to be able to handle parallel
@@ -563,13 +562,13 @@ tidy1 _ (PArrPat pats ty)
   = return (idDsWrapper, unLoc parrConPat)
   where
     arity      = length pats
-    parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
+    parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
 
-tidy1 _ (TuplePat pats boxity ty)
+tidy1 _ (TuplePat pats boxity tys)
   = return (idDsWrapper, unLoc tuple_ConPat)
   where
     arity = length pats
-    tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty
+    tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys
 
 -- LitPats: we *might* be able to replace these w/ a simpler form
 tidy1 _ (LitPat lit)
index 2b51638..fb02456 100644 (file)
@@ -124,7 +124,7 @@ matchOneConLike :: [Id]
                 -> [EquationInfo]
                 -> DsM (CaseAlt ConLike)
 matchOneConLike vars ty (eqn1 : eqns)  -- All eqns for a single constructor
-  = do { arg_vars <- selectConMatchVars arg_tys args1
+  = do { arg_vars <- selectConMatchVars val_arg_tys args1
                -- Use the first equation as a source of 
                -- suggestions for the new variables
 
@@ -140,27 +140,24 @@ matchOneConLike vars ty (eqn1 : eqns)     -- All eqns for a single constructor
                               alt_wrapper = wrapper1,
                               alt_result = foldr1 combineMatchResults match_results } }
   where
-    ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_wrap = wrapper1,
+    ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
                pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
              = firstPat eqn1
     fields1 = case con1 of
-        RealDataCon dcon1 -> dataConFieldLabels dcon1
-       PatSynCon{} -> []
-
-    arg_tys  = inst inst_tys
-      where
-        inst = case con1 of
-            RealDataCon dcon1 -> dataConInstOrigArgTys dcon1
-            PatSynCon psyn1 -> patSynInstArgTys psyn1
-    inst_tys = tcTyConAppArgs pat_ty1 ++ 
-              mkTyVarTys (takeList exVars tvs1)
-       -- Newtypes opaque, hence tcTyConAppArgs
+               RealDataCon dcon1 -> dataConFieldLabels dcon1
+               PatSynCon{}       -> []
+
+    val_arg_tys = case con1 of
+                    RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys
+                    PatSynCon psyn1   -> patSynInstArgTys      psyn1 inst_tys
+    inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )
+               arg_tys ++ mkTyVarTys tvs1
        -- dataConInstOrigArgTys takes the univ and existential tyvars
        -- and returns the types of the *value* args, which is what we want
-      where
-        exVars = case con1 of
-            RealDataCon dcon1 -> dataConExTyVars dcon1
-            PatSynCon psyn1 -> patSynExTyVars psyn1
+
+    ex_tvs = case con1 of
+               RealDataCon dcon1 -> dataConExTyVars dcon1
+               PatSynCon psyn1 -> patSynExTyVars psyn1
 
     match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
     -- All members of the group have compatible ConArgPats
@@ -178,7 +175,7 @@ matchOneConLike vars ty (eqn1 : eqns)       -- All eqns for a single constructor
            return ( wrapBinds (tvs `zip` tvs1)
                   . wrapBinds (ds  `zip` dicts1)
                   . mkCoreLets ds_bind
-                  , eqn { eqn_pats = conArgPats arg_tys args ++ pats }
+                  , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats }
                   )
     shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
 
index 7429a61..9652bdf 100644 (file)
@@ -264,8 +264,8 @@ tidyLitPat :: HsLit -> Pat Id
 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
 tidyLitPat (HsString s)
   | lengthFS s <= 1     -- Short string literals only
-  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
-                  (mkNilPat stringTy) (unpackFS s)
+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
+                  (mkNilPat charTy) (unpackFS s)
         -- The stringTy is the type of the whole pattern, not
         -- the type to instantiate (:) or [] with!
 tidyLitPat lit = LitPat lit
@@ -297,7 +297,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
   | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
   where
     mk_con_pat :: DataCon -> HsLit -> Pat Id
-    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
+    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
 
     mb_int_lit :: Maybe Integer
     mb_int_lit = case (mb_neg, val) of
index bd70cd7..d40e9c8 100644 (file)
@@ -827,8 +827,8 @@ 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])        = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
-cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
-cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
+cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed   [] }
+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
 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
index ef888fe..4b8fcda 100644 (file)
@@ -75,10 +75,13 @@ data Pat id
                    -- overall type of the pattern, and the toList
                    -- function to convert the scrutinee to a list value
 
-  | TuplePat    [LPat id]               -- Tuple
-                Boxity                  -- UnitPat is TuplePat []
-                PostTcType
-        -- You might think that the PostTcType was redundant, but it's essential
+  | TuplePat    [LPat id]    -- Tuple sub-patterns
+                Boxity       -- UnitPat is TuplePat []
+                [PostTcType] -- [] before typechecker, filled in afterwards with
+                             -- the types of the tuple components
+        -- You might think that the PostTcType was redundant, because we can 
+        -- get the pattern type by getting the types of the sub-patterns.
+        -- But it's essential
         --      data T a where
         --        T1 :: Int -> T Int
         --      f :: (T a, a) -> Int
@@ -89,6 +92,8 @@ data Pat id
         -- 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
+        -- (June 14: I'm not sure this comment is right; the sub-patterns
+        --           will be wrapped in CoPats, no?)
 
   | PArrPat     [LPat id]               -- Syntactic parallel array
                 PostTcType              -- The type of the elements
@@ -98,14 +103,18 @@ data Pat id
                 (HsConPatDetails id)
 
   | ConPatOut {
-        pat_con   :: Located ConLike,
+        pat_con     :: Located ConLike,
+        pat_arg_tys :: [Type],          -- The univeral arg types, 1-1 with the universal
+                                        -- tyvars of the constructor/pattern synonym
+                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get 
+                                        --   the type of the pattern
+
         pat_tvs   :: [TyVar],           -- Existentially bound type variables (tyvars only)
         pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*
                                         -- One reason for putting coercion variable here, I think,
                                         --      is to ensure their kinds are zonked
         pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
         pat_args  :: HsConPatDetails id,
-        pat_ty    :: Type,              -- The type of the pattern
         pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
     }
 
@@ -313,18 +322,18 @@ instance (OutputableBndr id, Outputable arg)
 %************************************************************************
 
 \begin{code}
-mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
+mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
 -- Make a vanilla Prefix constructor pattern
-mkPrefixConPat dc pats ty
+mkPrefixConPat dc pats tys
   = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
                         pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
-                        pat_ty = ty, pat_wrap = idHsWrapper }
+                        pat_arg_tys = tys, pat_wrap = idHsWrapper }
 
 mkNilPat :: Type -> OutPat id
-mkNilPat ty = mkPrefixConPat nilDataCon [] ty
+mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
 
 mkCharLitPat :: Char -> OutPat id
-mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
+mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] []
 \end{code}
 
 
index eff67df..a5ffda2 100644 (file)
@@ -382,7 +382,7 @@ mkLHsVarTuple :: [a] -> LHsExpr a
 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
 
 nlTuplePat :: [LPat id] -> Boxity -> LPat id
-nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+nlTuplePat pats box = noLoc (TuplePat pats box [])
 
 missingTupArg :: HsTupArg a
 missingTupArg = Missing placeHolderType
index 03ec622..ec00a8f 100644 (file)
@@ -666,7 +666,7 @@ checkAPat msg loc e0 = do
 
    ExplicitTuple es b
      | all tupArgPresent es  -> do ps <- mapM (checkLPat msg) [e | Present e <- es]
-                                   return (TuplePat ps b placeHolderType)
+                                   return (TuplePat ps b [])
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
    RecordCon c _ (HsRecFields fs dd)
index 3c48f34..e668cee 100644 (file)
@@ -439,7 +439,7 @@ rnPatAndThen mk (PArrPat pats _)
 rnPatAndThen mk (TuplePat pats boxed _)
   = do { liftCps $ checkTupSize (length pats)
        ; pats' <- rnLPatsAndThen mk pats
-       ; return (TuplePat pats' boxed placeHolderType) }
+       ; return (TuplePat pats' boxed []) }
 
 rnPatAndThen _ (SplicePat splice)
   = do { -- XXX How to deal with free variables?
index 59b42ea..a99888f 100644 (file)
@@ -15,6 +15,7 @@ module TcHsSyn (
         mkHsAppTy, mkSimpleHsAlt,
         nlHsIntLit,
         shortCutLit, hsOverLitName,
+        conLikeResTy,
 
         -- re-exported from TcMonad
         TcId, TcIdSet,
@@ -38,7 +39,9 @@ import TcEvidence
 import TysPrim
 import TysWiredIn
 import Type
+import ConLike
 import DataCon
+import PatSyn( patSynInstResTy )
 import Name
 import NameSet
 import Var
@@ -80,14 +83,19 @@ hsPatType (ViewPat _ _ ty)            = ty
 hsPatType (ListPat _ ty Nothing)      = mkListTy ty
 hsPatType (ListPat _ _ (Just (ty,_))) = ty
 hsPatType (PArrPat _ ty)              = mkPArrTy ty
-hsPatType (TuplePat _ _ ty)           = ty
-hsPatType (ConPatOut { pat_ty = ty }) = ty
+hsPatType (TuplePat _ bx tys)         = mkTupleTy (boxityNormalTupleSort bx) tys
+hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) 
+                                      = conLikeResTy con tys
 hsPatType (SigPatOut _ ty)            = ty
 hsPatType (NPat lit _ _)              = overLitType lit
 hsPatType (NPlusKPat id _ _ _)        = idType (unLoc id)
 hsPatType (CoPat _ _ ty)              = ty
 hsPatType p                           = pprPanic "hsPatType" (ppr p)
 
+conLikeResTy :: ConLike -> [Type] -> Type
+conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
+conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys
+
 hsLitType :: HsLit -> TcType
 hsLitType (HsChar _)       = charTy
 hsLitType (HsCharPrim _)   = charPrimTy
@@ -1025,16 +1033,16 @@ zonk_pat env (PArrPat pats ty)
         ; (env', pats') <- zonkPats env pats
         ; return (env', PArrPat pats' ty') }
 
-zonk_pat env (TuplePat pats boxed ty)
-  = do  { ty' <- zonkTcTypeToType env ty
+zonk_pat env (TuplePat pats boxed tys)
+  = do  { tys' <- mapM (zonkTcTypeToType env) tys
         ; (env', pats') <- zonkPats env pats
-        ; return (env', TuplePat pats' boxed ty') }
+        ; return (env', TuplePat pats' boxed tys') }
 
-zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars
+zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
                           , pat_dicts = evs, pat_binds = binds
                           , pat_args = args, pat_wrap = wrapper })
   = ASSERT( all isImmutableTyVar tyvars )
-    do  { new_ty <- zonkTcTypeToType env ty
+    do  { new_tys <- mapM (zonkTcTypeToType env) tys
         ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
           -- Must zonk the existential variables, because their
           -- /kind/ need potential zonking.
@@ -1043,7 +1051,7 @@ zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars
         ; (env2, new_binds) <- zonkTcEvBinds env1 binds
         ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
         ; (env', new_args) <- zonkConStuff env3 args
-        ; return (env', p { pat_ty = new_ty,
+        ; return (env', p { pat_arg_tys = new_tys,
                             pat_tvs = new_tyvars,
                             pat_dicts = new_evs,
                             pat_binds = new_binds,
index 951c168..927062e 100644 (file)
@@ -531,9 +531,9 @@ tc_pat penv (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 pat_ty'          = mkTyConApp tc arg_tys
-                                     -- pat_ty /= pat_ty iff coi /= IdCo
-              unmangled_result = TuplePat pats' boxity pat_ty'
+       ; let 
+              unmangled_result = TuplePat pats' boxity arg_tys
+                                 -- pat_ty /= pat_ty iff coi /= IdCo
              possibly_mangled_result
                | gopt Opt_IrrefutableTuples dflags &&
                   isBoxed boxity            = LazyPat (noLoc unmangled_result)
@@ -730,14 +730,14 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
                                (zipTopTvSubst univ_tvs ctxt_res_tys) ex_tvs
                      -- Get location from monad, not from ex_tvs
 
-        ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
+        ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
              -- pat_ty' is type of the actual constructor application
               -- pat_ty' /= pat_ty iff coi /= IdCo
 
              arg_tys' = substTys tenv arg_tys
 
         ; traceTc "tcConPat" (vcat [ ppr con_name, ppr univ_tvs, ppr ex_tvs, ppr eq_spec
-                                   , ppr ex_tvs', ppr pat_ty', ppr arg_tys' ])
+                                   , ppr ex_tvs', ppr ctxt_res_tys, ppr arg_tys' ])
        ; if null ex_tvs && null eq_spec && null theta
          then do { -- The common case; no class bindings etc 
                     -- (see Note [Arrows and patterns])
@@ -747,7 +747,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
                                              pat_tvs = [], pat_dicts = [], 
                                               pat_binds = emptyTcEvBinds,
                                              pat_args = arg_pats', 
-                                              pat_ty = pat_ty',
+                                              pat_arg_tys = ctxt_res_tys,
                                               pat_wrap = idHsWrapper }
 
                  ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
@@ -780,7 +780,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
                                    pat_dicts = given,
                                    pat_binds = ev_binds,
                                    pat_args  = arg_pats', 
-                                    pat_ty    = pat_ty',
+                                    pat_arg_tys = ctxt_res_tys,
                                     pat_wrap  = idHsWrapper }
        ; return (mkHsWrapPat wrap res_pat pat_ty, res)
        } }
@@ -794,7 +794,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
               arg_tys = patSynArgs pat_syn
               ty = patSynType pat_syn
 
-        ; (_univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs
+        ; (univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs
 
        ; checkExistentials ex_tvs penv
         ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs
@@ -838,7 +838,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
                                    pat_dicts = prov_dicts',
                                    pat_binds = ev_binds,
                                    pat_args  = arg_pats',
-                                    pat_ty    = ty',
+                                    pat_arg_tys = mkTyVarTys univ_tvs',
                                     pat_wrap  = req_wrap }
        ; return (mkHsWrapPat wrap res_pat pat_ty, res) }