X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprExternalCore.lhs;h=5303b0d1b68ffed31265e510bf9547e3c116a907;hp=dd75b62629d29410f940f606931465167e469fa2;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hpb=0a9b1362c9103c17a9f662287fd65c8779bcf4ef

diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
index dd75b62..5303b0d 100644
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ b/compiler/coreSyn/PprExternalCore.lhs
@@ -5,12 +5,12 @@
 \begin{code}
 module PprExternalCore () where
 
-import ExternalCore
 import Encoding
+import ExternalCore
 
 import Pretty
-import Char
-
+import Data.Char
+import Data.Ratio
 
 instance Show Module where
   showsPrec _ m = shows (pmodule m)
@@ -54,36 +54,23 @@ ptdef (Data tcon tbinds cdefs) =
   (text "%data" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> char '=')
   $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
 
-ptdef (Newtype tcon tbinds (coercion,k) rep) =
--- Here we take apart the newtype tycon in order to get the newtype coercion,
--- which needs to be represented in the External Core file because it's not
--- straightforward to derive its definition from the newtype declaration alone.
--- At the same time, we need the newtype decl to declare the tycon itself.
--- Sigh.
-  text "%newtype" <+> pqname tcon <+> (hsep (map ptbind tbinds)) 
-    <+> axiomclause <+> repclause
-       where  axiomclause = char '^' <+> parens (pqname coercion <+> text "::"
-                                     <+> pkind k)
-              repclause   = case rep of
-                              Just ty -> char '=' <+> pty ty 
-			      Nothing -> empty
-             
+ptdef (Newtype tcon coercion tbinds rep) =
+  text "%newtype" <+> pqname tcon <+> pqname coercion 
+   <+> (hsep (map ptbind tbinds)) $$ indent repclause
+       where repclause = char '=' <+> pty rep
 
 pcdef :: Cdef -> Doc
 pcdef (Constr dcon tbinds tys)  =
-  (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
+  (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
 pcdef (GadtConstr dcon ty)  =
-  (pname dcon) <+> text "::" <+> pty ty
+  (pqname dcon) <+> text "::" <+> pty ty
 
 pname :: Id -> Doc
 pname id = text (zEncodeString id)
 
 pqname :: Qual Id -> Doc
 pqname ("",id) = pname id
--- We print out a special character before a qualified name so as to
--- disambiguate unqualified names like "m" from qualified names like
--- "m:Foo.Bar.y". This makes the ext-core parser easier.
-pqname (m,id)  = char '^' <> text m <> char '.' <> pname id
+pqname (m,id)  = text m <> char '.' <> pname id
 
 ptbind, pattbind :: Tbind -> Doc
 ptbind (t,Klifted) = pname t
@@ -108,11 +95,21 @@ paty (Tcon c) = pqname c
 paty t = parens (pty t)
 
 pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2])
-pbty (Tapp t1 t2) = pappty t1 [t2] 
+pbty (Tapp t1 t2) = parens $ pappty t1 [t2] 
 pbty t = paty t
 
 pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
 pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
+pty (TransCoercion t1 t2) =
+  sep [text "%trans", paty t1, paty t2]
+pty (SymCoercion t) =
+  sep [text "%sym", paty t]
+pty (UnsafeCoercion t1 t2) =
+  sep [text "%unsafe", paty t1, paty t2]
+pty (NthCoercion n t) =
+  sep [text "%nth", int n, paty t]
+pty (InstCoercion t1 t2) =
+  sep [text "%inst", paty t1, paty t2]
 pty t = pbty t
 
 pappty :: Ty -> [Ty] -> Doc
@@ -128,10 +125,10 @@ pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (
 pvdefg (Nonrec vdef) = pvdef vdef
 
 pvdef :: Vdef -> Doc
--- note: at one point every vdef was getting printed out as "local".
--- I think that's manifestly wrong. Right now, the "%local" keyword
--- is never used.
-pvdef (_l,v,t,e) = sep [pname v <+> text "::" <+> pty t <+> char '=',
+-- TODO: Think about whether %local annotations are actually needed.
+-- Right now, the local flag is never used, because the Core doc doesn't
+-- explain the meaning of %local.
+pvdef (_l,v,t,e) = sep [(pqname v <+> text "::" <+> pty t <+> char '='),
 		    indent (pexp e)]
 
 paexp, pfexp, pexp :: Exp -> Doc
@@ -162,7 +159,7 @@ pappexp e as = fsep (paexp e : map pa as)
 
 pexp (Lam b e) = char '\\' <+> plamexp [b] e
 pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
-pexp (Case e vb ty alts) = sep [text "%case" <+> parens (paty ty) <+> paexp e,
+pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e,
 			     text "%of" <+> pvbind vb]
 			$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
 pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paty co
@@ -190,9 +187,12 @@ palt (Adefault e) =
 
 plit :: Lit -> Doc
 plit (Lint i t) = parens (integer i <> text "::" <> pty t)
--- we use (text (show r)) because "(rational r)" was printing out things
--- like "2.0e-2" (which isn't External Core)
-plit (Lrational r t) = parens (text (show r) <>  text "::" <> pty t)
+-- we use (text (show (numerator r))) (and the same for denominator)
+-- because "(rational r)" was printing out things like "2.0e-2" (which
+-- isn't External Core), and (text (show r)) was printing out things
+-- like "((-1)/5)" which isn't either (it should be "(-1/5)").
+plit (Lrational r t) = parens (text (show (numerator r)) <+> char '%'
+   <+> text (show (denominator r)) <>  text "::" <> pty t)
 plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t)
 plit (Lstring s t) = parens (pstring s <> text "::" <> pty t)