-
Notifications
You must be signed in to change notification settings - Fork 0
/
Printmyjs.hs
236 lines (174 loc) · 8.77 KB
/
Printmyjs.hs
1
2
3
4
5
6
7
8
9
10
11
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module Printmyjs where
-- pretty-printer generated by the BNF converter
import Absmyjs
import Data.Char
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "," :ts -> showString t . space "," . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t :ts -> space t . rend i ts
_ -> id
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
space t = showString t . (\s -> if null s then "" else (' ':s))
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
prtList :: [a] -> Doc
prtList = concatD . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Integer where
prt _ x = doc (shows x)
instance Print Double where
prt _ x = doc (shows x)
instance Print Ident where
prt _ (Ident i) = doc (showString ( i))
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Program where
prt i e = case e of
Progr stmts -> prPrec i 0 (concatD [prt 0 stmts])
instance Print MaybeIdent where
prt i e = case e of
NoIdent -> prPrec i 0 (concatD [])
JustIdent id -> prPrec i 0 (concatD [prt 0 id])
instance Print Decl where
prt i e = case e of
VarDecl id -> prPrec i 0 (concatD [doc (showString "var") , prt 0 id , doc (showString ";")])
VarDeclAssign id expr -> prPrec i 0 (concatD [doc (showString "var") , prt 0 id , doc (showString "=") , prt 0 expr , doc (showString ";")])
FunDecl funexpr -> prPrec i 0 (concatD [prt 0 funexpr])
instance Print CompoundStmt where
prt i e = case e of
CS stmts -> prPrec i 0 (concatD [doc (showString "{") , prt 0 stmts , doc (showString "}")])
instance Print Stmt where
prt i e = case e of
CSS compoundstmt -> prPrec i 0 (concatD [prt 0 compoundstmt])
ExprStmt expr -> prPrec i 0 (concatD [prt 0 expr , doc (showString ";")])
DeclStmt decl -> prPrec i 0 (concatD [prt 0 decl])
EmptyStmt -> prPrec i 0 (concatD [doc (showString ";")])
IfStmt expr stmt elseclause -> prPrec i 0 (concatD [doc (showString "if") , doc (showString "(") , prt 0 expr , doc (showString ")") , prt 0 stmt , prt 0 elseclause])
WhileStmt expr stmt -> prPrec i 0 (concatD [doc (showString "while") , doc (showString "(") , prt 0 expr , doc (showString ")") , prt 0 stmt])
ThrowStmt expr -> prPrec i 0 (concatD [doc (showString "throw") , prt 0 expr])
TryCatchStmt compoundstmt0 id compoundstmt -> prPrec i 0 (concatD [doc (showString "try") , prt 0 compoundstmt0 , doc (showString "catch") , doc (showString "(") , prt 0 id , doc (showString ")") , prt 0 compoundstmt])
ReturnStmt expr -> prPrec i 0 (concatD [doc (showString "return") , prt 0 expr , doc (showString ";")])
EmptyReturnStmt -> prPrec i 0 (concatD [doc (showString "return;")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Lvalue where
prt i e = case e of
QIdent qidentparts -> prPrec i 0 (concatD [prt 0 qidentparts])
instance Print QIdentPart where
prt i e = case e of
IdentPart iident -> prPrec i 0 (concatD [prt 0 iident])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ".") , prt 0 xs])
instance Print IIdent where
prt i e = case e of
IIdentBare id -> prPrec i 0 (concatD [prt 0 id])
IIdentIndexed id expr -> prPrec i 0 (concatD [prt 0 id , doc (showString "[") , prt 0 expr , doc (showString "]")])
instance Print ParamNames where
prt i e = case e of
ParamNameList ids -> prPrec i 0 (concatD [doc (showString "(") , prt 0 ids , doc (showString ")")])
instance Print Params where
prt i e = case e of
ParamList params -> prPrec i 0 (concatD [doc (showString "(") , prt 0 params , doc (showString ")")])
instance Print Param where
prt i e = case e of
ParamExpr expr -> prPrec i 0 (concatD [prt 0 expr])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print KeyValuePair where
prt i e = case e of
KVP key expr -> prPrec i 0 (concatD [prt 0 key , doc (showString ":") , prt 0 expr])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Key where
prt i e = case e of
KeyIdent id -> prPrec i 0 (concatD [prt 0 id])
KeyString str -> prPrec i 0 (concatD [prt 0 str])
instance Print Literal where
prt i e = case e of
IntLiteral n -> prPrec i 0 (concatD [prt 0 n])
StringLiteral str -> prPrec i 0 (concatD [prt 0 str])
TrueLiteral -> prPrec i 0 (concatD [doc (showString "true")])
FalseLiteral -> prPrec i 0 (concatD [doc (showString "false")])
UndefinedLiteral -> prPrec i 0 (concatD [doc (showString "undefined")])
ObjectLiteral keyvaluepairs -> prPrec i 0 (concatD [doc (showString "{") , prt 0 keyvaluepairs , doc (showString "}")])
ArrayLiteral params -> prPrec i 0 (concatD [doc (showString "[") , prt 0 params , doc (showString "]")])
instance Print FunExpr where
prt i e = case e of
Fun maybeident paramnames compoundstmt -> prPrec i 0 (concatD [doc (showString "function") , prt 0 maybeident , prt 0 paramnames , prt 0 compoundstmt])
instance Print Expr where
prt i e = case e of
FunExpression funexpr -> prPrec i 0 (concatD [prt 0 funexpr])
AssignExpr lvalue expr -> prPrec i 0 (concatD [prt 0 lvalue , doc (showString "=") , prt 0 expr])
LOrExpr expr0 expr -> prPrec i 2 (concatD [prt 2 expr0 , doc (showString "||") , prt 3 expr])
LAndExpr expr0 expr -> prPrec i 3 (concatD [prt 3 expr0 , doc (showString "&&") , prt 4 expr])
EqExpr expr0 expr -> prPrec i 4 (concatD [prt 4 expr0 , doc (showString "===") , prt 5 expr])
NeqExpr expr0 expr -> prPrec i 4 (concatD [prt 4 expr0 , doc (showString "!==") , prt 5 expr])
LessExpr expr0 expr -> prPrec i 5 (concatD [prt 5 expr0 , doc (showString "<") , prt 6 expr])
GreaterExpr expr0 expr -> prPrec i 5 (concatD [prt 5 expr0 , doc (showString ">") , prt 6 expr])
LeqExpr expr0 expr -> prPrec i 5 (concatD [prt 5 expr0 , doc (showString "<=") , prt 6 expr])
GeqExpr expr0 expr -> prPrec i 5 (concatD [prt 5 expr0 , doc (showString ">=") , prt 6 expr])
PlusExpr expr0 expr -> prPrec i 6 (concatD [prt 6 expr0 , doc (showString "+") , prt 7 expr])
MinusExpr expr0 expr -> prPrec i 6 (concatD [prt 6 expr0 , doc (showString "-") , prt 7 expr])
TimesExpr expr0 expr -> prPrec i 6 (concatD [prt 6 expr0 , doc (showString "*") , prt 7 expr])
DivExpr expr0 expr -> prPrec i 6 (concatD [prt 6 expr0 , doc (showString "/") , prt 7 expr])
PreincExpr lvalue -> prPrec i 7 (concatD [doc (showString "++") , prt 0 lvalue])
PredecExpr lvalue -> prPrec i 7 (concatD [doc (showString "--") , prt 0 lvalue])
PreopExpr unaryop expr -> prPrec i 8 (concatD [prt 0 unaryop , prt 9 expr])
ParenExpr expr -> prPrec i 9 (concatD [doc (showString "(") , prt 0 expr , doc (showString ")")])
CallExpr lvalue params -> prPrec i 10 (concatD [prt 0 lvalue , prt 0 params])
LiteralExpr literal -> prPrec i 11 (concatD [prt 0 literal])
EvalExpr lvalue -> prPrec i 12 (concatD [prt 0 lvalue])
instance Print UnaryOp where
prt i e = case e of
NegOp -> prPrec i 0 (concatD [doc (showString "!")])
instance Print ElseClause where
prt i e = case e of
Else stmt -> prPrec i 0 (concatD [doc (showString "else") , prt 0 stmt])
ElseEmpty -> prPrec i 0 (concatD [])