@@ -0,0 +1,504 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Generate.JavaScript.Builder (stmtsToText) where
4+
5+import qualified Data.List as List
6+import Data.Monoid ((<>))
7+import qualified Data.Text.Lazy as LazyText
8+import Data.Text.Lazy.Builder
9+import Data.Text.Lazy.Builder.Int (decimal)
10+import Data.Text.Lazy.Builder.RealFloat (realFloat)
11+import Language.ECMAScript3.Syntax
12+import Prelude hiding (lines)
13+
14+
15+
16+-- CONVERT TO LAZY TEXT
17+
18+
19+stmtsToText :: [Statement a] -> LazyText.Text
20+stmtsToText stmts =
21+ toLazyText (fromStmtBlock "" stmts)
22+
23+
24+
25+-- HELPERS
26+
27+
28+deeper :: Builder -> Builder
29+deeper indent =
30+ "\t" <> indent
31+
32+
33+commaSep :: [Builder] -> Builder
34+commaSep builders =
35+ mconcat (List.intersperse ", " builders)
36+
37+
38+commaNewlineSep :: Builder -> [Builder] -> Builder
39+commaNewlineSep indent builders =
40+ mconcat (List.intersperse (",\n" <> deeper indent) builders)
41+
42+
43+
44+-- STATEMENTS
45+
46+
47+fromStmtBlock :: Builder -> [Statement a] -> Builder
48+fromStmtBlock indent stmts =
49+ mconcat (map (fromStmt indent) stmts)
50+
51+
52+fromStmt :: Builder -> Statement a -> Builder
53+fromStmt indent statement =
54+ case statement of
55+ BlockStmt _ stmts ->
56+ fromStmtBlock indent stmts
57+
58+ EmptyStmt _ ->
59+ mempty
60+
61+ ExprStmt _ expr ->
62+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"
63+
64+ IfStmt _ condition thenStmt elseStmt ->
65+ mconcat
66+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
67+ , fromStmt (deeper indent) thenStmt
68+ , indent, "} else {\n"
69+ , fromStmt (deeper indent) elseStmt
70+ , indent, "}\n"
71+ ]
72+
73+ IfSingleStmt _ condition thenStmt ->
74+ mconcat
75+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
76+ , fromStmt (deeper indent) thenStmt
77+ , indent, "}\n"
78+ ]
79+
80+ SwitchStmt _ expr clauses ->
81+ mconcat
82+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
83+ , mconcat (map (fromClause (deeper indent)) clauses)
84+ , indent, "}\n"
85+ ]
86+
87+ WhileStmt _ expr stmt ->
88+ mconcat
89+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
90+ , fromStmt (deeper indent) stmt
91+ , indent, "}\n"
92+ ]
93+
94+ DoWhileStmt _ stmt expr ->
95+ mconcat
96+ [ indent, "do {\n"
97+ , fromStmt (deeper indent) stmt
98+ , indent, "} while(", snd (fromExpr indent Whatever expr), ");\n"
99+ ]
100+
101+ BreakStmt _ Nothing ->
102+ indent <> "break;\n"
103+
104+ BreakStmt _ (Just label) ->
105+ indent <> "break " <> fromId label <> ";\n"
106+
107+ ContinueStmt _ Nothing ->
108+ indent <> "continue;\n"
109+
110+ ContinueStmt _ (Just label) ->
111+ indent <> "continue " <> fromId label <> ";\n"
112+
113+ LabelledStmt _ label stmt ->
114+ mconcat
115+ [ indent, fromId label, ":\n"
116+ , fromStmt indent stmt
117+ ]
118+
119+ ForInStmt _ _ _ _ ->
120+ error "TODO"
121+
122+ ForStmt _ _ _ _ _ ->
123+ error "TODO"
124+
125+ TryStmt _ _ _ _ ->
126+ error "TODO"
127+
128+ ThrowStmt _ expr ->
129+ indent <> "throw " <> snd (fromExpr indent Whatever expr) <> ";\n"
130+
131+ ReturnStmt _ Nothing ->
132+ indent <> "return;\n"
133+
134+ ReturnStmt _ (Just expr) ->
135+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
136+
137+ WithStmt _ _ _ ->
138+ error "TODO"
139+
140+ VarDeclStmt _ [] ->
141+ mempty
142+
143+ VarDeclStmt _ decls ->
144+ indent <> "var " <> commaNewlineSep indent (map (fromVarDecl indent) decls) <> ";\n"
145+
146+ FunctionStmt _ name args stmts ->
147+ indent <> "function " <> fromId name <> "(" <> commaSep (map fromId args) <> ") {\n"
148+ <>
149+ fromStmtBlock (deeper indent) stmts
150+ <>
151+ indent <> "}\n"
152+
153+
154+
155+-- SWITCH CLAUSES
156+
157+
158+fromClause :: Builder -> CaseClause a -> Builder
159+fromClause indent clause =
160+ case clause of
161+ CaseClause _ expr stmts ->
162+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
163+ <> fromStmtBlock (deeper indent) stmts
164+
165+ CaseDefault _ stmts ->
166+ indent <> "default:\n"
167+ <> fromStmtBlock (deeper indent) stmts
168+
169+
170+
171+-- ID
172+
173+
174+fromId :: Id a -> Builder
175+fromId (Id _ name) =
176+ fromString name
177+
178+
179+
180+-- VAR DECLS
181+
182+
183+fromVarDecl :: Builder -> VarDecl a -> Builder
184+fromVarDecl indent (VarDecl _ (Id _ name) maybeExpr) =
185+ case maybeExpr of
186+ Nothing ->
187+ fromString name
188+
189+ Just expr ->
190+ fromString name <> " = " <> snd (fromExpr indent Whatever expr)
191+
192+
193+
194+-- EXPRESSIONS
195+
196+
197+data Lines = One | Many deriving (Eq)
198+
199+
200+{-# INLINE (!) #-}
201+(!) :: a -> b -> (a, b)
202+(!) a b =
203+ (a, b)
204+
205+infix 0 !
206+
207+
208+merge :: Lines -> Lines -> Lines
209+merge a b =
210+ if a == Many || b == Many then Many else One
211+
212+
213+linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
214+linesMap func xs =
215+ let
216+ pairs =
217+ map func xs
218+ in
219+ ( any ((==) Many . fst) pairs
220+ , map snd pairs
221+ )
222+
223+
224+data Grouping = Atomic | Whatever
225+
226+
227+parensFor :: Grouping -> Builder -> Builder
228+parensFor grouping builder =
229+ case grouping of
230+ Atomic ->
231+ "(" <> builder <> ")"
232+
233+ Whatever ->
234+ builder
235+
236+
237+fromExpr :: Builder -> Grouping -> Expression a -> (Lines, Builder)
238+fromExpr indent grouping expression =
239+ case expression of
240+ StringLit _ string ->
241+ One ! fromString (show string)
242+
243+ RegexpLit _ _ _ _ ->
244+ error "TODO"
245+
246+ NumLit _ n ->
247+ One ! realFloat n
248+
249+ IntLit _ n ->
250+ One ! decimal n
251+
252+ BoolLit _ True ->
253+ One ! "true"
254+
255+ BoolLit _ False ->
256+ One ! "false"
257+
258+ NullLit _ ->
259+ One ! "null"
260+
261+ ArrayLit _ exprs ->
262+ Many !
263+ let
264+ (anyMany, builders) =
265+ linesMap (fromExpr indent Whatever) exprs
266+ in
267+ if anyMany then
268+ "[\n"
269+ <> deeper indent
270+ <> commaNewlineSep indent builders
271+ <> "\n" <> indent <> "]"
272+
273+ else
274+ "[" <> commaSep builders <> "]"
275+
276+ ObjectLit _ fields ->
277+ Many !
278+ let
279+ deeperIndent =
280+ deeper indent
281+
282+ (anyMany, builders) =
283+ linesMap (fromField deeperIndent) fields
284+ in
285+ if anyMany then
286+ "{\n"
287+ <> deeperIndent
288+ <> commaNewlineSep indent builders
289+ <> "\n" <> indent <> "}"
290+
291+ else
292+ "{" <> commaSep builders <> "}"
293+
294+ ThisRef _ ->
295+ One ! "this"
296+
297+ VarRef _ name ->
298+ One ! fromId name
299+
300+ DotRef _ expr (Id _ name) ->
301+ makeDot indent expr name
302+
303+ BracketRef _ expr bracketedExpr ->
304+ makeBracketed indent expr bracketedExpr
305+
306+ NewExpr _ _ _ ->
307+ error "TODO"
308+
309+ PrefixExpr _ op expr ->
310+ let
311+ (lines, builder) =
312+ fromExpr indent Atomic expr
313+ in
314+ lines ! parensFor grouping (fromPrefix op <> builder)
315+
316+ UnaryAssignExpr _ _ _ ->
317+ error "TODO"
318+
319+ InfixExpr _ op leftExpr rightExpr ->
320+ let
321+ (leftLines, left) =
322+ fromExpr indent Atomic leftExpr
323+
324+ (rightLines, right) =
325+ fromExpr indent Atomic rightExpr
326+ in
327+ merge leftLines rightLines !
328+ parensFor grouping (left <> fromInfix op <> right)
329+
330+ CondExpr _ condExpr thenExpr elseExpr ->
331+ let
332+ condB = snd (fromExpr indent Atomic condExpr)
333+ thenB = snd (fromExpr indent Atomic thenExpr)
334+ elseB = snd (fromExpr indent Atomic elseExpr)
335+ in
336+ Many !
337+ parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
338+
339+ AssignExpr _ op lValue expr ->
340+ let
341+ (leftLines, left) =
342+ fromLValue indent lValue
343+
344+ (rightLines, right) =
345+ fromExpr indent Whatever expr
346+ in
347+ merge leftLines rightLines !
348+ parensFor grouping (left <> fromAssign op <> right)
349+
350+ ListExpr _ _ ->
351+ error "TODO"
352+
353+ CallExpr _ function args ->
354+ Many !
355+ let
356+ deeperIndent =
357+ deeper indent
358+
359+ funcB =
360+ snd (fromExpr indent Atomic function)
361+
362+ (anyMany, argsB) =
363+ linesMap (fromExpr deeperIndent Whatever) args
364+ in
365+ if anyMany then
366+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
367+
368+ else
369+ funcB <> "(" <> commaSep argsB <> ")"
370+
371+ FuncExpr _ maybeName args stmts ->
372+ Many !
373+ "function " <> maybe mempty fromId maybeName <> "(" <> commaSep (map fromId args) <> ") {\n"
374+ <>
375+ fromStmtBlock (deeper indent) stmts
376+ <>
377+ indent <> "}"
378+
379+
380+
381+-- FIELDS
382+
383+
384+fromField :: Builder -> (Prop a, Expression a) -> (Lines, Builder)
385+fromField indent (prop, expr) =
386+ let
387+ (lines, builder) =
388+ fromExpr indent Whatever expr
389+ in
390+ lines !
391+ fromProp prop <> ": " <> builder
392+
393+
394+fromProp :: Prop a -> Builder
395+fromProp prop =
396+ case prop of
397+ PropId _ name ->
398+ fromId name
399+
400+ PropString _ string ->
401+ fromString (show string)
402+
403+ PropNum _ n ->
404+ decimal n
405+
406+
407+
408+-- VALUES
409+
410+
411+fromLValue :: Builder -> LValue a -> (Lines, Builder)
412+fromLValue indent lValue =
413+ case lValue of
414+ LVar _ name ->
415+ One ! fromString name
416+
417+ LDot _ expr field ->
418+ makeDot indent expr field
419+
420+ LBracket _ expr bracketedExpr ->
421+ makeBracketed indent expr bracketedExpr
422+
423+
424+makeDot :: Builder -> Expression a -> String -> (Lines, Builder)
425+makeDot indent expr field =
426+ let
427+ (lines, builder) =
428+ fromExpr indent Atomic expr
429+ in
430+ lines ! builder <> "." <> fromString field
431+
432+
433+makeBracketed :: Builder -> Expression a -> Expression a -> (Lines, Builder)
434+makeBracketed indent expr bracketedExpr =
435+ let
436+ (lines, builder) =
437+ fromExpr indent Atomic expr
438+
439+ (bracketedLines, bracketedBuilder) =
440+ fromExpr indent Whatever bracketedExpr
441+ in
442+ merge lines bracketedLines !
443+ builder <> "[" <> bracketedBuilder <> "]"
444+
445+
446+
447+-- OPERATORS
448+
449+
450+fromPrefix :: PrefixOp -> Builder
451+fromPrefix op =
452+ case op of
453+ PrefixLNot -> "!"
454+ PrefixBNot -> "~"
455+ PrefixPlus -> "+"
456+ PrefixMinus -> "-"
457+ PrefixTypeof -> "typeof "
458+ PrefixVoid -> "void "
459+ PrefixDelete -> "delete "
460+
461+
462+fromAssign :: AssignOp -> Builder
463+fromAssign op =
464+ case op of
465+ OpAssign -> " = "
466+ OpAssignAdd -> " += "
467+ OpAssignSub -> " -= "
468+ OpAssignMul -> " *= "
469+ OpAssignDiv -> " /= "
470+ OpAssignMod -> " %= "
471+ OpAssignLShift -> " <<= "
472+ OpAssignSpRShift -> " >>= "
473+ OpAssignZfRShift -> " >>>= "
474+ OpAssignBAnd -> " &= "
475+ OpAssignBXor -> " ^= "
476+ OpAssignBOr -> " |= "
477+
478+
479+fromInfix :: InfixOp -> Builder
480+fromInfix op =
481+ case op of
482+ OpLT -> " < "
483+ OpLEq -> " <= "
484+ OpGT -> " > "
485+ OpGEq -> " >= "
486+ OpIn -> " in "
487+ OpInstanceof -> " instanceof "
488+ OpEq -> " == "
489+ OpNEq -> " != "
490+ OpStrictEq -> " === "
491+ OpStrictNEq -> " !=== "
492+ OpLAnd -> " && "
493+ OpLOr -> " || "
494+ OpMul -> " * "
495+ OpDiv -> " / "
496+ OpMod -> " % "
497+ OpSub -> " - "
498+ OpLShift -> " << "
499+ OpSpRShift -> " >> "
500+ OpZfRShift -> " >>> "
501+ OpBAnd -> " & "
502+ OpBXor -> " ^ "
503+ OpBOr -> " | "
504+ OpAdd -> " + "