From 0dac952932514c931b00b1fae555ebde79f2b4db Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Sat, 14 Jun 2008 12:39:39 +0000
Subject: [PATCH] Fix Trac #2358: 1-tuples in Template Haskell

fons points out that TH was treating 1-tuples inconsistently.  Generally
we make a 1-tuple into a no-op, so that (e) and e are the same.  But
I'd forgotten to do this for types.

It is possible to have a type with an un-saturated 1-tuple type
constructor. That now elicits an error message when converting from
TH syntax to Hs syntax
---
 compiler/hsSyn/Convert.lhs |   18 +++++++++++-------
 1 file changed, 11 insertions(+), 7 deletions(-)

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 42aa001..5b3c5e8 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -366,7 +366,7 @@ cvtl e = wrapL (cvt e)
     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e 
 			    ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
-    cvt (TupE [e])     = cvt e
+    cvt (TupE [e])     = cvt e	-- Singleton tuples treated like nothing (just parens)
     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
 			    ; return $ HsIf x' y' z' }
@@ -514,10 +514,13 @@ cvtPred ty
 	    _       -> failWith (ptext (sLit "Malformed predicate") <+> text (TH.pprint ty)) }
 
 cvtType :: TH.Type -> CvtM (LHsType RdrName)
-cvtType ty = do { (head, tys') <- split_ty_app ty
-		; case head of
-		    TupleT n | length tys' == n -> returnL (HsTupleTy Boxed tys')
-		             | n == 0    -> mk_apps (HsTyVar (getRdrName unitTyCon)) tys'
+cvtType ty = do { (head_ty, tys') <- split_ty_app ty
+		; case head_ty of
+		    TupleT n | length tys' == n 	-- Saturated
+			     -> if n==1 then return (head tys')	-- Singleton tuples treated 
+								-- like nothing (ie just parens)
+					else returnL (HsTupleTy Boxed tys')
+		             | n == 1    -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 		             | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 		    ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 		    ListT  | [x']    <- tys' -> returnL (HsListTy x')
@@ -531,8 +534,9 @@ cvtType ty = do { (head, tys') <- split_ty_app ty
 		    _       -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 	     }
   where
-    mk_apps head []       = returnL head
-    mk_apps head (ty:tys) = do { head' <- returnL head; mk_apps (HsAppTy head' ty) tys }
+    mk_apps head_ty []       = returnL head_ty
+    mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
+				  ; mk_apps (HsAppTy head_ty' ty) tys }
 
 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 split_ty_app ty = go ty []
-- 
1.7.10.4