X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprExternalCore.lhs;h=c34f7b842a45140ab8df52fd97e657b0dfdfbc4c;hp=26c89cce486982a791e87272cfc1fa634ee8fd7f;hb=e4417dcd4679da9c6b18c02ff667199c572bed89;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1

diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
index 26c89cc..c34f7b8 100644
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ b/compiler/coreSyn/PprExternalCore.lhs
@@ -1,115 +1,141 @@
 %
-% (c) The University of Glasgow 2001
+% (c) The University of Glasgow 2001-2006
 %
-\begin{code}
 
+\begin{code}
 module PprExternalCore () where
 
-import Pretty
 import ExternalCore
+import Encoding
+
+import Pretty
 import Char
 
+
 instance Show Module where
-  showsPrec d m = shows (pmodule m)
+  showsPrec _ m = shows (pmodule m)
 
 instance Show Tdef where
-  showsPrec d t = shows (ptdef t)
+  showsPrec _ t = shows (ptdef t)
 
 instance Show Cdef where
-  showsPrec d c = shows (pcdef c)
+  showsPrec _ c = shows (pcdef c)
 
 instance Show Vdefg where
-  showsPrec d v = shows (pvdefg v)
+  showsPrec _ v = shows (pvdefg v)
 
 instance Show Exp where
-  showsPrec d e = shows (pexp e)
+  showsPrec _ e = shows (pexp e)
 
 instance Show Alt where
-  showsPrec d a = shows (palt a)
+  showsPrec _ a = shows (palt a)
 
 instance Show Ty where
-  showsPrec d t = shows (pty t)
+  showsPrec _ t = shows (pty t)
 
 instance Show Kind where
-  showsPrec d k = shows (pkind k)
+  showsPrec _ k = shows (pkind k)
 
 instance Show Lit where
-  showsPrec d l = shows (plit l)
+  showsPrec _ l = shows (plit l)
 
 
+indent :: Doc -> Doc
 indent = nest 2
 
+pmodule :: Module -> Doc
 pmodule (Module mname tdefs vdefgs) =
   (text "%module" <+> text mname)
     $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
 	       $$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
 
+ptdef :: Tdef -> Doc
 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
+ptdef (Newtype tcon coercion tbinds rep) =
+  text "%newtype" <+> pqname tcon <+> pqname coercion 
+   <+> (hsep (map ptbind tbinds)) $$ indent repclause
        where 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 = text id
+pname :: Id -> Doc
+pname id = text (zEncodeString id)
 
+pqname :: Qual Id -> Doc
 pqname ("",id) = pname id
-pqname (m,id)  = pname m <> char '.' <> pname id
+pqname (m,id)  = text m <> char '.' <> pname id
 
+ptbind, pattbind :: Tbind -> Doc
 ptbind (t,Klifted) = pname t
 ptbind (t,k) = parens (pname t <> text "::" <> pkind k)
 
 pattbind (t,k) = char '@' <> ptbind (t,k)
 
+pakind, pkind :: Kind -> Doc
 pakind (Klifted) = char '*'
 pakind (Kunlifted) = char '#'
 pakind (Kopen) = char '?'
 pakind k = parens (pkind k)
 
 pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2)
+pkind (Keq t1 t2) = parens (parens (pty t1) <+> text ":=:" <+> 
+                            parens (pty t2))
 pkind k = pakind k
 
+paty, pbty, pty :: Ty -> Doc
 paty (Tvar n) = pname n
 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 t = pbty t
 
+pappty :: Ty -> [Ty] -> Doc
 pappty (Tapp t1 t2) ts = pappty t1 (t2:ts)
 pappty t ts = sep (map paty (t:ts))
 
+pforall :: [Tbind] -> Ty -> Doc
 pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
 pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
 
-pvdefg (Rec vtes) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvte vtes))))
-pvdefg (Nonrec vte) = pvte vte
+pvdefg :: Vdefg -> Doc
+pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
+pvdefg (Nonrec vdef) = pvdef vdef
 
-pvte (v,t,e) = sep [pname v <+> text "::" <+> pty t <+> char '=',
+pvdef :: Vdef -> Doc
+-- 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
 paexp (Var x) = pqname x
 paexp (Dcon x) = pqname x
 paexp (Lit l) = plit l
 paexp e = parens(pexp e)
 
+plamexp :: [Bind] -> Exp -> Doc
 plamexp bs (Lam b e) = plamexp (bs ++ [b]) e
 plamexp bs e = sep [sep (map pbind bs) <+> text "->",
 		    indent (pexp e)]
 
+pbind :: Bind -> Doc
 pbind (Tb tb) = char '@' <+> ptbind tb
 pbind (Vb vb) = pvbind vb
 
@@ -117,6 +143,7 @@ pfexp (App e1 e2) = pappexp e1 [Left e2]
 pfexp (Appt e t) = pappexp e [Right t]
 pfexp e = paexp e
 
+pappexp :: Exp -> [Either Exp Ty] -> Doc
 pappexp (App e1 e2) as = pappexp e1 (Left e2:as)
 pappexp (Appt e t) as = pappexp e (Right t:as)
 pappexp e as = fsep (paexp e : map pa as)
@@ -125,17 +152,20 @@ 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 (Coerce t e) = (text "%coerce" <+> paty t) $$ pexp e
+pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paty co
 pexp (Note s e) = (text "%note" <+> pstring s) $$ pexp e
-pexp (External n t) = (text "%external" <+> pstring n) $$ paty t
+pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t
+pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t
+pexp (Label n) = (text "%label" <+> pstring n)
 pexp e = pfexp e
 
-
+pvbind :: Vbind -> Doc
 pvbind (x,t) = parens(pname x <> text "::" <> pty t)
 
+palt :: Alt -> Doc
 palt (Acon c tbs vbs e) =
 	sep [pqname c, 
 	     sep (map pattbind tbs),
@@ -148,13 +178,18 @@ palt (Adefault e) =
 	(text "%_ ->")
 	$$ indent (pexp 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)
 
+pstring :: String -> Doc
 pstring s = doubleQuotes(text (escape s))
 
+escape :: String -> String
 escape s = foldr f [] (map ord s)
     where 
      f cv rest