Another round of External Core fixes

[ghc-hetmet.git] / compiler / coreSyn / PprExternalCore.lhs

diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
index 6808144..e46a871 100644 (file)
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ b/compiler/coreSyn/PprExternalCore.lhs
@@ -5,11 +5,13 @@
 \begin{code}
 module PprExternalCore () where
 
-import Pretty
 import ExternalCore
-import Char
 import Encoding
 
+import Pretty
+import Char
+
+
 instance Show Module where
   showsPrec _ m = shows (pmodule m)
 
@@ -52,24 +54,38 @@ 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 rep ) =
-  text "%newtype" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> repclause
-       where repclause = case rep of
-                           Just ty -> char '=' <+> pty ty 
-                          Nothing -> empty
+ptdef (Newtype tcon tbinds (coercion,tbs,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)) 
+    $$ indent (axiomclause $$ repclause)
+       where  axiomclause = char '^' 
+                 <+> parens (pqname coercion <+> (hsep (map ptbind tbs))
+                              <+> text "::"
+                              <+> pkind k)
+              repclause   = case rep of
+                              Just ty -> char '=' <+> pty ty 
+                             Nothing -> empty
+             
 
 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
-pqname (m,id)  = text m <> char '.' <> 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
 
 ptbind, pattbind :: Tbind -> Doc
 ptbind (t,Klifted) = pname t
@@ -84,7 +100,8 @@ pakind (Kopen) = char '?'
 pakind k = parens (pkind k)
 
 pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2)
-pkind (Keq t1 t2) = parens (pty t1 <> text ":=:" <> pty t2)
+pkind (Keq t1 t2) = parens (parens (pty t1) <+> text ":=:" <+> 
+                            parens (pty t2))
 pkind k = pakind k
 
 paty, pbty, pty :: Ty -> Doc
@@ -113,13 +130,12 @@ pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (
 pvdefg (Nonrec vdef) = pvdef vdef
 
 pvdef :: Vdef -> Doc
-pvdef (l,v,t,e) = sep [plocal l <+> 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)]
 
-plocal :: Bool -> Doc
-plocal True  = text "%local"
-plocal False = empty
-
 paexp, pfexp, pexp :: Exp -> Doc
 paexp (Var x) = pqname x
 paexp (Dcon x) = pqname x
@@ -148,7 +164,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
@@ -176,7 +192,9 @@ palt (Adefault e) =
 
 plit :: Lit -> Doc
 plit (Lint i t) = parens (integer i <> text "::" <> pty t)
-plit (Lrational r t) = parens (rational r <>  text "::" <> pty t)  -- might be better to print as two integers
+-- 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)
 plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t)
 plit (Lstring s t) = parens (pstring s <> text "::" <> pty t)