git.iko.soy/elk
on 90fc530 help sign in
elk/compiler/src/Generate/JavaScript/Builder.hs
527 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 (Maybe 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 "throw " <> snd (fromExpr indent Whatever expr) <> ";"
222 Return Nothing ->
223 indent <> "return;\n"
225 Return (Just expr) ->
226 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
228 Var name expr ->
229 indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr) <> ";\n"
231 Vars [] ->
232 mempty
234 Vars vars ->
235 indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
237 FunctionStmt name args stmts ->
238 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
239 <>
240 fromStmtBlock (deeper indent) stmts
241 <>
242 indent <> "}\n"
246-- SWITCH CLAUSES
249fromClause :: Builder -> Case -> Builder
250fromClause indent clause =
251 case clause of
252 Case expr stmts ->
253 indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
254 <> fromStmtBlock (deeper indent) stmts
256 Default stmts ->
257 indent <> "default:\n"
258 <> fromStmtBlock (deeper indent) stmts
262-- VAR DECLS
265varToBuilder :: Builder -> (Name, Expr) -> Builder
266varToBuilder indent (name, expr) =
267 Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
271-- EXPRESSIONS
274data Lines = One | Many deriving (Eq)
277merge :: Lines -> Lines -> Lines
278merge a b =
279 if a == Many || b == Many then Many else One
282linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
283linesMap func xs =
284 let
285 pairs =
286 map func xs
287 in
288 ( any ((==) Many . fst) pairs
289 , map snd pairs
290 )
293data Grouping = Atomic | Whatever
296parensFor :: Grouping -> Builder -> Builder
297parensFor grouping builder =
298 case grouping of
299 Atomic ->
300 "(" <> builder <> ")"
302 Whatever ->
303 builder
306fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
307fromExpr indent grouping expression =
308 case expression of
309 String string ->
310 (One, "'" <> string <> "'")
312 Float float ->
313 (One, float)
315 Int n ->
316 (One, B.intDec n)
318 Bool bool ->
319 (One, if bool then "true" else "false")
321 Null ->
322 (One, "null")
324 Json json ->
325 ( One, Json.encodeUgly json )
327 Array exprs ->
328 (,) Many $
329 let
330 (anyMany, builders) =
331 linesMap (fromExpr indent Whatever) exprs
332 in
333 if anyMany then
334 "[\n"
335 <> deeper indent
336 <> commaNewlineSep indent builders
337 <> "\n" <> indent <> "]"
339 else
340 "[" <> commaSep builders <> "]"
342 Object fields ->
343 (,) Many $
344 let
345 deeperIndent =
346 deeper indent
348 (anyMany, builders) =
349 linesMap (fromField deeperIndent) fields
350 in
351 if anyMany then
352 "{\n"
353 <> deeperIndent
354 <> commaNewlineSep indent builders
355 <> "\n" <> indent <> "}"
357 else
358 "{" <> commaSep builders <> "}"
360 Ref name ->
361 (One, Name.toBuilder name)
363 Access expr field ->
364 makeDot indent expr field
366 Index expr bracketedExpr ->
367 makeBracketed indent expr bracketedExpr
369 Prefix op expr ->
370 let
371 (lines, builder) =
372 fromExpr indent Atomic expr
373 in
374 ( lines
375 , parensFor grouping (fromPrefix op <> builder)
376 )
378 Infix op leftExpr rightExpr ->
379 let
380 (leftLines, left) =
381 fromExpr indent Atomic leftExpr
383 (rightLines, right) =
384 fromExpr indent Atomic rightExpr
385 in
386 ( merge leftLines rightLines
387 , parensFor grouping (left <> fromInfix op <> right)
388 )
390 If condExpr thenExpr elseExpr ->
391 let
392 condB = snd (fromExpr indent Atomic condExpr)
393 thenB = snd (fromExpr indent Atomic thenExpr)
394 elseB = snd (fromExpr indent Atomic elseExpr)
395 in
396 ( Many
397 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
398 )
400 Assign lValue expr ->
401 let
402 (leftLines, left) =
403 fromLValue indent lValue
405 (rightLines, right) =
406 fromExpr indent Whatever expr
407 in
408 ( merge leftLines rightLines
409 , parensFor grouping (left <> " = " <> right)
410 )
412 Call function args ->
413 (,) Many $
414 let
415 deeperIndent =
416 deeper indent
418 funcB =
419 snd (fromExpr indent Atomic function)
421 (anyMany, argsB) =
422 linesMap (fromExpr deeperIndent Whatever) args
423 in
424 if anyMany then
425 funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
427 else
428 funcB <> "(" <> commaSep argsB <> ")"
430 Function maybeName args stmts ->
431 (,) Many $
432 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
433 <>
434 fromStmtBlock (deeper indent) stmts
435 <>
436 indent <> "}"
440-- FIELDS
443fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
444fromField indent (field, expr) =
445 let
446 (lines, builder) =
447 fromExpr indent Whatever expr
448 in
449 ( lines
450 , Name.toBuilder field <> ": " <> builder
451 )
455-- VALUES
458fromLValue :: Builder -> LValue -> (Lines, Builder)
459fromLValue indent lValue =
460 case lValue of
461 LRef name ->
462 (One, Name.toBuilder name)
464 LDot expr field ->
465 makeDot indent expr field
467 LBracket expr bracketedExpr ->
468 makeBracketed indent expr bracketedExpr
471makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
472makeDot indent expr field =
473 let
474 (lines, builder) =
475 fromExpr indent Atomic expr
476 in
477 (lines, builder <> "." <> Name.toBuilder field)
480makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
481makeBracketed indent expr bracketedExpr =
482 let
483 (lines, builder) =
484 fromExpr indent Atomic expr
486 (bracketedLines, bracketedBuilder) =
487 fromExpr indent Whatever bracketedExpr
488 in
489 ( merge lines bracketedLines
490 , builder <> "[" <> bracketedBuilder <> "]"
491 )
495-- OPERATORS
498fromPrefix :: PrefixOp -> Builder
499fromPrefix op =
500 case op of
501 PrefixNot -> "!"
502 PrefixNegate -> "-"
503 PrefixComplement -> "~"
506fromInfix :: InfixOp -> Builder
507fromInfix op =
508 case op of
509 OpAdd -> " + "
510 OpSub -> " - "
511 OpMul -> " * "
512 OpDiv -> " / "
513 OpMod -> " % "
514 OpEq -> " === "
515 OpNe -> " !== "
516 OpLt -> " < "
517 OpLe -> " <= "
518 OpGt -> " > "
519 OpGe -> " >= "
520 OpAnd -> " && "
521 OpOr -> " || "
522 OpBitwiseAnd -> " & "
523 OpBitwiseXor -> " ^ "
524 OpBitwiseOr -> " | "
525 OpLShift -> " << "
526 OpSpRShift -> " >> "
527 OpZfRShift -> " >>> "