git.iko.soy/elk
on a2daa5b help sign in
elk/src/Generate/JavaScript/Builder.hs
504 lines 11 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)
200{-# INLINE (!) #-}
201(!) :: a -> b -> (a, b)
202(!) a b =
203 (a, b)
205infix 0 !
208merge :: Lines -> Lines -> Lines
209merge a b =
210 if a == Many || b == Many then Many else One
213linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
214linesMap func xs =
215 let
216 pairs =
217 map func xs
218 in
219 ( any ((==) Many . fst) pairs
220 , map snd pairs
221 )
224data Grouping = Atomic | Whatever
227parensFor :: Grouping -> Builder -> Builder
228parensFor grouping builder =
229 case grouping of
230 Atomic ->
231 "(" <> builder <> ")"
233 Whatever ->
234 builder
237fromExpr :: Builder -> Grouping -> Expression a -> (Lines, Builder)
238fromExpr indent grouping expression =
239 case expression of
240 StringLit _ string ->
241 One ! fromString (show string)
243 RegexpLit _ _ _ _ ->
244 error "TODO"
246 NumLit _ n ->
247 One ! realFloat n
249 IntLit _ n ->
250 One ! decimal n
252 BoolLit _ True ->
253 One ! "true"
255 BoolLit _ False ->
256 One ! "false"
258 NullLit _ ->
259 One ! "null"
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 <> "]"
273 else
274 "[" <> commaSep builders <> "]"
276 ObjectLit _ fields ->
277 Many !
278 let
279 deeperIndent =
280 deeper indent
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 <> "}"
291 else
292 "{" <> commaSep builders <> "}"
294 ThisRef _ ->
295 One ! "this"
297 VarRef _ name ->
298 One ! fromId name
300 DotRef _ expr (Id _ name) ->
301 makeDot indent expr name
303 BracketRef _ expr bracketedExpr ->
304 makeBracketed indent expr bracketedExpr
306 NewExpr _ _ _ ->
307 error "TODO"
309 PrefixExpr _ op expr ->
310 let
311 (lines, builder) =
312 fromExpr indent Atomic expr
313 in
314 lines ! parensFor grouping (fromPrefix op <> builder)
316 UnaryAssignExpr _ _ _ ->
317 error "TODO"
319 InfixExpr _ op leftExpr rightExpr ->
320 let
321 (leftLines, left) =
322 fromExpr indent Atomic leftExpr
324 (rightLines, right) =
325 fromExpr indent Atomic rightExpr
326 in
327 merge leftLines rightLines !
328 parensFor grouping (left <> fromInfix op <> right)
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)
339 AssignExpr _ op lValue expr ->
340 let
341 (leftLines, left) =
342 fromLValue indent lValue
344 (rightLines, right) =
345 fromExpr indent Whatever expr
346 in
347 merge leftLines rightLines !
348 parensFor grouping (left <> fromAssign op <> right)
350 ListExpr _ _ ->
351 error "TODO"
353 CallExpr _ function args ->
354 Many !
355 let
356 deeperIndent =
357 deeper indent
359 funcB =
360 snd (fromExpr indent Atomic function)
362 (anyMany, argsB) =
363 linesMap (fromExpr deeperIndent Whatever) args
364 in
365 if anyMany then
366 funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
368 else
369 funcB <> "(" <> commaSep argsB <> ")"
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 <> "}"
381-- FIELDS
384fromField :: Builder -> (Prop a, Expression a) -> (Lines, Builder)
385fromField indent (prop, expr) =
386 let
387 (lines, builder) =
388 fromExpr indent Whatever expr
389 in
390 lines !
391 fromProp prop <> ": " <> builder
394fromProp :: Prop a -> Builder
395fromProp prop =
396 case prop of
397 PropId _ name ->
398 fromId name
400 PropString _ string ->
401 fromString (show string)
403 PropNum _ n ->
404 decimal n
408-- VALUES
411fromLValue :: Builder -> LValue a -> (Lines, Builder)
412fromLValue indent lValue =
413 case lValue of
414 LVar _ name ->
415 One ! fromString name
417 LDot _ expr field ->
418 makeDot indent expr field
420 LBracket _ expr bracketedExpr ->
421 makeBracketed indent expr bracketedExpr
424makeDot :: Builder -> Expression a -> String -> (Lines, Builder)
425makeDot indent expr field =
426 let
427 (lines, builder) =
428 fromExpr indent Atomic expr
429 in
430 lines ! builder <> "." <> fromString field
433makeBracketed :: Builder -> Expression a -> Expression a -> (Lines, Builder)
434makeBracketed indent expr bracketedExpr =
435 let
436 (lines, builder) =
437 fromExpr indent Atomic expr
439 (bracketedLines, bracketedBuilder) =
440 fromExpr indent Whatever bracketedExpr
441 in
442 merge lines bracketedLines !
443 builder <> "[" <> bracketedBuilder <> "]"
447-- OPERATORS
450fromPrefix :: PrefixOp -> Builder
451fromPrefix op =
452 case op of
453 PrefixLNot -> "!"
454 PrefixBNot -> "~"
455 PrefixPlus -> "+"
456 PrefixMinus -> "-"
457 PrefixTypeof -> "typeof "
458 PrefixVoid -> "void "
459 PrefixDelete -> "delete "
462fromAssign :: AssignOp -> Builder
463fromAssign 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 -> " |= "
479fromInfix :: InfixOp -> Builder
480fromInfix 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 -> " + "