git.iko.soy/elk
on badd0cf help sign in
elk/compiler/src/Generate/JavaScript/Builder.hs
499 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 Builder
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
41 | Index Expr Expr -- foo[bar]
42 | Prefix PrefixOp Expr
43 | Infix InfixOp Expr Expr
44 | If Expr Expr Expr
45 | Assign LValue Expr
46 | Call Expr [Expr]
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]
62 | EmptyStmt
63 | ExprStmt Expr
64 | IfStmt Expr Stmt Stmt
65 | Switch Expr [Case]
66 | While Expr Stmt
67 | Break (Maybe Name)
68 | Continue (Maybe Name)
69 | Labelled Name Stmt
70 | Try Stmt Name Stmt
71 | Throw Expr
72 | Return Expr
73 | Var Name Expr
74 | Vars [(Name, Expr)]
75 | FunctionStmt Name [Name] [Stmt]
78data Case
79 = Case Expr [Stmt]
80 | Default [Stmt]
84-- OPERATORS
87data InfixOp
88 = OpAdd -- +
89 | OpSub -- -
90 | OpMul -- *
91 | OpDiv -- /
92 | OpMod -- %
93 | OpEq -- ===
94 | OpNe -- !==
95 | OpLt -- <
96 | OpLe -- <=
97 | OpGt -- >
98 | OpGe -- >=
99 | OpAnd -- &&
100 | OpOr -- ||
101 | OpBitwiseAnd -- &
102 | OpBitwiseXor -- ^
103 | OpBitwiseOr -- |
104 | OpLShift -- <<
105 | OpSpRShift -- >>
106 | OpZfRShift -- >>>
109data PrefixOp
110 = PrefixNot -- !
111 | PrefixNegate -- -
112 | PrefixComplement -- ~
116-- ENCODE
119stmtToBuilder :: Stmt -> Builder
120stmtToBuilder stmts =
121 fromStmt "" stmts
124exprToBuilder :: Expr -> Builder
125exprToBuilder expr =
126 snd $ fromExpr "" Whatever expr
130-- HELPERS
133deeper :: Builder -> Builder
134deeper indent =
135 "\t" <> indent
138commaSep :: [Builder] -> Builder
139commaSep builders =
140 mconcat (List.intersperse ", " builders)
143commaNewlineSep :: Builder -> [Builder] -> Builder
144commaNewlineSep indent builders =
145 mconcat (List.intersperse (",\n" <> deeper indent) builders)
149-- STATEMENTS
152fromStmtBlock :: Builder -> [Stmt] -> Builder
153fromStmtBlock indent stmts =
154 mconcat (map (fromStmt indent) stmts)
157fromStmt :: Builder -> Stmt -> Builder
158fromStmt indent statement =
159 case statement of
160 Block stmts ->
161 fromStmtBlock indent stmts
163 EmptyStmt ->
164 mempty
166 ExprStmt expr ->
167 indent <> snd (fromExpr indent Whatever expr) <> ";\n"
169 IfStmt condition thenStmt elseStmt ->
170 mconcat
171 [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
172 , fromStmt (deeper indent) thenStmt
173 , indent, "} else {\n"
174 , fromStmt (deeper indent) elseStmt
175 , indent, "}\n"
176 ]
178 Switch expr clauses ->
179 mconcat
180 [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
181 , mconcat (map (fromClause (deeper indent)) clauses)
182 , indent, "}\n"
183 ]
185 While expr stmt ->
186 mconcat
187 [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
188 , fromStmt (deeper indent) stmt
189 , indent, "}\n"
190 ]
192 Break Nothing ->
193 indent <> "break;\n"
195 Break (Just label) ->
196 indent <> "break " <> Name.toBuilder label <> ";\n"
198 Continue Nothing ->
199 indent <> "continue;\n"
201 Continue (Just label) ->
202 indent <> "continue " <> Name.toBuilder label <> ";\n"
204 Labelled label stmt ->
205 mconcat
206 [ indent, Name.toBuilder label, ":\n"
207 , fromStmt indent stmt
208 ]
210 Try tryStmt errorName catchStmt ->
211 mconcat
212 [ indent, "try {\n"
213 , fromStmt (deeper indent) tryStmt
214 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
215 , fromStmt (deeper indent) catchStmt
216 , indent, "}\n"
217 ]
219 Throw expr ->
220 indent <> "throw " <> snd (fromExpr indent Whatever expr) <> ";"
222 Return expr ->
223 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
225 Var name expr ->
226 indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr) <> ";\n"
228 Vars [] ->
229 mempty
231 Vars vars ->
232 indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
234 FunctionStmt name args stmts ->
235 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
236 <>
237 fromStmtBlock (deeper indent) stmts
238 <>
239 indent <> "}\n"
243-- SWITCH CLAUSES
246fromClause :: Builder -> Case -> Builder
247fromClause indent clause =
248 case clause of
249 Case expr stmts ->
250 indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
251 <> fromStmtBlock (deeper indent) stmts
253 Default stmts ->
254 indent <> "default:\n"
255 <> fromStmtBlock (deeper indent) stmts
259-- VAR DECLS
262varToBuilder :: Builder -> (Name, Expr) -> Builder
263varToBuilder indent (name, expr) =
264 Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
268-- EXPRESSIONS
271data Lines = One | Many deriving (Eq)
274merge :: Lines -> Lines -> Lines
275merge a b =
276 if a == Many || b == Many then Many else One
279linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
280linesMap func xs =
281 let
282 pairs = map func xs
283 in
284 ( any ((==) Many . fst) pairs
285 , map snd pairs
286 )
289data Grouping = Atomic | Whatever
292parensFor :: Grouping -> Builder -> Builder
293parensFor grouping builder =
294 case grouping of
295 Atomic ->
296 "(" <> builder <> ")"
298 Whatever ->
299 builder
302fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
303fromExpr indent grouping expression =
304 case expression of
305 String string ->
306 (One, "'" <> string <> "'")
308 Float float ->
309 (One, float)
311 Int n ->
312 (One, B.intDec n)
314 Bool bool ->
315 (One, if bool then "true" else "false")
317 Null ->
318 (One, "null")
320 Json json ->
321 ( One, Json.encodeUgly json )
323 Array exprs ->
324 (,) Many $
325 let
326 (anyMany, builders) = linesMap (fromExpr indent Whatever) exprs
327 in
328 if anyMany then
329 "[\n"
330 <> deeper indent
331 <> commaNewlineSep indent builders
332 <> "\n" <> indent <> "]"
333 else
334 "[" <> commaSep builders <> "]"
336 Object fields ->
337 (,) Many $
338 let
339 deeperIndent = deeper indent
340 (anyMany, builders) = linesMap (fromField deeperIndent) fields
341 in
342 if anyMany then
343 "{\n"
344 <> deeperIndent
345 <> commaNewlineSep indent builders
346 <> "\n" <> indent <> "}"
347 else
348 "{" <> commaSep builders <> "}"
350 Ref name ->
351 (One, Name.toBuilder name)
353 Access expr field ->
354 makeDot indent expr field
356 Index expr bracketedExpr ->
357 makeBracketed indent expr bracketedExpr
359 Prefix op expr ->
360 let
361 (lines, builder) = fromExpr indent Atomic expr
362 in
363 ( lines
364 , parensFor grouping (fromPrefix op <> builder)
365 )
367 Infix op leftExpr rightExpr ->
368 let
369 (leftLines , left ) = fromExpr indent Atomic leftExpr
370 (rightLines, right) = fromExpr indent Atomic rightExpr
371 in
372 ( merge leftLines rightLines
373 , parensFor grouping (left <> fromInfix op <> right)
374 )
376 If condExpr thenExpr elseExpr ->
377 let
378 condB = snd (fromExpr indent Atomic condExpr)
379 thenB = snd (fromExpr indent Atomic thenExpr)
380 elseB = snd (fromExpr indent Atomic elseExpr)
381 in
382 ( Many
383 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
384 )
386 Assign lValue expr ->
387 let
388 (leftLines , left ) = fromLValue indent lValue
389 (rightLines, right) = fromExpr indent Whatever expr
390 in
391 ( merge leftLines rightLines
392 , parensFor grouping (left <> " = " <> right)
393 )
395 Call function args ->
396 (,) Many $
397 let
398 deeperIndent = deeper indent
399 funcB = snd (fromExpr indent Atomic function)
400 (anyMany, argsB) = linesMap (fromExpr deeperIndent Whatever) args
401 in
402 if anyMany then
403 funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
404 else
405 funcB <> "(" <> commaSep argsB <> ")"
407 Function maybeName args stmts ->
408 (,) Many $
409 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
410 <>
411 fromStmtBlock (deeper indent) stmts
412 <>
413 indent <> "}"
417-- FIELDS
420fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
421fromField indent (field, expr) =
422 let
423 (lines, builder) = fromExpr indent Whatever expr
424 in
425 ( lines
426 , Name.toBuilder field <> ": " <> builder
427 )
431-- VALUES
434fromLValue :: Builder -> LValue -> (Lines, Builder)
435fromLValue indent lValue =
436 case lValue of
437 LRef name ->
438 (One, Name.toBuilder name)
440 LDot expr field ->
441 makeDot indent expr field
443 LBracket expr bracketedExpr ->
444 makeBracketed indent expr bracketedExpr
447makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
448makeDot indent expr field =
449 let
450 (lines, builder) = fromExpr indent Atomic expr
451 in
452 (lines, builder <> "." <> Name.toBuilder field)
455makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
456makeBracketed indent expr bracketedExpr =
457 let
458 (lines , builder ) = fromExpr indent Atomic expr
459 (bracketedLines, bracketedBuilder) = fromExpr indent Whatever bracketedExpr
460 in
461 ( merge lines bracketedLines
462 , builder <> "[" <> bracketedBuilder <> "]"
463 )
467-- OPERATORS
470fromPrefix :: PrefixOp -> Builder
471fromPrefix op =
472 case op of
473 PrefixNot -> "!"
474 PrefixNegate -> "-"
475 PrefixComplement -> "~"
478fromInfix :: InfixOp -> Builder
479fromInfix op =
480 case op of
481 OpAdd -> " + "
482 OpSub -> " - "
483 OpMul -> " * "
484 OpDiv -> " / "
485 OpMod -> " % "
486 OpEq -> " === "
487 OpNe -> " !== "
488 OpLt -> " < "
489 OpLe -> " <= "
490 OpGt -> " > "
491 OpGe -> " >= "
492 OpAnd -> " && "
493 OpOr -> " || "
494 OpBitwiseAnd -> " & "
495 OpBitwiseXor -> " ^ "
496 OpBitwiseOr -> " | "
497 OpLShift -> " << "
498 OpSpRShift -> " >> "
499 OpZfRShift -> " >>> "