tyops
[ghc.git] / compiler / coreSyn / PprExternalCore.lhs
1 %
2 % (c) The University of Glasgow 2001-2006
3 %
4
5 \begin{code}
6 {-# OPTIONS -fno-warn-tabs #-}
7 -- The above warning supression flag is a temporary kludge.
8 -- While working on this module you are encouraged to remove it and
9 -- detab the module (please do the detabbing in a separate patch). See
10 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
11 -- for details
12
13 module PprExternalCore () where
14
15 import Encoding
16 import ExternalCore
17
18 import Pretty
19 import Data.Char
20 import Data.Ratio
21
22 instance Show Module where
23   showsPrec _ m = shows (pmodule m)
24
25 instance Show Tdef where
26   showsPrec _ t = shows (ptdef t)
27
28 instance Show Cdef where
29   showsPrec _ c = shows (pcdef c)
30
31 instance Show Vdefg where
32   showsPrec _ v = shows (pvdefg v)
33
34 instance Show Exp where
35   showsPrec _ e = shows (pexp e)
36
37 instance Show Alt where
38   showsPrec _ a = shows (palt a)
39
40 instance Show Ty where
41   showsPrec _ t = shows (pty t)
42
43 instance Show Kind where
44   showsPrec _ k = shows (pkind k)
45
46 instance Show Lit where
47   showsPrec _ l = shows (plit l)
48
49
50 indent :: Doc -> Doc
51 indent = nest 2
52
53 pmodule :: Module -> Doc
54 pmodule (Module mname tdefs vdefgs) =
55   (text "%module" <+> text mname)
56     $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
57                $$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
58
59 ptdef :: Tdef -> Doc
60 ptdef (Data tcon tbinds cdefs) =
61   (text "%data" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> char '=')
62   $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
63
64 ptdef (Newtype tcon coercion tbinds rep) =
65   text "%newtype" <+> pqname tcon <+> pqname coercion 
66    <+> (hsep (map ptbind tbinds)) $$ indent repclause
67        where repclause = char '=' <+> pty rep
68
69 pcdef :: Cdef -> Doc
70 pcdef (Constr dcon tbinds tys)  =
71   (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
72 pcdef (GadtConstr dcon ty)  =
73   (pqname dcon) <+> text "::" <+> pty ty
74
75 pname :: Id -> Doc
76 pname id = text (zEncodeString id)
77
78 pqname :: Qual Id -> Doc
79 pqname ("",id) = pname id
80 pqname (m,id)  = text m <> char '.' <> pname id
81
82 ptbind, pattbind :: Tbind -> Doc
83 ptbind (t,Klifted) = pname t
84 ptbind (t,k) = parens (pname t <> text "::" <> pkind k)
85
86 pattbind (t,k) = char '@' <> ptbind (t,k)
87
88 pakind, pkind :: Kind -> Doc
89 pakind (Klifted) = char '*'
90 pakind (Kunlifted) = char '#'
91 pakind (Kopen) = char '?'
92 pakind k = parens (pkind k)
93
94 pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2)
95 pkind k = pakind k
96
97 paty, pbty, pty :: Ty -> Doc
98 paty (Tvar n) = pname n
99 paty (Tcon c) = pqname c
100 paty t = parens (pty t)
101
102 pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2])
103 pbty (Tapp t1 t2) = parens $ pappty t1 [t2] 
104 pbty t = paty t
105
106 pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
107 pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
108 pty (TransCoercion t1 t2) =
109   sep [text "%trans", paty t1, paty t2]
110 pty (SymCoercion t) =
111   sep [text "%sym", paty t]
112 pty (UnsafeCoercion t1 t2) =
113   sep [text "%unsafe", paty t1, paty t2]
114 pty (NthCoercion n t) =
115   sep [text "%nth", int n, paty t]
116 pty (InstCoercion t1 t2) =
117   sep [text "%inst", paty t1, paty t2]
118 pty t = pbty t
119
120 pappty :: Ty -> [Ty] -> Doc
121 pappty (Tapp t1 t2) ts = pappty t1 (t2:ts)
122 pappty t ts = sep (map paty (t:ts))
123
124 pforall :: [Tbind] -> Ty -> Doc
125 pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
126 pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
127
128 pvdefg :: Vdefg -> Doc
129 pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
130 pvdefg (Nonrec vdef) = pvdef vdef
131
132 pvdef :: Vdef -> Doc
133 -- TODO: Think about whether %local annotations are actually needed.
134 -- Right now, the local flag is never used, because the Core doc doesn't
135 -- explain the meaning of %local.
136 pvdef (_l,v,t,e) = sep [(pqname v <+> text "::" <+> pty t <+> char '='),
137                     indent (pexp e)]
138
139 paexp, pfexp, pexp :: Exp -> Doc
140 paexp (Var x) = pqname x
141 paexp (Dcon x) = pqname x
142 paexp (Lit l) = plit l
143 paexp e = parens(pexp e)
144
145 plamexp :: [Bind] -> Exp -> Doc
146 plamexp bs (Lam b e) = plamexp (bs ++ [b]) e
147 plamexp bs e = sep [sep (map pbind bs) <+> text "->",
148                     indent (pexp e)]
149
150 pbind :: Bind -> Doc
151 pbind (Tb tb) = char '@' <+> ptbind tb
152 pbind (Vb vb) = pvbind vb
153
154 pfexp (App e1 e2) = pappexp e1 [Left e2]
155 pfexp (Appt e t) = pappexp e [Right t]
156 pfexp e = paexp e
157
158 pappexp :: Exp -> [Either Exp Ty] -> Doc
159 pappexp (App e1 e2) as = pappexp e1 (Left e2:as)
160 pappexp (Appt e t) as = pappexp e (Right t:as)
161 pappexp e as = fsep (paexp e : map pa as)
162            where pa (Left e) = paexp e
163                  pa (Right t) = char '@' <+> paty t
164
165 pexp (Lam b e) = char '\\' <+> plamexp [b] e
166 pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
167 pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e,
168                              text "%of" <+> pvbind vb]
169                         $$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
170 pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paty co
171 pexp (Tick s e) = (text "%source" <+> pstring s) $$ pexp e
172 pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t
173 pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t
174 pexp (Label n) = (text "%label" <+> pstring n)
175 pexp e = pfexp e
176
177 pvbind :: Vbind -> Doc
178 pvbind (x,t) = parens(pname x <> text "::" <> pty t)
179
180 palt :: Alt -> Doc
181 palt (Acon c tbs vbs e) =
182         sep [pqname c, 
183              sep (map pattbind tbs),
184              sep (map pvbind vbs) <+> text "->"]
185         $$ indent (pexp e)
186 palt (Alit l e) = 
187         (plit l <+>  text "->")
188         $$ indent (pexp e)
189 palt (Adefault e) = 
190         (text "%_ ->")
191         $$ indent (pexp e)
192
193 plit :: Lit -> Doc
194 plit (Lint i t) = parens (integer i <> text "::" <> pty t)
195 -- we use (text (show (numerator r))) (and the same for denominator)
196 -- because "(rational r)" was printing out things like "2.0e-2" (which
197 -- isn't External Core), and (text (show r)) was printing out things
198 -- like "((-1)/5)" which isn't either (it should be "(-1/5)").
199 plit (Lrational r t) = parens (text (show (numerator r)) <+> char '%'
200    <+> text (show (denominator r)) <>  text "::" <> pty t)
201 plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t)
202 plit (Lstring s t) = parens (pstring s <> text "::" <> pty t)
203
204 pstring :: String -> Doc
205 pstring s = doubleQuotes(text (escape s))
206
207 escape :: String -> String
208 escape s = foldr f [] (map ord s)
209     where 
210      f cv rest
211         | cv > 0xFF = '\\':'x':hs ++ rest
212         | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) = 
213          '\\':'x':h1:h0:rest
214            where (q1,r1) = quotRem cv 16
215                  h1 = intToDigit q1
216                  h0 = intToDigit r1
217                  hs = dropWhile (=='0') $ reverse $ mkHex cv
218                  mkHex 0 = ""
219                  mkHex cv = intToDigit r : mkHex q
220                     where (q,r) = quotRem cv 16
221      f cv rest = (chr cv):rest
222
223 \end{code}
224
225
226
227