git.iko.soy/elk
on 42c3f75 help sign in
elk/src/Generate/JavaScript/Builder.hs
529 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript.Builder
4 ( stmtToBuilder
5 , exprToBuilder
6 , Expr(..), LValue(..)
7 , Stmt(..), Case(..)
8 , InfixOp(..), PrefixOp(..)
9 )
10 where
12-- Based on the language-ecmascript package.
13-- https://hackage.haskell.org/package/language-ecmascript
14-- They did the hard work of reading the spec to figure out
15-- how all the types should fit together.
17import Prelude hiding (lines)
18import qualified Data.List as List
19import Data.ByteString.Builder as B
20import Data.Monoid ((<>))
21import qualified Generate.JavaScript.Name as Name
22import Generate.JavaScript.Name (Name)
26-- EXPRESSIONS
29data Expr
30 = String Builder
31 | Float Double
32 | Int Int
33 | Bool Bool
34 | Null
35 | Array [Expr]
36 | Object [(Name, Expr)]
37 | Ref Name
38 | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
39 | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
40 | Prefix PrefixOp Expr
41 | Infix InfixOp Expr Expr
42 | If Expr Expr Expr
43 | Assign LValue Expr
44 | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
45 | Function (Maybe Name) [Name] [Stmt]
48data LValue
49 = LVar Name
50 | LDot Expr Name
51 | LBracket Expr Expr
55-- STATEMENTS
58data Stmt
59 = Block [Stmt] -- {stmts}
60 | EmptyStmt -- ;
61 | ExprStmt Expr -- expr;
62 | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
63 | Switch Expr [Case] -- switch (e) clauses
64 | While Expr Stmt -- while (e) do stmt
65 | DoWhile Stmt Expr -- do stmt while (e);
66 | Break (Maybe Name) -- break lab;
67 | Continue (Maybe Name) -- continue lab;
68 | Labelled Name Stmt -- lab: stmt
69 | Return (Maybe Expr) -- return expr;
70 | Var [(Name, Maybe Expr)] -- var x, y=42;
71 | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
74data Case
75 = Case Expr [Stmt]
76 | Default [Stmt]
80-- OPERATORS
83data InfixOp
84 = OpLT -- <
85 | OpLEq -- <=
86 | OpGT -- >
87 | OpGEq -- >=
88 | OpIn -- in
89 | OpInstanceof -- instanceof
90 | OpEq -- ==
91 | OpNEq -- !=
92 | OpStrictEq -- ===
93 | OpStrictNEq -- !===
94 | OpLAnd -- &&
95 | OpLOr -- ||
96 | OpMul -- *
97 | OpDiv -- /
98 | OpMod -- %
99 | OpSub -- -
100 | OpLShift -- <<
101 | OpSpRShift -- >>
102 | OpZfRShift -- >>>
103 | OpBAnd -- &
104 | OpBXor -- ^
105 | OpBOr -- |
106 | OpAdd -- +
109data PrefixOp
110 = PrefixLNot -- !
111 | PrefixBNot -- ~
112 | PrefixPlus -- +
113 | PrefixMinus -- -
114 | PrefixTypeof -- typeof
118-- ENCODE
121stmtToBuilder :: Stmt -> Builder
122stmtToBuilder stmts =
123 fromStmt "" stmts
126exprToBuilder :: Expr -> Builder
127exprToBuilder expr =
128 snd $ fromExpr "" Whatever expr
132-- HELPERS
135deeper :: Builder -> Builder
136deeper indent =
137 "\t" <> indent
140commaSep :: [Builder] -> Builder
141commaSep builders =
142 mconcat (List.intersperse ", " builders)
145commaNewlineSep :: Builder -> [Builder] -> Builder
146commaNewlineSep indent builders =
147 mconcat (List.intersperse (",\n" <> deeper indent) builders)
151-- STATEMENTS
154fromStmtBlock :: Builder -> [Stmt] -> Builder
155fromStmtBlock indent stmts =
156 mconcat (map (fromStmt indent) stmts)
159fromStmt :: Builder -> Stmt -> Builder
160fromStmt indent statement =
161 case statement of
162 Block stmts ->
163 fromStmtBlock indent stmts
165 EmptyStmt ->
166 mempty
168 ExprStmt expr ->
169 indent <> snd (fromExpr indent Whatever expr) <> ";\n"
171 IfStmt condition thenStmt elseStmt ->
172 mconcat
173 [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
174 , fromStmt (deeper indent) thenStmt
175 , indent, "} else {\n"
176 , fromStmt (deeper indent) elseStmt
177 , indent, "}\n"
178 ]
180 Switch expr clauses ->
181 mconcat
182 [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
183 , mconcat (map (fromClause (deeper indent)) clauses)
184 , indent, "}\n"
185 ]
187 While expr stmt ->
188 mconcat
189 [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
190 , fromStmt (deeper indent) stmt
191 , indent, "}\n"
192 ]
194 DoWhile stmt expr ->
195 mconcat
196 [ indent, "do {\n"
197 , fromStmt (deeper indent) stmt
198 , indent, "} while(", snd (fromExpr indent Whatever expr), ");\n"
199 ]
201 Break Nothing ->
202 indent <> "break;\n"
204 Break (Just label) ->
205 indent <> "break " <> Name.toBuilder label <> ";\n"
207 Continue Nothing ->
208 indent <> "continue;\n"
210 Continue (Just label) ->
211 indent <> "continue " <> Name.toBuilder label <> ";\n"
213 Labelled label stmt ->
214 mconcat
215 [ indent, Name.toBuilder label, ":\n"
216 , fromStmt indent stmt
217 ]
219 Return Nothing ->
220 indent <> "return;\n"
222 Return (Just expr) ->
223 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
225 Var [] ->
226 mempty
228 Var vars ->
229 indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
231 FunctionStmt name args stmts ->
232 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
233 <>
234 fromStmtBlock (deeper indent) stmts
235 <>
236 indent <> "}\n"
240-- SWITCH CLAUSES
243fromClause :: Builder -> Case -> Builder
244fromClause indent clause =
245 case clause of
246 Case expr stmts ->
247 indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
248 <> fromStmtBlock (deeper indent) stmts
250 Default stmts ->
251 indent <> "default:\n"
252 <> fromStmtBlock (deeper indent) stmts
256-- VAR DECLS
259varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
260varToBuilder indent (name, maybeExpr) =
261 case maybeExpr of
262 Nothing ->
263 Name.toBuilder name
265 Just expr ->
266 Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
270-- EXPRESSIONS
273data Lines = One | Many deriving (Eq)
276merge :: Lines -> Lines -> Lines
277merge a b =
278 if a == Many || b == Many then Many else One
281linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
282linesMap func xs =
283 let
284 pairs =
285 map func xs
286 in
287 ( any ((==) Many . fst) pairs
288 , map snd pairs
289 )
292data Grouping = Atomic | Whatever
295parensFor :: Grouping -> Builder -> Builder
296parensFor grouping builder =
297 case grouping of
298 Atomic ->
299 "(" <> builder <> ")"
301 Whatever ->
302 builder
305fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
306fromExpr indent grouping expression =
307 case expression of
308 String string ->
309 (One, "'" <> string <> "'")
311 Float n ->
312 (One, B.doubleDec n)
314 Int n ->
315 (One, B.intDec n)
317 Bool bool ->
318 (One, if bool then "true" else "false")
320 Null ->
321 (One, "null")
323 Array exprs ->
324 (,) Many $
325 let
326 (anyMany, builders) =
327 linesMap (fromExpr indent Whatever) exprs
328 in
329 if anyMany then
330 "[\n"
331 <> deeper indent
332 <> commaNewlineSep indent builders
333 <> "\n" <> indent <> "]"
335 else
336 "[" <> commaSep builders <> "]"
338 Object fields ->
339 (,) Many $
340 let
341 deeperIndent =
342 deeper indent
344 (anyMany, builders) =
345 linesMap (fromField deeperIndent) fields
346 in
347 if anyMany then
348 "{\n"
349 <> deeperIndent
350 <> commaNewlineSep indent builders
351 <> "\n" <> indent <> "}"
353 else
354 "{" <> commaSep builders <> "}"
356 Ref name ->
357 (One, Name.toBuilder name)
359 Access expr field ->
360 makeDot indent expr field
362 Index expr bracketedExpr ->
363 makeBracketed indent expr bracketedExpr
365 Prefix op expr ->
366 let
367 (lines, builder) =
368 fromExpr indent Atomic expr
369 in
370 ( lines
371 , parensFor grouping (fromPrefix op <> builder)
372 )
374 Infix op leftExpr rightExpr ->
375 let
376 (leftLines, left) =
377 fromExpr indent Atomic leftExpr
379 (rightLines, right) =
380 fromExpr indent Atomic rightExpr
381 in
382 ( merge leftLines rightLines
383 , parensFor grouping (left <> fromInfix op <> right)
384 )
386 If condExpr thenExpr elseExpr ->
387 let
388 condB = snd (fromExpr indent Atomic condExpr)
389 thenB = snd (fromExpr indent Atomic thenExpr)
390 elseB = snd (fromExpr indent Atomic elseExpr)
391 in
392 ( Many
393 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
394 )
396 Assign lValue expr ->
397 let
398 (leftLines, left) =
399 fromLValue indent lValue
401 (rightLines, right) =
402 fromExpr indent Whatever expr
403 in
404 ( merge leftLines rightLines
405 , parensFor grouping (left <> " = " <> right)
406 )
408 Call function args ->
409 (,) Many $
410 let
411 deeperIndent =
412 deeper indent
414 funcB =
415 snd (fromExpr indent Atomic function)
417 (anyMany, argsB) =
418 linesMap (fromExpr deeperIndent Whatever) args
419 in
420 if anyMany then
421 funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
423 else
424 funcB <> "(" <> commaSep argsB <> ")"
426 Function maybeName args stmts ->
427 (,) Many $
428 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
429 <>
430 fromStmtBlock (deeper indent) stmts
431 <>
432 indent <> "}"
436-- FIELDS
439fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
440fromField indent (field, expr) =
441 let
442 (lines, builder) =
443 fromExpr indent Whatever expr
444 in
445 ( lines
446 , Name.toBuilder field <> ": " <> builder
447 )
451-- VALUES
454fromLValue :: Builder -> LValue -> (Lines, Builder)
455fromLValue indent lValue =
456 case lValue of
457 LVar name ->
458 (One, Name.toBuilder name)
460 LDot expr field ->
461 makeDot indent expr field
463 LBracket expr bracketedExpr ->
464 makeBracketed indent expr bracketedExpr
467makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
468makeDot indent expr field =
469 let
470 (lines, builder) =
471 fromExpr indent Atomic expr
472 in
473 (lines, builder <> "." <> Name.toBuilder field)
476makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
477makeBracketed indent expr bracketedExpr =
478 let
479 (lines, builder) =
480 fromExpr indent Atomic expr
482 (bracketedLines, bracketedBuilder) =
483 fromExpr indent Whatever bracketedExpr
484 in
485 ( merge lines bracketedLines
486 , builder <> "[" <> bracketedBuilder <> "]"
487 )
491-- OPERATORS
494fromPrefix :: PrefixOp -> Builder
495fromPrefix op =
496 case op of
497 PrefixLNot -> "!"
498 PrefixBNot -> "~"
499 PrefixPlus -> "+"
500 PrefixMinus -> "-"
501 PrefixTypeof -> "typeof "
504fromInfix :: InfixOp -> Builder
505fromInfix op =
506 case op of
507 OpLT -> " < "
508 OpLEq -> " <= "
509 OpGT -> " > "
510 OpGEq -> " >= "
511 OpIn -> " in "
512 OpInstanceof -> " instanceof "
513 OpEq -> " == "
514 OpNEq -> " != "
515 OpStrictEq -> " === "
516 OpStrictNEq -> " !=== "
517 OpLAnd -> " && "
518 OpLOr -> " || "
519 OpMul -> " * "
520 OpDiv -> " / "
521 OpMod -> " % "
522 OpSub -> " - "
523 OpLShift -> " << "
524 OpSpRShift -> " >> "
525 OpZfRShift -> " >>> "
526 OpBAnd -> " & "
527 OpBXor -> " ^ "
528 OpBOr -> " | "
529 OpAdd -> " + "