\begin{code}
module PprExternalCore () where
-import Pretty
-import ExternalCore
-import Char
import Encoding
+import ExternalCore
+
+import Pretty
+import Data.Char
+import Data.Ratio
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 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 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)
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
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
-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
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
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 (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)