X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=48844ddc85a1209f4ee1e05a02f0531c55aefeff;hb=6fa448e4c21d92d50d8a87bdd3c5f61072820c98;hp=5113f778fb8f3ad7cbdf7d0ea82ccf20170eaaec;hpb=81dd3afef58136efab3dc2691f3c7a7ee844ad91;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 5113f77..48844dd 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -51,14 +51,14 @@ convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)
 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
 convertToHsExpr loc e 
   = case initCvt loc (cvtl e) of
-	Left msg  -> Left (msg $$ (ptext (sLit "When converting TH expression")
+	Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH expression:")
 				    <+> text (show e)))
 	Right res -> Right res
 
 convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
 convertToPat loc e
   = case initCvt loc (cvtPat e) of
-        Left msg  -> Left (msg $$ (ptext (sLit "When converting TH pattern")
+        Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH pattern:")
                                     <+> text (show e)))
         Right res -> Right res
 
@@ -146,7 +146,7 @@ cvtTop (InstanceD tys ty decs)
 	; L loc pred' <- cvtPred ty
 	; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
 	; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
-						       -- ^^no ATs in TH
+					-- no ATs in TH   ^^
 	}
 
 cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
@@ -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' }
@@ -412,6 +412,8 @@ cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; retur
 
 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
 cvtHsDo do_or_lc stmts
+  | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
+  | otherwise
   = do	{ stmts' <- cvtStmts stmts
 	; let body = case last stmts' of
 			L _ (ExprStmt body _ _) -> body
@@ -455,6 +457,7 @@ cvtOverLit (StringL s)   = do { let { s' = mkFastString s }; force s'; return $
 
 cvtLit :: Lit -> CvtM HsLit
 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 cvtLit (CharL c)       = do { force c; return $ HsChar c }
@@ -513,10 +516,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')
@@ -530,8 +536,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 []
@@ -586,8 +593,8 @@ cvtName ctxt_ns (TH.Name occ flavour)
 okOcc :: OccName.NameSpace -> String -> Bool
 okOcc _  []      = False
 okOcc ns str@(c:_) 
-  | OccName.isVarName ns = startsVarId c || startsVarSym c
-  | otherwise 	 	 = startsConId c || startsConSym c || str == "[]"
+  | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
+  | otherwise 	 	      = startsConId c || startsConSym c || str == "[]"
 
 badOcc :: OccName.NameSpace -> String -> SDoc
 badOcc ctxt_ns occ 
@@ -629,8 +636,8 @@ isBuiltInOcc ctxt_ns occ
     go_tuple _ _            = Nothing
 
     tup_name n 
-	| OccName.isTcClsName ctxt_ns = Name.getName (tupleTyCon Boxed n)
-	| otherwise 		      = Name.getName (tupleCon Boxed n)
+	| OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
+	| otherwise 		           = Name.getName (tupleCon Boxed n)
 
 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 mk_uniq_occ ns occ uniq