PprExternalCore.lhs 4.94 KB
Newer Older
apt's avatar
apt committed
1
2
3
4
5
%
% (c) The University of Glasgow 2001
%
\begin{code}

6
module PprExternalCore () where
apt's avatar
apt committed
7
8
9
10

import Pretty
import ExternalCore
import Char
Jan Rochel's avatar
Jan Rochel committed
11
import Encoding ( zEncodeString )
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
apt's avatar
apt committed
137
pexp (External n t) = (text "%external" <+> pstring n) $$ paty t
apt's avatar
apt committed
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
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 
164
165
166
     f cv rest
	| cv > 0xFF = '\\':'x':hs ++ rest
	| (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) = 
apt's avatar
apt committed
167
168
169
170
	 '\\':'x':h1:h0:rest
           where (q1,r1) = quotRem cv 16
		 h1 = intToDigit q1
                 h0 = intToDigit r1
171
172
173
174
		 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
175
176
177
178
179
180
181
     f cv rest = (chr cv):rest

\end{code}