Fix desugaring of unboxed tuples

This patch is a slightly-unsatisfactory fix to desugaring unboxed
tuples; it fixes ds057 which has been failing for some time.

Unsatisfactory because rather ad hoc -- but that applies to lots
of the unboxed tuple stuff. 

ghc/compiler/deSugar/DsExpr.lhs

@@ -8,14 +8,14 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
 
 #include "HsVersions.h"
 
-import Match		( matchWrapper, matchSimply, matchSinglePat )
+import Match		( matchWrapper, matchSinglePat, matchEquations )
 import MatchLit		( dsLit, dsOverLit )
 import DsBinds		( dsLHsBinds, dsCoercion )
 import DsGRHSs		( dsGuarded )
 import DsListComp	( dsListComp, dsPArrComp )
 import DsUtils		( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
 			  extractMatchResult, cantFailMatchResult, matchCanFail,
-			  mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence )
+			  mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence, selectMatchVar )
 import DsArrows		( dsProcExpr )
 import DsMonad
 
@@ -92,8 +92,9 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
 ds_val_bind (NonRecursive, hsbinds) body
   | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
     (L loc bind : null_binds) <- bagToList binds,
-    or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
-    || isBangHsBind bind
+    isBangHsBind bind
+    || isUnboxedTupleBind bind
+    || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
   = let
       body_w_exports		      = foldr bind_export body exports
       bind_export (tvs, g, l, _) body = ASSERT( null tvs )
@@ -113,16 +114,19 @@ ds_val_bind (NonRecursive, hsbinds) body
 	   returnDs (bindNonRec fun rhs body_w_exports)
 
       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
-	-> putSrcSpanDs loc			$
-	   dsGuarded grhss ty 			`thenDs` \ rhs ->
-	   mk_error_app pat			`thenDs` \ error_expr ->
-	   matchSimply rhs PatBindRhs pat body_w_exports error_expr
+	-> 	-- let C x# y# = rhs in body
+		-- ==> case rhs of C x# y# -> body
+	   putSrcSpanDs loc			$
+	   do { rhs <- dsGuarded grhss ty
+	      ; let upat = unLoc pat
+		    eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat], 
+				    eqn_rhs = cantFailMatchResult body_w_exports }
+	      ; var    <- selectMatchVar upat ty
+	      ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+	      ; return (scrungleMatch var rhs result) }
 
       other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
-  where
-      mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
-				    (exprType body)
-				    (showSDoc (ppr pat))
+
 
 -- Ordinary case for bindings; none should be unlifted
 ds_val_bind (is_rec, binds) body
@@ -141,6 +145,35 @@ ds_val_bind (is_rec, binds) body
 	--
 	-- NB The previous case dealt with unlifted bindings, so we
 	--    only have to deal with lifted ones now; so Rec is ok
