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}