PprExternalCore.lhs 5.05 KB
Newer Older
apt's avatar
apt committed
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2001-2006
apt's avatar
apt committed
3 4
%

Simon Marlow's avatar
Simon Marlow committed
5
\begin{code}
6
module PprExternalCore () where
apt's avatar
apt committed
7 8 9 10

import Pretty
import ExternalCore
import Char
Simon Marlow's avatar
Simon Marlow committed
11
import Encoding
apt's avatar
apt committed
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42

instance Show Module where
  showsPrec d m = shows (pmodule m)

instance Show Tdef where
  showsPrec d t = shows (ptdef t)

instance Show Cdef where
  showsPrec d c = shows (pcdef c)

instance Show Vdefg where
  showsPrec d v = shows (pvdefg v)

instance Show Exp where
  showsPrec d e = shows (pexp e)

instance Show Alt where
  showsPrec d a = shows (palt a)

instance Show Ty where
  showsPrec d t = shows (pty t)

instance Show Kind where
  showsPrec d k = shows (pkind k)

instance Show Lit where
  showsPrec d l = shows (plit l)


indent = nest 2

apt's avatar
apt committed
43
pmodule (Module mname tdefs vdefgs) =
44
  (text "%module" <+> text mname)
apt's avatar
apt committed
45
    $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
apt's avatar
apt committed
46
	       $$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
apt's avatar
apt committed
47 48

ptdef (Data tcon tbinds cdefs) =
apt's avatar
apt committed
49
  (text "%data" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> char '=')
apt's avatar
apt committed
50 51
  $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))

apt's avatar
apt committed
52
ptdef (Newtype tcon tbinds rep ) =
apt's avatar
apt committed
53
  text "%newtype" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> repclause
apt's avatar
apt committed
54 55 56
       where repclause = case rep of
                           Just ty -> char '=' <+> pty ty 
			   Nothing -> empty
apt's avatar
apt committed
57 58

pcdef (Constr dcon tbinds tys)  =
59
  (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
60 61
pcdef (GadtConstr dcon ty)  =
  (pname dcon) <+> text "::" <+> pty ty
apt's avatar
apt committed
62

Jan Rochel's avatar
Jan Rochel committed
63
pname id = text (zEncodeString id)
apt's avatar
apt committed
64 65

pqname ("",id) = pname id
66
pqname (m,id)  = text m <> char '.' <> pname id
apt's avatar
apt committed
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98

ptbind (t,Klifted) = pname t
ptbind (t,k) = parens (pname t <> text "::" <> pkind k)

pattbind (t,k) = char '@' <> ptbind (t,k)

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 k = pakind k

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 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 (Tapp t1 t2) ts = pappty t1 (t2:ts)
pappty t ts = sep (map paty (t:ts))

pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t

99 100
pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
pvdefg (Nonrec vdef) = pvdef vdef
apt's avatar
apt committed
101

102
pvdef (l,v,t,e) = sep [plocal l <+> pname v <+> text "::" <+> pty t <+> char '=',
apt's avatar
apt committed
103 104
		    indent (pexp e)]

105 106 107
plocal True  = text "%local"
plocal False = empty

apt's avatar
apt committed
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
paexp (Var x) = pqname x
paexp (Dcon x) = pqname x
paexp (Lit l) = plit l
paexp e = parens(pexp e)

plamexp bs (Lam b e) = plamexp (bs ++ [b]) e
plamexp bs e = sep [sep (map pbind bs) <+> text "->",
		    indent (pexp e)]

pbind (Tb tb) = char '@' <+> ptbind tb
pbind (Vb vb) = pvbind vb

pfexp (App e1 e2) = pappexp e1 [Left e2]
pfexp (Appt e t) = pappexp e [Right t]
pfexp e = paexp e

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)
           where pa (Left e) = paexp e
		 pa (Right t) = char '@' <+> paty t

pexp (Lam b e) = char '\\' <+> plamexp [b] e
pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
132
pexp (Case e vb ty alts) = sep [text "%case" <+> parens (paty ty) <+> paexp e,
apt's avatar
apt committed
133 134
			     text "%of" <+> pvbind vb]
			$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
135
pexp (Cast e co) = (text "%cast" <+> pexp e) $$ paty co
apt's avatar
apt committed
136
pexp (Note s e) = (text "%note" <+> pstring s) $$ pexp e
137 138 139
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)
apt's avatar
apt committed
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
pexp e = pfexp e


pvbind (x,t) = parens(pname x <> text "::" <> pty t)

palt (Acon c tbs vbs e) =
	sep [pqname c, 
	     sep (map pattbind tbs),
	     sep (map pvbind vbs) <+> text "->"]
        $$ indent (pexp e)
palt (Alit l e) = 
	(plit l <+>  text "->")
	$$ indent (pexp e)
palt (Adefault e) = 
	(text "%_ ->")
	$$ indent (pexp e)

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
plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t)
plit (Lstring s t) = parens (pstring s <> text "::" <> pty t)

pstring s = doubleQuotes(text (escape s))

escape s = foldr f [] (map ord s)
    where 
166 167 168
     f cv rest
	| cv > 0xFF = '\\':'x':hs ++ rest
	| (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) = 
apt's avatar
apt committed
169 170 171 172
	 '\\':'x':h1:h0:rest
           where (q1,r1) = quotRem cv 16
		 h1 = intToDigit q1
                 h0 = intToDigit r1
173 174 175 176
		 hs = dropWhile (=='0') $ reverse $ mkHex cv
		 mkHex 0 = ""
		 mkHex cv = intToDigit r : mkHex q
		    where (q,r) = quotRem cv 16
apt's avatar
apt committed
177 178 179 180 181 182 183
     f cv rest = (chr cv):rest

\end{code}