X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=3a84239d4a7e83179228cc8ea9c05ea5654fd8de;hp=b5a185ca86108b6739702b368aa4dfdc2fc320cf;hb=3391a03562d4056de7b16cd0f632e6c43ae44cca;hpb=110bf0e93196b88606503a06552c95d2014e6267

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index b5a185c..3a84239 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -268,6 +268,7 @@ cvt_tyinst_hdr cxt tc tys
     collect (VarT tv)    = return [PlainTV tv]
     collect (ConT _)     = return []
     collect (TupleT _)   = return []
+    collect (UnboxedTupleT _) = return []
     collect ArrowT       = return []
     collect ListT        = return []
     collect (AppT t1 t2)
@@ -464,8 +465,10 @@ cvtl e = wrapL (cvt e)
 			    ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
     cvt (TupE [e])     = cvt e	-- Singleton tuples treated like nothing (just parens)
     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
-    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
-			    ; return $ HsIf x' y' z' }
+    cvt (UnboxedTupE [e])     = cvt e	-- Singleton tuples treated like nothing (just parens)
+    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
+			    ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
                             ; e' <- cvtl e; return $ HsLet ds' e' }
     cvt (CaseE e ms)   
@@ -519,12 +522,15 @@ cvtHsDo do_or_lc stmts
   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
   | otherwise
   = do	{ stmts' <- cvtStmts stmts
-	; body <- case last stmts' of
-		    L _ (ExprStmt body _ _) -> return body
-                    stmt' -> failWith (bad_last stmt')
-	; return $ HsDo do_or_lc (init stmts') body void }
+        ; let Just (stmts'', last') = snocView stmts'
+        
+	; last'' <- case last' of
+		      L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
+                      _ -> failWith (bad_last last')
+
+	; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
   where
-    bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
+    bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
                          , nest 2 $ Outputable.ppr stmt
 			 , ptext (sLit "(It should be an expression.)") ]
 		
@@ -536,7 +542,7 @@ cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
                             ; returnL $ LetStmt ds' }
-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr }
 		       where
 			 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 
@@ -562,7 +568,7 @@ cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)  
   = do { force i; return $ mkHsIntegral i placeHolderType}
 cvtOverLit (RationalL r) 
-  = do { force r; return $ mkHsFractional r placeHolderType}
+  = do { force r; return $ mkHsFractional (FL { fl_text = show (fromRational r :: Double), fl_value = r }) placeHolderType}
 cvtOverLit (StringL s)   
   = do { let { s' = mkFastString s }
        ; force s'
@@ -626,6 +632,8 @@ cvtp (TH.LitP l)
 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 cvtp (TupP [p])       = cvtp p
 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
+cvtp (UnboxedTupP [p]) = cvtp p
+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
 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
 			   ; return $ ConPatIn s' (InfixCon p1' p2') }
@@ -697,6 +705,15 @@ cvtType ty
              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
              | otherwise 
              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
+           UnboxedTupleT n
+             | length tys' == n 	-- Saturated
+             -> if n==1 then return (head tys')	-- Singleton tuples treated
+                                                -- like nothing (ie just parens)
+                        else returnL (HsTupleTy Unboxed tys')
+             | n == 1
+             -> failWith (ptext (sLit "Illegal 1-unboxed-tuple type constructor"))
+             | otherwise
+             -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
            ArrowT 
              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'