X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=53d16be95590c286c0e0f075110dd43a5e0b63d0;hb=cccb9a1aead5d225caee75b2c4669de94ce0cc57;hp=3a240733fcf05e27834064ffccc2537a1f9d2694;hpb=8f7ac3fe40d3d55743b824deab655d0797a1c55f;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 3a24073..53d16be 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -11,27 +11,23 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
 @TyVars@ as well.  Currently trying the former... MEGA SIGH.
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsCore (
 	UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
 	UfDefault(..), UfBinding(..),
 	UfArg(..), UfPrimOp(..)
     ) where
 
-IMP_Ubiq()
+#include "HsVersions.h"
 
 -- friends:
 import HsTypes		( HsType, pprParendHsType )
-import PrimOp		( PrimOp, tagOf_PrimOp )
 import Kind		( Kind {- instance Outputable -} )
-import Type		( GenType {- instance Outputable -} )
 
 -- others:
 import Literal		( Literal )
-import Outputable	( Outputable(..) )
-import Pretty
 import Util		( panic )
+import CostCentre
+import Outputable
 \end{code}
 
 %************************************************************************
@@ -66,15 +62,14 @@ data UfPrimOp name
 data UfCoercion name = UfIn name | UfOut name
 
 data UfAlts name
-  = UfAlgAlts  [(name, [UfBinder name], UfExpr name)]
+  = UfAlgAlts  [(name, [name], UfExpr name)]
 		(UfDefault name)
   | UfPrimAlts [(Literal, UfExpr name)]
 		(UfDefault name)
 
 data UfDefault name
   = UfNoDefault
-  | UfBindDefault (UfBinder name)
-		  (UfExpr name)
+  | UfBindDefault name (UfExpr name)
 
 data UfBinding name
   = UfNonRec	(UfBinder name)
@@ -84,13 +79,11 @@ data UfBinding name
 data UfBinder name
   = UfValBinder	name (HsType name)
   | UfTyBinder	name Kind
-  | UfUsageBinder name
 
 data UfArg name
   = UfVarArg	name
   | UfLitArg	Literal
   | UfTyArg	(HsType name)
-  | UfUsageArg	name
 \end{code}
 
 %************************************************************************
@@ -101,72 +94,72 @@ data UfArg name
 
 \begin{code}
 instance Outputable name => Outputable (UfExpr name) where
-    ppr sty (UfVar v) = ppr sty v
-    ppr sty (UfLit l) = ppr sty l
+    ppr (UfVar v) = ppr v
+    ppr (UfLit l) = ppr l
 
-    ppr sty (UfCon c as)
-      = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"]
-    ppr sty (UfPrim o as)
-      = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"]
+    ppr (UfCon c as)
+      = hsep [text "UfCon", ppr c, ppr as, char ')']
+    ppr (UfPrim o as)
+      = hsep [text "UfPrim", ppr o, ppr as, char ')']
 
-    ppr sty (UfLam b body)
-      = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body]
+    ppr (UfLam b body)
+      = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
 
-    ppr sty (UfApp fun (UfTyArg ty))
-      = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty]
+    ppr (UfApp fun (UfTyArg ty))
+      = hsep [ppr fun, char '@', pprParendHsType ty]
 
-    ppr sty (UfApp fun (UfLitArg lit))
-      = ppCat [ppr sty fun, ppr sty lit]
+    ppr (UfApp fun (UfLitArg lit))
+      = hsep [ppr fun, ppr lit]
 
-    ppr sty (UfApp fun (UfVarArg var))
-      = ppCat [ppr sty fun, ppr sty var]
+    ppr (UfApp fun (UfVarArg var))
+      = hsep [ppr fun, ppr var]
 
-    ppr sty (UfCase scrut alts)
-      = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
+    ppr (UfCase scrut alts)
+      = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
       where
     	pp_alts (UfAlgAlts alts deflt)
-	  = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
+	  = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
 	  where
-	   pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
+	   pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
     	pp_alts (UfPrimAlts alts deflt)
-	  = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
+	  = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
 	  where
-	   pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
+	   pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
+
+	pp_deflt UfNoDefault = empty
+	pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
 
-	pp_deflt UfNoDefault = ppNil
-	pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
+        ppr_arrow = ptext SLIT("->")
 
-    ppr sty (UfLet (UfNonRec b rhs) body)
-      = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
-    ppr sty (UfLet (UfRec pairs) body)
-      = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
+    ppr (UfLet (UfNonRec b rhs) body)
+      = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
+    ppr (UfLet (UfRec pairs) body)
+      = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
       where
-	pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
+	pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
 
-    ppr sty (UfSCC uf_cc body)
-      = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
+    ppr (UfSCC uf_cc body)
+      = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr body]
 
 instance Outputable name => Outputable (UfPrimOp name) where
-    ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
+    ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
       = let
-	    before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
-	    after  = if is_casm then ppStr "'' " else ppSP
+	    before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
+	    after  = if is_casm then text "'' " else space
 	in
-	ppBesides [before, ppPStr str, after,
-		   ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+	hcat [before, ptext str, after,
+		   brackets (ppr arg_tys), space, ppr result_ty]
 
-    ppr sty (UfOtherOp op)
-      = ppr sty op
+    ppr (UfOtherOp op)
+      = ppr op
 
 instance Outputable name => Outputable (UfArg name) where
-    ppr sty (UfVarArg v)	= ppr sty v
-    ppr sty (UfLitArg l)	= ppr sty l
-    ppr sty (UfTyArg ty)	= pprParendHsType sty ty
-    ppr sty (UfUsageArg name)	= ppr sty name
+    ppr (UfVarArg v)	= ppr v
+    ppr (UfLitArg l)	= ppr l
+    ppr (UfTyArg ty)	= pprParendHsType ty
 
 instance Outputable name => Outputable (UfBinder name) where
-    ppr sty (UfValBinder name ty)  = ppCat [ppr sty name, ppStr "::", ppr sty ty]
-    ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind]
-    ppr sty (UfUsageBinder name)   = ppr sty name
+    ppr (UfValBinder name ty)  = hsep [ppr name, ptext SLIT("::"), ppr ty]
+    ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
 \end{code}