Fix egregious instantiation bug in matchOneConLike (fixing Trac #9023)

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.

6 files changed, 40 insertions, 47 deletions

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index d008893d32..e07a70fc65 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -23,7 +23,6 @@ import Name
 import TysWiredIn
 import PrelNames
 import TyCon
-import Type
 import SrcLoc
 import UniqSet
 import Util
@@ -146,7 +145,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"
@@ -470,8 +469,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
@@ -595,9 +594,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
@@ -698,17 +697,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
@@ -716,11 +714,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
 
@@ -737,8 +735,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
 
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 31c4d1750b..4eadef69b8 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -550,7 +550,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
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 557e77589c..c52b917efd 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -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
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 68e55bd68d..a14027862a 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -554,9 +554,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
@@ -565,13 +564,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)
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index ef74bff1c6..4eec0d24bd 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -125,7 +125,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
 
@@ -141,27 +141,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
@@ -179,7 +176,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)
 
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 07cf420372..350ed22d69 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -266,8 +266,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
@@ -299,7 +299,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