git.iko.soy/elk
on 83e18b3 help sign in
elk/src/Generate/JavaScript/Builder.hs
526 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)
23import qualified Json.Encode as Json
27-- EXPRESSIONS
30data Expr
31 = String Builder
32 | Float Double
33 | Int Int
34 | Bool Bool
35 | Null
36 | Json Json.Value
37 | Array [Expr]
38 | Object [(Name, Expr)]
39 | Ref Name
40 | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
41 | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
42 | Prefix PrefixOp Expr
43 | Infix InfixOp Expr Expr
44 | If Expr Expr Expr
45 | Assign LValue Expr
46 | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
47 | Function (Maybe Name) [Name] [Stmt]
50data LValue
51 = LRef Name
52 | LDot Expr Name
53 | LBracket Expr Expr
57-- STATEMENTS
60data Stmt
61 = Block [Stmt] -- {stmts}
62 | EmptyStmt -- ;
63 | ExprStmt Expr -- expr;
64 | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
65 | Switch Expr [Case] -- switch (e) clauses
66 | While Expr Stmt -- while (e) do stmt
67 | Break (Maybe Name) -- break lab;
68 | Continue (Maybe Name) -- continue lab;
69 | Labelled Name Stmt -- lab: stmt
70 | Return (Maybe Expr) -- return expr;
71 | Var [(Name, Maybe Expr)] -- var x, y=42;
72 | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
75data Case
76 = Case Expr [Stmt]
77 | Default [Stmt]
81-- OPERATORS
84data InfixOp
85 = OpLT -- <
86 | OpLEq -- <=
87 | OpGT -- >
88 | OpGEq -- >=
89 | OpIn -- in
90 | OpInstanceof -- instanceof
91 | OpEq -- ==
92 | OpNEq -- !=
93 | OpStrictEq -- ===
94 | OpStrictNEq -- !==
95 | OpLAnd -- &&
96 | OpLOr -- ||
97 | OpMul -- *
98 | OpDiv -- /
99 | OpMod -- %
100 | OpSub -- -
101 | OpLShift -- <<
102 | OpSpRShift -- >>
103 | OpZfRShift -- >>>
104 | OpBAnd -- &
105 | OpBXor -- ^
106 | OpBOr -- |
107 | OpAdd -- +
110data PrefixOp
111 = PrefixLNot -- !
112 | PrefixBNot -- ~
113 | PrefixPlus -- +
114 | PrefixMinus -- -
115 | PrefixTypeof -- typeof
119-- ENCODE
122stmtToBuilder :: Stmt -> Builder
123stmtToBuilder stmts =
124 fromStmt "" stmts
127exprToBuilder :: Expr -> Builder
128exprToBuilder expr =
129 snd $ fromExpr "" Whatever expr
133-- HELPERS
136deeper :: Builder -> Builder
137deeper indent =
138 "\t" <> indent
141commaSep :: [Builder] -> Builder
142commaSep builders =
143 mconcat (List.intersperse ", " builders)
146commaNewlineSep :: Builder -> [Builder] -> Builder
147commaNewlineSep indent builders =
148 mconcat (List.intersperse (",\n" <> deeper indent) builders)
152-- STATEMENTS
155fromStmtBlock :: Builder -> [Stmt] -> Builder
156fromStmtBlock indent stmts =
157 mconcat (map (fromStmt indent) stmts)
160fromStmt :: Builder -> Stmt -> Builder
161fromStmt indent statement =
162 case statement of
163 Block stmts ->
164 fromStmtBlock indent stmts
166 EmptyStmt ->
167 mempty
169 ExprStmt expr ->
170 indent <> snd (fromExpr indent Whatever expr) <> ";\n"
172 IfStmt condition thenStmt elseStmt ->
173 mconcat
174 [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
175 , fromStmt (deeper indent) thenStmt
176 , indent, "} else {\n"
177 , fromStmt (deeper indent) elseStmt
178 , indent, "}\n"
179 ]
181 Switch expr clauses ->
182 mconcat
183 [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
184 , mconcat (map (fromClause (deeper indent)) clauses)
185 , indent, "}\n"
186 ]
188 While expr stmt ->
189 mconcat
190 [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
191 , fromStmt (deeper indent) stmt
192 , indent, "}\n"
193 ]
195 Break Nothing ->
196 indent <> "break;\n"
198 Break (Just label) ->
199 indent <> "break " <> Name.toBuilder label <> ";\n"
201 Continue Nothing ->
202 indent <> "continue;\n"
204 Continue (Just label) ->
205 indent <> "continue " <> Name.toBuilder label <> ";\n"
207 Labelled label stmt ->
208 mconcat
209 [ indent, Name.toBuilder label, ":\n"
210 , fromStmt indent stmt
211 ]
213 Return Nothing ->
214 indent <> "return;\n"
216 Return (Just expr) ->
217 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
219 Var [] ->
220 mempty
222 Var vars ->
223 indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
225 FunctionStmt name args stmts ->
226 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
227 <>
228 fromStmtBlock (deeper indent) stmts
229 <>
230 indent <> "}\n"
234-- SWITCH CLAUSES
237fromClause :: Builder -> Case -> Builder
238fromClause indent clause =
239 case clause of
240 Case expr stmts ->
241 indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
242 <> fromStmtBlock (deeper indent) stmts
244 Default stmts ->
245 indent <> "default:\n"
246 <> fromStmtBlock (deeper indent) stmts
250-- VAR DECLS
253varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
254varToBuilder indent (name, maybeExpr) =
255 case maybeExpr of
256 Nothing ->
257 Name.toBuilder name
259 Just expr ->
260 Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
264-- EXPRESSIONS
267data Lines = One | Many deriving (Eq)
270merge :: Lines -> Lines -> Lines
271merge a b =
272 if a == Many || b == Many then Many else One
275linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
276linesMap func xs =
277 let
278 pairs =
279 map func xs
280 in
281 ( any ((==) Many . fst) pairs
282 , map snd pairs
283 )
286data Grouping = Atomic | Whatever
289parensFor :: Grouping -> Builder -> Builder
290parensFor grouping builder =
291 case grouping of
292 Atomic ->
293 "(" <> builder <> ")"
295 Whatever ->
296 builder
299fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
300fromExpr indent grouping expression =
301 case expression of
302 String string ->
303 (One, "'" <> string <> "'")
305 Float n ->
306 (One, B.doubleDec n)
308 Int n ->
309 (One, B.intDec n)
311 Bool bool ->
312 (One, if bool then "true" else "false")
314 Null ->
315 (One, "null")
317 Json json ->
318 ( One, Json.encodeUgly json )
320 Array exprs ->
321 (,) Many $
322 let
323 (anyMany, builders) =
324 linesMap (fromExpr indent Whatever) exprs
325 in
326 if anyMany then
327 "[\n"
328 <> deeper indent
329 <> commaNewlineSep indent builders
330 <> "\n" <> indent <> "]"
332 else
333 "[" <> commaSep builders <> "]"
335 Object fields ->
336 (,) Many $
337 let
338 deeperIndent =
339 deeper indent
341 (anyMany, builders) =
342 linesMap (fromField deeperIndent) fields
343 in
344 if anyMany then
345 "{\n"
346 <> deeperIndent
347 <> commaNewlineSep indent builders
348 <> "\n" <> indent <> "}"
350 else
351 "{" <> commaSep builders <> "}"
353 Ref name ->
354 (One, Name.toBuilder name)
356 Access expr field ->
357 makeDot indent expr field
359 Index expr bracketedExpr ->
360 makeBracketed indent expr bracketedExpr
362 Prefix op expr ->
363 let
364 (lines, builder) =
365 fromExpr indent Atomic expr
366 in
367 ( lines
368 , parensFor grouping (fromPrefix op <> builder)
369 )
371 Infix op leftExpr rightExpr ->
372 let
373 (leftLines, left) =
374 fromExpr indent Atomic leftExpr
376 (rightLines, right) =
377 fromExpr indent Atomic rightExpr
378 in
379 ( merge leftLines rightLines
380 , parensFor grouping (left <> fromInfix op <> right)
381 )
383 If condExpr thenExpr elseExpr ->
384 let
385 condB = snd (fromExpr indent Atomic condExpr)
386 thenB = snd (fromExpr indent Atomic thenExpr)
387 elseB = snd (fromExpr indent Atomic elseExpr)
388 in
389 ( Many
390 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
391 )
393 Assign lValue expr ->
394 let
395 (leftLines, left) =
396 fromLValue indent lValue
398 (rightLines, right) =
399 fromExpr indent Whatever expr
400 in
401 ( merge leftLines rightLines
402 , parensFor grouping (left <> " = " <> right)
403 )
405 Call function args ->
406 (,) Many $
407 let
408 deeperIndent =
409 deeper indent
411 funcB =
412 snd (fromExpr indent Atomic function)
414 (anyMany, argsB) =
415 linesMap (fromExpr deeperIndent Whatever) args
416 in
417 if anyMany then
418 funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
420 else
421 funcB <> "(" <> commaSep argsB <> ")"
423 Function maybeName args stmts ->
424 (,) Many $
425 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
426 <>
427 fromStmtBlock (deeper indent) stmts
428 <>
429 indent <> "}"
433-- FIELDS
436fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
437fromField indent (field, expr) =
438 let
439 (lines, builder) =
440 fromExpr indent Whatever expr
441 in
442 ( lines
443 , Name.toBuilder field <> ": " <> builder
444 )
448-- VALUES
451fromLValue :: Builder -> LValue -> (Lines, Builder)
452fromLValue indent lValue =
453 case lValue of
454 LRef name ->
455 (One, Name.toBuilder name)
457 LDot expr field ->
458 makeDot indent expr field
460 LBracket expr bracketedExpr ->
461 makeBracketed indent expr bracketedExpr
464makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
465makeDot indent expr field =
466 let
467 (lines, builder) =
468 fromExpr indent Atomic expr
469 in
470 (lines, builder <> "." <> Name.toBuilder field)
473makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
474makeBracketed indent expr bracketedExpr =
475 let
476 (lines, builder) =
477 fromExpr indent Atomic expr
479 (bracketedLines, bracketedBuilder) =
480 fromExpr indent Whatever bracketedExpr
481 in
482 ( merge lines bracketedLines
483 , builder <> "[" <> bracketedBuilder <> "]"
484 )
488-- OPERATORS
491fromPrefix :: PrefixOp -> Builder
492fromPrefix op =
493 case op of
494 PrefixLNot -> "!"
495 PrefixBNot -> "~"
496 PrefixPlus -> "+"
497 PrefixMinus -> "-"
498 PrefixTypeof -> "typeof "
501fromInfix :: InfixOp -> Builder
502fromInfix op =
503 case op of
504 OpLT -> " < "
505 OpLEq -> " <= "
506 OpGT -> " > "
507 OpGEq -> " >= "
508 OpIn -> " in "
509 OpInstanceof -> " instanceof "
510 OpEq -> " == "
511 OpNEq -> " != "
512 OpStrictEq -> " === "
513 OpStrictNEq -> " !== "
514 OpLAnd -> " && "
515 OpLOr -> " || "
516 OpMul -> " * "
517 OpDiv -> " / "
518 OpMod -> " % "
519 OpSub -> " - "
520 OpLShift -> " << "
521 OpSpRShift -> " >> "
522 OpZfRShift -> " >>> "
523 OpBAnd -> " & "
524 OpBXor -> " ^ "
525 OpBOr -> " | "
526 OpAdd -> " + "