git.iko.soy/elk
on c5b225d help sign in
elk/src/Generate/JavaScript/Builder.hs
528 lines 12 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript.Builder (stmtsToText) where
5import qualified Data.List as List
6import Data.Monoid ((<>))
7import qualified Data.Text.Lazy as LazyText
8import Data.Text.Lazy.Builder
9import Data.Text.Lazy.Builder.Int (decimal)
10import Data.Text.Lazy.Builder.RealFloat (realFloat)
11import Language.ECMAScript3.Syntax
12import Prelude hiding (lines)
16-- CONVERT TO LAZY TEXT
19stmtsToText :: [Statement a] -> LazyText.Text
20stmtsToText stmts =
21 toLazyText (fromStmtBlock "" stmts)
25-- HELPERS
28deeper :: Builder -> Builder
29deeper indent =
30 "\t" <> indent
33commaSep :: [Builder] -> Builder
34commaSep builders =
35 mconcat (List.intersperse ", " builders)
38commaNewlineSep :: Builder -> [Builder] -> Builder
39commaNewlineSep indent builders =
40 mconcat (List.intersperse (",\n" <> deeper indent) builders)
44-- STATEMENTS
47fromStmtBlock :: Builder -> [Statement a] -> Builder
48fromStmtBlock indent stmts =
49 mconcat (map (fromStmt indent) stmts)
52fromStmt :: Builder -> Statement a -> Builder
53fromStmt indent statement =
54 case statement of
55 BlockStmt _ stmts ->
56 fromStmtBlock indent stmts
58 EmptyStmt _ ->
59 mempty
61 ExprStmt _ expr ->
62 indent <> snd (fromExpr indent Whatever expr) <> ";\n"
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 ]
73 IfSingleStmt _ condition thenStmt ->
74 mconcat
75 [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
76 , fromStmt (deeper indent) thenStmt
77 , indent, "}\n"
78 ]
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 ]
87 WhileStmt _ expr stmt ->
88 mconcat
89 [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
90 , fromStmt (deeper indent) stmt
91 , indent, "}\n"
92 ]
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 ]
101 BreakStmt _ Nothing ->
102 indent <> "break;\n"
104 BreakStmt _ (Just label) ->
105 indent <> "break " <> fromId label <> ";\n"
107 ContinueStmt _ Nothing ->
108 indent <> "continue;\n"
110 ContinueStmt _ (Just label) ->
111 indent <> "continue " <> fromId label <> ";\n"
113 LabelledStmt _ label stmt ->
114 mconcat
115 [ indent, fromId label, ":\n"
116 , fromStmt indent stmt
117 ]
119 ForInStmt _ _ _ _ ->
120 error "TODO"
122 ForStmt _ _ _ _ _ ->
123 error "TODO"
125 TryStmt _ _ _ _ ->
126 error "TODO"
128 ThrowStmt _ expr ->
129 indent <> "throw " <> snd (fromExpr indent Whatever expr) <> ";\n"
131 ReturnStmt _ Nothing ->
132 indent <> "return;\n"
134 ReturnStmt _ (Just expr) ->
135 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
137 WithStmt _ _ _ ->
138 error "TODO"
140 VarDeclStmt _ [] ->
141 mempty
143 VarDeclStmt _ decls ->
144 indent <> "var " <> commaNewlineSep indent (map (fromVarDecl indent) decls) <> ";\n"
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"
155-- SWITCH CLAUSES
158fromClause :: Builder -> CaseClause a -> Builder
159fromClause indent clause =
160 case clause of
161 CaseClause _ expr stmts ->
162 indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
163 <> fromStmtBlock (deeper indent) stmts
165 CaseDefault _ stmts ->
166 indent <> "default:\n"
167 <> fromStmtBlock (deeper indent) stmts
171-- ID
174fromId :: Id a -> Builder
175fromId (Id _ name) =
176 fromString name
180-- VAR DECLS
183fromVarDecl :: Builder -> VarDecl a -> Builder
184fromVarDecl indent (VarDecl _ (Id _ name) maybeExpr) =
185 case maybeExpr of
186 Nothing ->
187 fromString name
189 Just expr ->
190 fromString name <> " = " <> snd (fromExpr indent Whatever expr)
194-- EXPRESSIONS
197data Lines = One | Many deriving (Eq)
200merge :: Lines -> Lines -> Lines
201merge a b =
202 if a == Many || b == Many then Many else One
205linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
206linesMap func xs =
207 let
208 pairs =
209 map func xs
210 in
211 ( any ((==) Many . fst) pairs
212 , map snd pairs
213 )
216data Grouping = Atomic | Whatever
219parensFor :: Grouping -> Builder -> Builder
220parensFor grouping builder =
221 case grouping of
222 Atomic ->
223 "(" <> builder <> ")"
225 Whatever ->
226 builder
229fromExpr :: Builder -> Grouping -> Expression a -> (Lines, Builder)
230fromExpr indent grouping expression =
231 case expression of
232 StringLit _ string ->
233 (One, quoted string)
235 RegexpLit _ _ _ _ ->
236 error "TODO"
238 NumLit _ n ->
239 (One, realFloat n)
241 IntLit _ n ->
242 (One, decimal n)
244 BoolLit _ True ->
245 (One, "true")
247 BoolLit _ False ->
248 (One, "false")
250 NullLit _ ->
251 (One, "null")
253 ArrayLit _ exprs ->
254 (,) Many $
255 let
256 (anyMany, builders) =
257 linesMap (fromExpr indent Whatever) exprs
258 in
259 if anyMany then
260 "[\n"
261 <> deeper indent
262 <> commaNewlineSep indent builders
263 <> "\n" <> indent <> "]"
265 else
266 "[" <> commaSep builders <> "]"
268 ObjectLit _ fields ->
269 (,) Many $
270 let
271 deeperIndent =
272 deeper indent
274 (anyMany, builders) =
275 linesMap (fromField deeperIndent) fields
276 in
277 if anyMany then
278 "{\n"
279 <> deeperIndent
280 <> commaNewlineSep indent builders
281 <> "\n" <> indent <> "}"
283 else
284 "{" <> commaSep builders <> "}"
286 ThisRef _ ->
287 (One, "this")
289 VarRef _ name ->
290 (One, fromId name)
292 DotRef _ expr (Id _ name) ->
293 makeDot indent expr name
295 BracketRef _ expr bracketedExpr ->
296 makeBracketed indent expr bracketedExpr
298 NewExpr _ _ _ ->
299 error "TODO"
301 PrefixExpr _ op expr ->
302 let
303 (lines, builder) =
304 fromExpr indent Atomic expr
305 in
306 ( lines
307 , parensFor grouping (fromPrefix op <> builder)
308 )
310 UnaryAssignExpr _ _ _ ->
311 error "TODO"
313 InfixExpr _ op leftExpr rightExpr ->
314 let
315 (leftLines, left) =
316 fromExpr indent Atomic leftExpr
318 (rightLines, right) =
319 fromExpr indent Atomic rightExpr
320 in
321 ( merge leftLines rightLines
322 , parensFor grouping (left <> fromInfix op <> right)
323 )
325 CondExpr _ condExpr thenExpr elseExpr ->
326 let
327 condB = snd (fromExpr indent Atomic condExpr)
328 thenB = snd (fromExpr indent Atomic thenExpr)
329 elseB = snd (fromExpr indent Atomic elseExpr)
330 in
331 ( Many
332 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
333 )
335 AssignExpr _ op lValue expr ->
336 let
337 (leftLines, left) =
338 fromLValue indent lValue
340 (rightLines, right) =
341 fromExpr indent Whatever expr
342 in
343 ( merge leftLines rightLines
344 , parensFor grouping (left <> fromAssign op <> right)
345 )
347 ListExpr _ _ ->
348 error "TODO"
350 CallExpr _ function args ->
351 (,) Many $
352 let
353 deeperIndent =
354 deeper indent
356 funcB =
357 snd (fromExpr indent Atomic function)
359 (anyMany, argsB) =
360 linesMap (fromExpr deeperIndent Whatever) args
361 in
362 if anyMany then
363 funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
365 else
366 funcB <> "(" <> commaSep argsB <> ")"
368 FuncExpr _ maybeName args stmts ->
369 (,) Many $
370 "function " <> maybe mempty fromId maybeName <> "(" <> commaSep (map fromId args) <> ") {\n"
371 <>
372 fromStmtBlock (deeper indent) stmts
373 <>
374 indent <> "}"
378-- FIELDS
381fromField :: Builder -> (Prop a, Expression a) -> (Lines, Builder)
382fromField indent (prop, expr) =
383 let
384 (lines, builder) =
385 fromExpr indent Whatever expr
386 in
387 ( lines
388 , fromProp prop <> ": " <> builder
389 )
392fromProp :: Prop a -> Builder
393fromProp prop =
394 case prop of
395 PropId _ name ->
396 fromId name
398 PropString _ string ->
399 quoted string
401 PropNum _ n ->
402 decimal n
406-- STRINGS
409quoted :: String -> Builder
410quoted string =
411 fromString ('\'' : foldr escapeCons "'" string)
414-- https://developer.mozilla.org/en-US/docs/Web/JavaScript/Guide/Grammar_and_types#String_literals
415escapeCons :: Char -> String -> String
416escapeCons char rest =
417 case char of
418 '\b' -> '\\' : 'b' : rest
419 '\f' -> '\\' : 'f' : rest
420 '\n' -> '\\' : 'n' : rest
421 '\r' -> '\\' : 'r' : rest
422 '\t' -> '\\' : 't' : rest
423 '\v' -> '\\' : 'v' : rest
424 '\"' -> '\\' : '"' : rest
425 '\'' -> '\\' : '\'' : rest
426 '\\' -> '\\' : '\\' : rest
427 _ -> char : rest
431-- VALUES
434fromLValue :: Builder -> LValue a -> (Lines, Builder)
435fromLValue indent lValue =
436 case lValue of
437 LVar _ name ->
438 (One, fromString name)
440 LDot _ expr field ->
441 makeDot indent expr field
443 LBracket _ expr bracketedExpr ->
444 makeBracketed indent expr bracketedExpr
447makeDot :: Builder -> Expression a -> String -> (Lines, Builder)
448makeDot indent expr field =
449 let
450 (lines, builder) =
451 fromExpr indent Atomic expr
452 in
453 (lines, builder <> "." <> fromString field)
456makeBracketed :: Builder -> Expression a -> Expression a -> (Lines, Builder)
457makeBracketed indent expr bracketedExpr =
458 let
459 (lines, builder) =
460 fromExpr indent Atomic expr
462 (bracketedLines, bracketedBuilder) =
463 fromExpr indent Whatever bracketedExpr
464 in
465 ( merge lines bracketedLines
466 , builder <> "[" <> bracketedBuilder <> "]"
467 )
471-- OPERATORS
474fromPrefix :: PrefixOp -> Builder
475fromPrefix op =
476 case op of
477 PrefixLNot -> "!"
478 PrefixBNot -> "~"
479 PrefixPlus -> "+"
480 PrefixMinus -> "-"
481 PrefixTypeof -> "typeof "
482 PrefixVoid -> "void "
483 PrefixDelete -> "delete "
486fromAssign :: AssignOp -> Builder
487fromAssign op =
488 case op of
489 OpAssign -> " = "
490 OpAssignAdd -> " += "
491 OpAssignSub -> " -= "
492 OpAssignMul -> " *= "
493 OpAssignDiv -> " /= "
494 OpAssignMod -> " %= "
495 OpAssignLShift -> " <<= "
496 OpAssignSpRShift -> " >>= "
497 OpAssignZfRShift -> " >>>= "
498 OpAssignBAnd -> " &= "
499 OpAssignBXor -> " ^= "
500 OpAssignBOr -> " |= "
503fromInfix :: InfixOp -> Builder
504fromInfix op =
505 case op of
506 OpLT -> " < "
507 OpLEq -> " <= "
508 OpGT -> " > "
509 OpGEq -> " >= "
510 OpIn -> " in "
511 OpInstanceof -> " instanceof "
512 OpEq -> " == "
513 OpNEq -> " != "
514 OpStrictEq -> " === "
515 OpStrictNEq -> " !=== "
516 OpLAnd -> " && "
517 OpLOr -> " || "
518 OpMul -> " * "
519 OpDiv -> " / "
520 OpMod -> " % "
521 OpSub -> " - "
522 OpLShift -> " << "
523 OpSpRShift -> " >> "
524 OpZfRShift -> " >>> "
525 OpBAnd -> " & "
526 OpBXor -> " ^ "
527 OpBOr -> " | "
528 OpAdd -> " + "