+
+isUnboxedTupleBind :: HsBind Id -> Bool
+isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
+isUnboxedTupleBind other			 = False
+
+scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- Returns something like (let var = scrut in body)
+-- but if var is an unboxed-tuple type, it inlines it in a fragile way
+-- Special case to handle unboxed tuple patterns; they can't appear nested
+-- The idea is that 
+--	case e of (# p1, p2 #) -> rhs
+-- should desugar to
+--	case e of (# x1, x2 #) -> ... match p1, p2 ...
+-- NOT
+--	let x = e in case x of ....
+--
+-- But there may be a big 
+--	let fail = ... in case e of ...
+-- wrapping the whole case, which complicates matters slightly
+-- It all seems a bit fragile.  Test is dsrun013.
+
+scrungleMatch var scrut body
+  | isUnboxedTupleType (idType var) = scrungle body
+  | otherwise			    = bindNonRec var scrut body
+  where
+    scrungle (Case (Var x) bndr ty alts)
+		    | x == var = Case scrut bndr ty alts
+    scrungle (Let binds body)  = Let binds (scrungle body)
+    scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
 \end{code}	
 
 %************************************************************************
@@ -248,35 +281,10 @@ dsExpr (HsCoreAnn fs expr)
   = dsLExpr expr        `thenDs` \ core_expr ->
     returnDs (Note (CoreNote $ unpackFS fs) core_expr)
 
--- Special case to handle unboxed tuple patterns; they can't appear nested
--- The idea is that 
---	case e of (# p1, p2 #) -> rhs
--- should desugar to
---	case e of (# x1, x2 #) -> ... match p1, p2 ...
--- NOT
---	let x = e in case x of ....
---
--- But there may be a big 
---	let fail = ... in case e of ...
--- wrapping the whole case, which complicates matters slightly
--- It all seems a bit fragile.  Test is dsrun013.
-
-dsExpr (HsCase discrim matches@(MatchGroup _ ty))
- | isUnboxedTupleType (funArgTy ty)
- =  dsLExpr discrim			`thenDs` \ core_discrim ->
-    matchWrapper CaseAlt matches 	`thenDs` \ ([discrim_var], matching_code) ->
-    let
-	scrungle (Case (Var x) bndr ty alts) 
-		| x == discrim_var = Case core_discrim bndr ty alts
-	scrungle (Let binds body)  = Let binds (scrungle body)
-	scrungle other = panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr other))
-    in
-    returnDs (scrungle matching_code)
-
 dsExpr (HsCase discrim matches)
   = dsLExpr discrim			`thenDs` \ core_discrim ->
     matchWrapper CaseAlt matches 	`thenDs` \ ([discrim_var], matching_code) ->
-    returnDs (bindNonRec discrim_var core_discrim matching_code)
+    returnDs (scrungleMatch discrim_var core_discrim matching_code)
 
 dsExpr (HsLet binds body)
   = dsLExpr body		`thenDs` \ body' ->

ghc/compiler/deSugar/DsMonad.lhs

@@ -69,7 +69,7 @@ infixr 9 `thenDs`
 
 \begin{code}
 data DsMatchContext
-  = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
+  = DsMatchContext (HsMatchContext Name) SrcSpan
   | NoMatchContext
   deriving ()
 

ghc/compiler/deSugar/DsUtils.lhs

@@ -31,7 +31,7 @@ module DsUtils (
 	
 	dsSyntaxTable, lookupEvidence,
 
-	selectSimpleMatchVarL, selectMatchVars
+	selectSimpleMatchVarL, selectMatchVars, selectMatchVar
     ) where
 
 #include "HsVersions.h"

ghc/compiler/deSugar/Match.lhs

@@ -4,7 +4,7 @@
 \section[Main_match]{The @match@ function}
 
 \begin{code}
-module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
+module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
 
 #include "HsVersions.h"
 
@@ -69,7 +69,7 @@ matchCheck_really dflags ctx vars ty qs
   where (pats, eqns_shadow) = check qs
         incomplete    = want_incomplete && (notNull pats)
         want_incomplete = case ctx of
-                              DsMatchContext RecUpd _ _ ->
+                              DsMatchContext RecUpd _ ->
                                   dopt Opt_WarnIncompletePatternsRecUpd dflags
                               _ ->
                                   dopt Opt_WarnIncompletePatterns       dflags
@@ -90,7 +90,7 @@ The next two functions create the warning message.
 
 \begin{code}
 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
-dsShadowWarn ctx@(DsMatchContext kind _ loc) qs
+dsShadowWarn ctx@(DsMatchContext kind loc) qs
   = putSrcSpanDs loc (dsWarn warn)
   where
     warn | qs `lengthExceeds` maximum_output
@@ -103,7 +103,7 @@ dsShadowWarn ctx@(DsMatchContext kind _ loc) qs
 
 
 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
-dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats 
+dsIncompleteWarn ctx@(DsMatchContext kind loc) pats 
   = putSrcSpanDs loc (dsWarn warn)
 	where
 	  warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
@@ -115,7 +115,7 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats
 	  dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
 	       | otherwise                           = empty
 
-pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun
+pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
   = vcat [ptext SLIT("Pattern match(es)") <+> msg,
 	  sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
   where
@@ -650,19 +650,11 @@ JJQC 30-Nov-1997
 
 \begin{code}
 matchWrapper ctxt (MatchGroup matches match_ty)
-  = do	{ eqns_info <- mapM mk_eqn_info matches
-	; dflags <- getDOptsDs
-	; locn <- getSrcSpanDs
-	; let   ds_ctxt      = DsMatchContext ctxt arg_pats locn
-		error_string = matchContextErrString ctxt
-
-	; new_vars     <- selectMatchVars arg_pats pat_tys
-	; match_result <- match_fun dflags ds_ctxt new_vars rhs_ty eqns_info
-
-	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
-	; result_expr <- extractMatchResult match_result fail_expr
+  = do	{ eqns_info   <- mapM mk_eqn_info matches
+	; new_vars    <- selectMatchVars arg_pats pat_tys
+	; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
 	; return (new_vars, result_expr) }
-  where 
+  where
     arg_pats          = map unLoc (hsLMatchPats (head matches))
     n_pats	      = length arg_pats
     (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
@@ -672,8 +664,23 @@ matchWrapper ctxt (MatchGroup matches match_ty)
 	   ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
 	   ; return (EqnInfo { eqn_wrap = idWrapper,
 			       eqn_pats = upats, 
-			       eqn_rhs = match_result}) }
+			       eqn_rhs  = match_result}) }
 
+
+matchEquations  :: HsMatchContext Name
+		-> [Id]	-> [EquationInfo] -> Type
+		-> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+  = do	{ dflags <- getDOptsDs
+	; locn   <- getSrcSpanDs
+	; let   ds_ctxt      = DsMatchContext ctxt locn
+		error_string = matchContextErrString ctxt
+
+	; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+
+	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+	; extractMatchResult match_result fail_expr }
+  where 
     match_fun dflags ds_ctxt
        = case ctxt of 
            LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
@@ -719,7 +726,7 @@ matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
            | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
   	   | otherwise	       		        = match
 	   where
-	     ds_ctx = DsMatchContext hs_ctx [pat] locn
+	     ds_ctx = DsMatchContext hs_ctx locn
     in
     match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
 					eqn_pats = [pat],

ghc/compiler/typecheck/TcHsSyn.lhs

@@ -72,7 +72,7 @@ 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