Fix desugaring of unboxed tuples

[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsSyn.lhs

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 3bf8b4a..c2355a0 100644 (file)
--- 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,19 +66,25 @@ 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)
+hsPatType (L _ pat) = pat_type pat
 
 pat_type (ParPat pat)             = hsPatType pat
 pat_type (WildPat ty)             = ty
 pat_type (VarPat var)             = idType var
 pat_type (VarPatOut var _)        = idType var
+pat_type (BangPat pat)            = hsPatType pat
 pat_type (LazyPat pat)            = hsPatType pat
 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
@@ -708,6 +714,10 @@ zonk_pat env (LazyPat pat)
   = do { (env', pat') <- zonkPat env pat
        ; return (env',  LazyPat pat') }
 
+zonk_pat env (BangPat pat)
+  = do { (env', pat') <- zonkPat env pat
+       ; return (env',  BangPat pat') }
+
 zonk_pat env (AsPat (L loc v) pat)
   = do { v' <- zonkIdBndr env v
        ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
@@ -723,9 +733,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 )