git.iko.soy/elk
on 82b3bd0 help sign in
elk/compiler/src/Generate/JavaScript/Builder.hs
517 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 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
31data Expr
32 = String Builder
33 | Float Builder
34 | Int Int
35 | Bool Bool
36 | Null
37 | Json Json.Value
38 | Array [Expr]
39 | Object [(Name, Expr)]
40 | Ref Name
41 | Access Expr Name -- foo.bar
42 | Index Expr Expr -- foo[bar]
43 | Prefix PrefixOp Expr
44 | Infix InfixOp Expr Expr
45 | If Expr Expr Expr
46 | Assign LValue Expr
47 | Call Expr [Expr]
48 | Function (Maybe Name) [Name] [Stmt]
51data LValue
52 = LRef Name
53 | LDot Expr Name
54 | LBracket Expr Expr
58-- STATEMENTS
61data Stmt
62 = Block [Stmt]
63 | EmptyStmt
64 | ExprStmt Expr
65 | IfStmt Expr Stmt Stmt
66 | Switch Expr [Case]
67 | While Expr Stmt
68 | Break (Maybe Name)
69 | Continue (Maybe Name)
70 | Labelled Name Stmt
71 | Try Stmt Name Stmt
72 | Throw Expr
73 | Return Expr
74 | Var Name Expr
75 | Vars [(Name, Expr)]
76 | FunctionStmt Name [Name] [Stmt]
79data Case
80 = Case Expr [Stmt]
81 | Default [Stmt]
85-- OPERATORS
88data InfixOp
89 = OpAdd -- +
90 | OpSub -- -
91 | OpMul -- *
92 | OpDiv -- /
93 | OpMod -- %
94 | OpEq -- ===
95 | OpNe -- !==
96 | OpLt -- <
97 | OpLe -- <=
98 | OpGt -- >
99 | OpGe -- >=
100 | OpAnd -- &&
101 | OpOr -- ||
102 | OpBitwiseAnd -- &
103 | OpBitwiseXor -- ^
104 | OpBitwiseOr -- |
105 | OpLShift -- <<
106 | OpSpRShift -- >>
107 | OpZfRShift -- >>>
110data PrefixOp
111 = PrefixNot -- !
112 | PrefixNegate -- -
113 | PrefixComplement -- ~
117-- ENCODE
120stmtToBuilder :: Stmt -> Builder
121stmtToBuilder stmts =
122 fromStmt levelZero stmts
125exprToBuilder :: Expr -> Builder
126exprToBuilder expr =
127 snd $ fromExpr levelZero Whatever expr
131-- INDENT LEVEL
134data Level =
135 Level Builder Level
138levelZero :: Level
139levelZero =
140 Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
143makeLevel :: Int -> BS.ByteString -> Level
144makeLevel level oldTabs =
145 let
146 tabs =
147 if level <= BS.length oldTabs
148 then oldTabs
149 else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
150 in
151 Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)
155-- HELPERS
158commaSep :: [Builder] -> Builder
159commaSep builders =
160 mconcat (List.intersperse ", " builders)
163commaNewlineSep :: Level -> [Builder] -> Builder
164commaNewlineSep (Level _ (Level deeperIndent _)) builders =
165 mconcat (List.intersperse (",\n" <> deeperIndent) builders)
169-- STATEMENTS
172fromStmtBlock :: Level -> [Stmt] -> Builder
173fromStmtBlock level stmts =
174 mconcat (map (fromStmt level) stmts)
177fromStmt :: Level -> Stmt -> Builder
178fromStmt level@(Level indent nextLevel) statement =
179 case statement of
180 Block stmts ->
181 fromStmtBlock level stmts
183 EmptyStmt ->
184 mempty
186 ExprStmt expr ->
187 indent <> snd (fromExpr level Whatever expr) <> ";\n"
189 IfStmt condition thenStmt elseStmt ->
190 mconcat
191 [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
192 , fromStmt nextLevel thenStmt
193 , indent, "} else {\n"
194 , fromStmt nextLevel elseStmt
195 , indent, "}\n"
196 ]
198 Switch expr clauses ->
199 mconcat
200 [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
201 , mconcat (map (fromClause nextLevel) clauses)
202 , indent, "}\n"
203 ]
205 While expr stmt ->
206 mconcat
207 [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
208 , fromStmt nextLevel stmt
209 , indent, "}\n"
210 ]
212 Break Nothing ->
213 indent <> "break;\n"
215 Break (Just label) ->
216 indent <> "break " <> Name.toBuilder label <> ";\n"
218 Continue Nothing ->
219 indent <> "continue;\n"
221 Continue (Just label) ->
222 indent <> "continue " <> Name.toBuilder label <> ";\n"
224 Labelled label stmt ->
225 mconcat
226 [ indent, Name.toBuilder label, ":\n"
227 , fromStmt level stmt
228 ]
230 Try tryStmt errorName catchStmt ->
231 mconcat
232 [ indent, "try {\n"
233 , fromStmt nextLevel tryStmt
234 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
235 , fromStmt nextLevel catchStmt
236 , indent, "}\n"
237 ]
239 Throw expr ->
240 indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
242 Return expr ->
243 indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
245 Var name expr ->
246 indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
248 Vars [] ->
249 mempty
251 Vars vars ->
252 indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
254 FunctionStmt name args stmts ->
255 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
256 <>
257 fromStmtBlock nextLevel stmts
258 <>
259 indent <> "}\n"
263-- SWITCH CLAUSES
266fromClause :: Level -> Case -> Builder
267fromClause level@(Level indent nextLevel) clause =
268 case clause of
269 Case expr stmts ->
270 indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
271 <> fromStmtBlock nextLevel stmts
273 Default stmts ->
274 indent <> "default:\n"
275 <> fromStmtBlock nextLevel stmts
279-- VAR DECLS
282varToBuilder :: Level -> (Name, Expr) -> Builder
283varToBuilder level (name, expr) =
284 Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
288-- EXPRESSIONS
291data Lines = One | Many deriving (Eq)
294merge :: Lines -> Lines -> Lines
295merge a b =
296 if a == Many || b == Many then Many else One
299linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
300linesMap func xs =
301 let
302 pairs = map func xs
303 in
304 ( any ((==) Many . fst) pairs
305 , map snd pairs
306 )
309data Grouping = Atomic | Whatever
312parensFor :: Grouping -> Builder -> Builder
313parensFor grouping builder =
314 case grouping of
315 Atomic ->
316 "(" <> builder <> ")"
318 Whatever ->
319 builder
322fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
323fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
324 case expression of
325 String string ->
326 ( One, "'" <> string <> "'" )
328 Float float ->
329 ( One, float )
331 Int n ->
332 ( One, B.intDec n )
334 Bool bool ->
335 ( One, if bool then "true" else "false" )
337 Null ->
338 ( One, "null" )
340 Json json ->
341 ( One, Json.encodeUgly json )
343 Array exprs ->
344 (,) Many $
345 let
346 (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
347 in
348 if anyMany then
349 "[\n"
350 <> deeperIndent
351 <> commaNewlineSep level builders
352 <> "\n" <> indent <> "]"
353 else
354 "[" <> commaSep builders <> "]"
356 Object fields ->
357 (,) Many $
358 let
359 (anyMany, builders) = linesMap (fromField nextLevel) fields
360 in
361 if anyMany then
362 "{\n"
363 <> deeperIndent
364 <> commaNewlineSep level builders
365 <> "\n" <> indent <> "}"
366 else
367 "{" <> commaSep builders <> "}"
369 Ref name ->
370 ( One, Name.toBuilder name )
372 Access expr field ->
373 makeDot level expr field
375 Index expr bracketedExpr ->
376 makeBracketed level expr bracketedExpr
378 Prefix op expr ->
379 let
380 (lines, builder) = fromExpr level Atomic expr
381 in
382 ( lines
383 , parensFor grouping (fromPrefix op <> builder)
384 )
386 Infix op leftExpr rightExpr ->
387 let
388 (leftLines , left ) = fromExpr level Atomic leftExpr
389 (rightLines, right) = fromExpr level Atomic rightExpr
390 in
391 ( merge leftLines rightLines
392 , parensFor grouping (left <> fromInfix op <> right)
393 )
395 If condExpr thenExpr elseExpr ->
396 let
397 condB = snd (fromExpr level Atomic condExpr)
398 thenB = snd (fromExpr level Atomic thenExpr)
399 elseB = snd (fromExpr level Atomic elseExpr)
400 in
401 ( Many
402 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
403 )
405 Assign lValue expr ->
406 let
407 (leftLines , left ) = fromLValue level lValue
408 (rightLines, right) = fromExpr level Whatever expr
409 in
410 ( merge leftLines rightLines
411 , parensFor grouping (left <> " = " <> right)
412 )
414 Call function args ->
415 (,) Many $
416 let
417 (_ , funcB) = fromExpr level Atomic function
418 (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
419 in
420 if anyMany then
421 funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
422 else
423 funcB <> "(" <> commaSep argsB <> ")"
425 Function maybeName args stmts ->
426 (,) Many $
427 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
428 <>
429 fromStmtBlock nextLevel stmts
430 <>
431 indent <> "}"
435-- FIELDS
438fromField :: Level -> (Name, Expr) -> (Lines, Builder)
439fromField level (field, expr) =
440 let
441 (lines, builder) = fromExpr level Whatever expr
442 in
443 ( lines
444 , Name.toBuilder field <> ": " <> builder
445 )
449-- VALUES
452fromLValue :: Level -> LValue -> (Lines, Builder)
453fromLValue level lValue =
454 case lValue of
455 LRef name ->
456 (One, Name.toBuilder name)
458 LDot expr field ->
459 makeDot level expr field
461 LBracket expr bracketedExpr ->
462 makeBracketed level expr bracketedExpr
465makeDot :: Level -> Expr -> Name -> (Lines, Builder)
466makeDot level expr field =
467 let
468 (lines, builder) = fromExpr level Atomic expr
469 in
470 (lines, builder <> "." <> Name.toBuilder field)
473makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
474makeBracketed level expr bracketedExpr =
475 let
476 (lines , builder ) = fromExpr level Atomic expr
477 (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
478 in
479 ( merge lines bracketedLines
480 , builder <> "[" <> bracketedBuilder <> "]"
481 )
485-- OPERATORS
488fromPrefix :: PrefixOp -> Builder
489fromPrefix op =
490 case op of
491 PrefixNot -> "!"
492 PrefixNegate -> "-"
493 PrefixComplement -> "~"
496fromInfix :: InfixOp -> Builder
497fromInfix op =
498 case op of
499 OpAdd -> " + "
500 OpSub -> " - "
501 OpMul -> " * "
502 OpDiv -> " / "
503 OpMod -> " % "
504 OpEq -> " === "
505 OpNe -> " !== "
506 OpLt -> " < "
507 OpLe -> " <= "
508 OpGt -> " > "
509 OpGe -> " >= "
510 OpAnd -> " && "
511 OpOr -> " || "
512 OpBitwiseAnd -> " & "
513 OpBitwiseXor -> " ^ "
514 OpBitwiseOr -> " | "
515 OpLShift -> " << "
516 OpSpRShift -> " >> "
517 OpZfRShift -> " >>> "