git.iko.soy/elk
on 5ee219e help sign in
elk/compiler/src/Generate/JavaScript/Builder.hs
502 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 = 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 float ->
312 (One, float)
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 Json json ->
324 ( One, Json.encodeUgly json )
326 Array exprs ->
327 (,) Many $
328 let
329 (anyMany, builders) = linesMap (fromExpr indent Whatever) exprs
330 in
331 if anyMany then
332 "[\n"
333 <> deeper indent
334 <> commaNewlineSep indent builders
335 <> "\n" <> indent <> "]"
336 else
337 "[" <> commaSep builders <> "]"
339 Object fields ->
340 (,) Many $
341 let
342 deeperIndent = deeper indent
343 (anyMany, builders) = linesMap (fromField deeperIndent) fields
344 in
345 if anyMany then
346 "{\n"
347 <> deeperIndent
348 <> commaNewlineSep indent builders
349 <> "\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) = fromExpr indent Atomic expr
365 in
366 ( lines
367 , parensFor grouping (fromPrefix op <> builder)
368 )
370 Infix op leftExpr rightExpr ->
371 let
372 (leftLines , left ) = fromExpr indent Atomic leftExpr
373 (rightLines, right) = fromExpr indent Atomic rightExpr
374 in
375 ( merge leftLines rightLines
376 , parensFor grouping (left <> fromInfix op <> right)
377 )
379 If condExpr thenExpr elseExpr ->
380 let
381 condB = snd (fromExpr indent Atomic condExpr)
382 thenB = snd (fromExpr indent Atomic thenExpr)
383 elseB = snd (fromExpr indent Atomic elseExpr)
384 in
385 ( Many
386 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
387 )
389 Assign lValue expr ->
390 let
391 (leftLines , left ) = fromLValue indent lValue
392 (rightLines, right) = fromExpr indent Whatever expr
393 in
394 ( merge leftLines rightLines
395 , parensFor grouping (left <> " = " <> right)
396 )
398 Call function args ->
399 (,) Many $
400 let
401 deeperIndent = deeper indent
402 funcB = snd (fromExpr indent Atomic function)
403 (anyMany, argsB) = linesMap (fromExpr deeperIndent Whatever) args
404 in
405 if anyMany then
406 funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
407 else
408 funcB <> "(" <> commaSep argsB <> ")"
410 Function maybeName args stmts ->
411 (,) Many $
412 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
413 <>
414 fromStmtBlock (deeper indent) stmts
415 <>
416 indent <> "}"
420-- FIELDS
423fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
424fromField indent (field, expr) =
425 let
426 (lines, builder) = fromExpr indent Whatever expr
427 in
428 ( lines
429 , Name.toBuilder field <> ": " <> builder
430 )
434-- VALUES
437fromLValue :: Builder -> LValue -> (Lines, Builder)
438fromLValue indent lValue =
439 case lValue of
440 LRef name ->
441 (One, Name.toBuilder name)
443 LDot expr field ->
444 makeDot indent expr field
446 LBracket expr bracketedExpr ->
447 makeBracketed indent expr bracketedExpr
450makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
451makeDot indent expr field =
452 let
453 (lines, builder) = fromExpr indent Atomic expr
454 in
455 (lines, builder <> "." <> Name.toBuilder field)
458makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
459makeBracketed indent expr bracketedExpr =
460 let
461 (lines , builder ) = fromExpr indent Atomic expr
462 (bracketedLines, bracketedBuilder) = fromExpr indent Whatever bracketedExpr
463 in
464 ( merge lines bracketedLines
465 , builder <> "[" <> bracketedBuilder <> "]"
466 )
470-- OPERATORS
473fromPrefix :: PrefixOp -> Builder
474fromPrefix op =
475 case op of
476 PrefixNot -> "!"
477 PrefixNegate -> "-"
478 PrefixComplement -> "~"
481fromInfix :: InfixOp -> Builder
482fromInfix op =
483 case op of
484 OpAdd -> " + "
485 OpSub -> " - "
486 OpMul -> " * "
487 OpDiv -> " / "
488 OpMod -> " % "
489 OpEq -> " === "
490 OpNe -> " !== "
491 OpLt -> " < "
492 OpLe -> " <= "
493 OpGt -> " > "
494 OpGe -> " >= "
495 OpAnd -> " && "
496 OpOr -> " || "
497 OpBitwiseAnd -> " & "
498 OpBitwiseXor -> " ^ "
499 OpBitwiseOr -> " | "
500 OpLShift -> " << "
501 OpSpRShift -> " >> "
502 OpZfRShift -> " >>> "