git.iko.soy/elk
on 71fa816 help sign in
elk/compiler/src/Generate/JavaScript/Builder.hs
530 lines 12 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 qualified Data.ByteString as BS
20import Data.ByteString.Builder as B
21import Data.Monoid ((<>))
22import qualified Generate.JavaScript.Name as Name
23import Generate.JavaScript.Name (Name)
24import qualified Json.Encode as Json
28-- EXPRESSIONS
31-- NOTE: I tried making this create a B.Builder directly.
32--
33-- The hope was that it'd allocate less and speed things up, but it seemed
34-- to be neutral for perf.
35--
36-- The downside is that Generate.JavaScript.Expression inspects the
37-- structure of Expr and Stmt on some occassions to try to strip out
38-- unnecessary closures. I think these closures are already avoided
39-- by other logic in code gen these days, but I am not 100% certain.
40--
41-- For this to be worth it, I think it would be necessary to avoid
42-- returning tuples when generating expressions.
43--
44data Expr
45 = String Builder
46 | Float Builder
47 | Int Int
48 | Bool Bool
49 | Null
50 | Json Json.Value
51 | Array [Expr]
52 | Object [(Name, Expr)]
53 | Ref Name
54 | Access Expr Name -- foo.bar
55 | Index Expr Expr -- foo[bar]
56 | Prefix PrefixOp Expr
57 | Infix InfixOp Expr Expr
58 | If Expr Expr Expr
59 | Assign LValue Expr
60 | Call Expr [Expr]
61 | Function (Maybe Name) [Name] [Stmt]
64data LValue
65 = LRef Name
66 | LDot Expr Name
67 | LBracket Expr Expr
71-- STATEMENTS
74data Stmt
75 = Block [Stmt]
76 | EmptyStmt
77 | ExprStmt Expr
78 | IfStmt Expr Stmt Stmt
79 | Switch Expr [Case]
80 | While Expr Stmt
81 | Break (Maybe Name)
82 | Continue (Maybe Name)
83 | Labelled Name Stmt
84 | Try Stmt Name Stmt
85 | Throw Expr
86 | Return Expr
87 | Var Name Expr
88 | Vars [(Name, Expr)]
89 | FunctionStmt Name [Name] [Stmt]
92data Case
93 = Case Expr [Stmt]
94 | Default [Stmt]
98-- OPERATORS
101data InfixOp
102 = OpAdd -- +
103 | OpSub -- -
104 | OpMul -- *
105 | OpDiv -- /
106 | OpMod -- %
107 | OpEq -- ===
108 | OpNe -- !==
109 | OpLt -- <
110 | OpLe -- <=
111 | OpGt -- >
112 | OpGe -- >=
113 | OpAnd -- &&
114 | OpOr -- ||
115 | OpBitwiseAnd -- &
116 | OpBitwiseXor -- ^
117 | OpBitwiseOr -- |
118 | OpLShift -- <<
119 | OpSpRShift -- >>
120 | OpZfRShift -- >>>
123data PrefixOp
124 = PrefixNot -- !
125 | PrefixNegate -- -
126 | PrefixComplement -- ~
130-- ENCODE
133stmtToBuilder :: Stmt -> Builder
134stmtToBuilder stmts =
135 fromStmt levelZero stmts
138exprToBuilder :: Expr -> Builder
139exprToBuilder expr =
140 snd $ fromExpr levelZero Whatever expr
144-- INDENT LEVEL
147data Level =
148 Level Builder Level
151levelZero :: Level
152levelZero =
153 Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
156makeLevel :: Int -> BS.ByteString -> Level
157makeLevel level oldTabs =
158 let
159 tabs =
160 if level <= BS.length oldTabs
161 then oldTabs
162 else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
163 in
164 Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)
168-- HELPERS
171commaSep :: [Builder] -> Builder
172commaSep builders =
173 mconcat (List.intersperse ", " builders)
176commaNewlineSep :: Level -> [Builder] -> Builder
177commaNewlineSep (Level _ (Level deeperIndent _)) builders =
178 mconcat (List.intersperse (",\n" <> deeperIndent) builders)
182-- STATEMENTS
185fromStmtBlock :: Level -> [Stmt] -> Builder
186fromStmtBlock level stmts =
187 mconcat (map (fromStmt level) stmts)
190fromStmt :: Level -> Stmt -> Builder
191fromStmt level@(Level indent nextLevel) statement =
192 case statement of
193 Block stmts ->
194 fromStmtBlock level stmts
196 EmptyStmt ->
197 mempty
199 ExprStmt expr ->
200 indent <> snd (fromExpr level Whatever expr) <> ";\n"
202 IfStmt condition thenStmt elseStmt ->
203 mconcat
204 [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
205 , fromStmt nextLevel thenStmt
206 , indent, "} else {\n"
207 , fromStmt nextLevel elseStmt
208 , indent, "}\n"
209 ]
211 Switch expr clauses ->
212 mconcat
213 [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
214 , mconcat (map (fromClause nextLevel) clauses)
215 , indent, "}\n"
216 ]
218 While expr stmt ->
219 mconcat
220 [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
221 , fromStmt nextLevel stmt
222 , indent, "}\n"
223 ]
225 Break Nothing ->
226 indent <> "break;\n"
228 Break (Just label) ->
229 indent <> "break " <> Name.toBuilder label <> ";\n"
231 Continue Nothing ->
232 indent <> "continue;\n"
234 Continue (Just label) ->
235 indent <> "continue " <> Name.toBuilder label <> ";\n"
237 Labelled label stmt ->
238 mconcat
239 [ indent, Name.toBuilder label, ":\n"
240 , fromStmt level stmt
241 ]
243 Try tryStmt errorName catchStmt ->
244 mconcat
245 [ indent, "try {\n"
246 , fromStmt nextLevel tryStmt
247 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
248 , fromStmt nextLevel catchStmt
249 , indent, "}\n"
250 ]
252 Throw expr ->
253 indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
255 Return expr ->
256 indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
258 Var name expr ->
259 indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
261 Vars [] ->
262 mempty
264 Vars vars ->
265 indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
267 FunctionStmt name args stmts ->
268 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
269 <>
270 fromStmtBlock nextLevel stmts
271 <>
272 indent <> "}\n"
276-- SWITCH CLAUSES
279fromClause :: Level -> Case -> Builder
280fromClause level@(Level indent nextLevel) clause =
281 case clause of
282 Case expr stmts ->
283 indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
284 <> fromStmtBlock nextLevel stmts
286 Default stmts ->
287 indent <> "default:\n"
288 <> fromStmtBlock nextLevel stmts
292-- VAR DECLS
295varToBuilder :: Level -> (Name, Expr) -> Builder
296varToBuilder level (name, expr) =
297 Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
301-- EXPRESSIONS
304data Lines = One | Many deriving (Eq)
307merge :: Lines -> Lines -> Lines
308merge a b =
309 if a == Many || b == Many then Many else One
312linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
313linesMap func xs =
314 let
315 pairs = map func xs
316 in
317 ( any ((==) Many . fst) pairs
318 , map snd pairs
319 )
322data Grouping = Atomic | Whatever
325parensFor :: Grouping -> Builder -> Builder
326parensFor grouping builder =
327 case grouping of
328 Atomic ->
329 "(" <> builder <> ")"
331 Whatever ->
332 builder
335fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
336fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
337 case expression of
338 String string ->
339 ( One, "'" <> string <> "'" )
341 Float float ->
342 ( One, float )
344 Int n ->
345 ( One, B.intDec n )
347 Bool bool ->
348 ( One, if bool then "true" else "false" )
350 Null ->
351 ( One, "null" )
353 Json json ->
354 ( One, Json.encodeUgly json )
356 Array exprs ->
357 (,) Many $
358 let
359 (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
360 in
361 if anyMany then
362 "[\n"
363 <> deeperIndent
364 <> commaNewlineSep level builders
365 <> "\n" <> indent <> "]"
366 else
367 "[" <> commaSep builders <> "]"
369 Object fields ->
370 (,) Many $
371 let
372 (anyMany, builders) = linesMap (fromField nextLevel) fields
373 in
374 if anyMany then
375 "{\n"
376 <> deeperIndent
377 <> commaNewlineSep level builders
378 <> "\n" <> indent <> "}"
379 else
380 "{" <> commaSep builders <> "}"
382 Ref name ->
383 ( One, Name.toBuilder name )
385 Access expr field ->
386 makeDot level expr field
388 Index expr bracketedExpr ->
389 makeBracketed level expr bracketedExpr
391 Prefix op expr ->
392 let
393 (lines, builder) = fromExpr level Atomic expr
394 in
395 ( lines
396 , parensFor grouping (fromPrefix op <> builder)
397 )
399 Infix op leftExpr rightExpr ->
400 let
401 (leftLines , left ) = fromExpr level Atomic leftExpr
402 (rightLines, right) = fromExpr level Atomic rightExpr
403 in
404 ( merge leftLines rightLines
405 , parensFor grouping (left <> fromInfix op <> right)
406 )
408 If condExpr thenExpr elseExpr ->
409 let
410 condB = snd (fromExpr level Atomic condExpr)
411 thenB = snd (fromExpr level Atomic thenExpr)
412 elseB = snd (fromExpr level Atomic elseExpr)
413 in
414 ( Many
415 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
416 )
418 Assign lValue expr ->
419 let
420 (leftLines , left ) = fromLValue level lValue
421 (rightLines, right) = fromExpr level Whatever expr
422 in
423 ( merge leftLines rightLines
424 , parensFor grouping (left <> " = " <> right)
425 )
427 Call function args ->
428 (,) Many $
429 let
430 (_ , funcB) = fromExpr level Atomic function
431 (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
432 in
433 if anyMany then
434 funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
435 else
436 funcB <> "(" <> commaSep argsB <> ")"
438 Function maybeName args stmts ->
439 (,) Many $
440 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
441 <>
442 fromStmtBlock nextLevel stmts
443 <>
444 indent <> "}"
448-- FIELDS
451fromField :: Level -> (Name, Expr) -> (Lines, Builder)
452fromField level (field, expr) =
453 let
454 (lines, builder) = fromExpr level Whatever expr
455 in
456 ( lines
457 , Name.toBuilder field <> ": " <> builder
458 )
462-- VALUES
465fromLValue :: Level -> LValue -> (Lines, Builder)
466fromLValue level lValue =
467 case lValue of
468 LRef name ->
469 (One, Name.toBuilder name)
471 LDot expr field ->
472 makeDot level expr field
474 LBracket expr bracketedExpr ->
475 makeBracketed level expr bracketedExpr
478makeDot :: Level -> Expr -> Name -> (Lines, Builder)
479makeDot level expr field =
480 let
481 (lines, builder) = fromExpr level Atomic expr
482 in
483 (lines, builder <> "." <> Name.toBuilder field)
486makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
487makeBracketed level expr bracketedExpr =
488 let
489 (lines , builder ) = fromExpr level Atomic expr
490 (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
491 in
492 ( merge lines bracketedLines
493 , builder <> "[" <> bracketedBuilder <> "]"
494 )
498-- OPERATORS
501fromPrefix :: PrefixOp -> Builder
502fromPrefix op =
503 case op of
504 PrefixNot -> "!"
505 PrefixNegate -> "-"
506 PrefixComplement -> "~"
509fromInfix :: InfixOp -> Builder
510fromInfix op =
511 case op of
512 OpAdd -> " + "
513 OpSub -> " - "
514 OpMul -> " * "
515 OpDiv -> " / "
516 OpMod -> " % "
517 OpEq -> " === "
518 OpNe -> " !== "
519 OpLt -> " < "
520 OpLe -> " <= "
521 OpGt -> " > "
522 OpGe -> " >= "
523 OpAnd -> " && "
524 OpOr -> " || "
525 OpBitwiseAnd -> " & "
526 OpBitwiseXor -> " ^ "
527 OpBitwiseOr -> " | "
528 OpLShift -> " << "
529 OpSpRShift -> " >> "
530 OpZfRShift -> " >>> "