\begin{code}
module PprExternalCore () where
-import ExternalCore
import Encoding
+import ExternalCore
import Pretty
import Char
-
instance Show Module where
showsPrec _ m = shows (pmodule m)
(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))
- $$ indent (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
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 (LeftCoercion t) =
+ sep [text "%left", paty t]
+pty (RightCoercion t) =
+ sep [text "%right", paty t]
+pty (InstCoercion t1 t2) =
+ sep [text "%inst", paty t1, paty t2]
pty t = pbty t
pappty :: Ty -> [Ty] -> Doc
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
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