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.

3 files changed, 23 insertions, 14 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index fc291f2047..04ca09e689 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -830,8 +830,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
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index ef888fe5a8..4b8fcdaae7 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -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}
 
 
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 4ac1bf0d5a..ae7866cf03 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -383,7 +383,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