X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=57945cbc10f166a6f128b8c84f7dd115c21189b1;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=2aff67f223293ed973012b21c8b97160b4da877a;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 2aff67f..57945cb 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -17,25 +17,25 @@ module PprCore (
 	pprTypedCoreBinder
 	
 	-- these are here to make the instances go in 0.26:
-#if __GLASGOW_HASKELL__ <= 26
+#if __GLASGOW_HASKELL__ <= 30
 	, GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
 	, GenCoreCaseDefault, GenCoreArg
 #endif
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import CoreSyn
 import CostCentre	( showCostCentre )
 import Id		( idType, getIdInfo, getIdStrictness, isTupleCon,
-			  nullIdEnv, DataCon(..), GenId{-instances-}
+			  nullIdEnv, SYN_IE(DataCon), GenId{-instances-}
 			)
 import IdInfo		( ppIdInfo, StrictnessInfo(..) )
 import Literal		( Literal{-instances-} )
 import Name		( isSymLexeme )
 import Outputable	-- quite a few things
 import PprEnv
-import PprType		( GenType{-instances-}, GenTyVar{-instance-} )
+import PprType		( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} )
 import PprStyle		( PprStyle(..) )
 import Pretty
 import PrimOp		( PrimOp{-instances-} )
@@ -91,7 +91,7 @@ init_ppr_env sty pbdr1 pbdr2 pocc
 	(Just (ppr sty)) -- tyvars
 	(Just (ppr sty)) -- usage vars
 	(Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
-	(Just (ppr sty)) -- types
+	(Just (pprParendGenType sty)) -- types
 	(Just (ppr sty)) -- usages
 
 --------------
@@ -265,6 +265,28 @@ ppr_expr pe expr@(App _ _)
 	          ])
 
 ppr_expr pe (Case expr alts)
+  | only_one_alt alts
+    -- johan thinks that single case patterns should be on same line as case,
+    -- and no indent; all sane persons agree with him.
+  = let
+	ppr_alt (AlgAlts  [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
+	ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
+	ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l)	   (ppStr " ->")
+	ppr_alt (AlgAlts  ((con, params, _):[]) NoDefault)
+	  = ppCat [ppr_alt_con con (pCon pe con),
+		   ppInterleave ppSP (map (pMinBndr pe) params),
+		   ppStr "->"]
+
+	ppr_rhs (AlgAlts [] (BindDefault _ expr))   = ppr_expr pe expr
+	ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
+	ppr_rhs (PrimAlts [] (BindDefault _ expr))  = ppr_expr pe expr
+	ppr_rhs (PrimAlts ((_,expr):[]) NoDefault)  = ppr_expr pe expr
+    in 
+    ppSep
+    [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
+	 ppBeside (ppr_rhs alts) (ppStr "}")]
+
+  | otherwise -- default "case" printing
   = ppSep
     [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
      ppNest 2 (ppr_alts pe alts),
@@ -296,6 +318,22 @@ ppr_expr pe (Let bind expr)
 ppr_expr pe (SCC cc expr)
   = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
 	   ppr_parend_expr pe expr ]
+
+ppr_expr pe (Coerce c ty expr)
+  = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c],
+	   pTy pe ty, ppr_parend_expr pe expr ]
+  where
+    pp_coerce (CoerceIn  v) = ppBeside (ppStr "{-in-}")  (ppr (pStyle pe) v)
+    pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
+
+only_one_alt (AlgAlts []     (BindDefault _ _)) = True
+only_one_alt (AlgAlts (_:[])  NoDefault) 	= True
+only_one_alt (PrimAlts []    (BindDefault _ _)) = True
+only_one_alt (PrimAlts (_:[]) NoDefault) 	= True
+only_one_alt _					= False 
+
+ppr_alt_con con pp_con
+  = if isSymLexeme con then ppParens pp_con else pp_con
 \end{code}
 
 \begin{code}
@@ -307,14 +345,11 @@ ppr_alts pe (AlgAlts alts deflt)
 		    ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
 			   ppStr "->"]
 		else
-		    ppCat [ppr_con con (pCon pe con),
+		    ppCat [ppr_alt_con con (pCon pe con),
 			   ppInterleave ppSP (map (pMinBndr pe) params),
 			   ppStr "->"]
 	       )
 	     4 (ppr_expr pe expr)
-      where
-    	ppr_con con pp_con
-    	  = if isSymLexeme con then ppParens pp_con else pp_con
 
 ppr_alts pe (PrimAlts alts deflt)
   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
@@ -352,7 +387,7 @@ pprBigCoreBinder sty binder
 
     pragmas =
 	ifnotPprForUser sty
-	 (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
+	 (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv
 	  (getIdInfo binder))
 
 pprBabyCoreBinder sty binder