git.iko.soy/elk
on c5da7c0 help sign in
elk/src/Generate/JavaScript/Builder.hs
612 lines 13 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript.Builder
4 ( Expr(..), Id(..), Prop(..), LValue(..)
5 , Stmt(..), Case(..), VarDecl(..)
6 , InfixOp(..), AssignOp(..), PrefixOp(..)
7 , stmtsToText
8 )
9 where
11-- Based on the language-ecmascript package.
12-- https://hackage.haskell.org/package/language-ecmascript
13-- They did the hard work of reading the spec to figure out
14-- how all the types should fit together.
16import Prelude hiding (lines)
17import qualified Data.List as List
18import Data.Monoid ((<>))
19import Data.Text (Text)
20import Data.Text.Lazy.Builder
21import Data.Text.Lazy.Builder.Int (decimal)
22import Data.Text.Lazy.Builder.RealFloat (realFloat)
23import qualified Data.Text.Lazy as LazyText
27-- EXPRESSIONS
30data Expr
31 = String Text
32 | Float Double
33 | Int Int
34 | Bool Bool
35 | Null
36 | Array [Expr]
37 | Object [(Prop, Expr)]
38 | VarRef Id
39 | DotRef Expr Id -- ^ @foo.bar@, spec 11.2.1
40 | BracketRef Expr Expr -- ^ @foo[bar]@, spec 11.2.1
41 | Prefix PrefixOp Expr
42 | Infix InfixOp Expr Expr
43 | If Expr Expr Expr
44 | Assign AssignOp LValue Expr
45 | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
46 | Function (Maybe Id) [Id] [Stmt]
49newtype Id = Id Text
52data Prop
53 = StringProp Text
54 | IntProp Int
55 | IdProp Id
58data LValue
59 = LVar Text
60 | LDot Expr Text
61 | LBracket Expr Expr
65-- STATEMENTS
68data Stmt
69 = Block [Stmt] -- {stmts}
70 | EmptyStmt -- ;
71 | ExprStmt Expr -- expr;
72 | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
73 | IfSingleStmt Expr Stmt -- if (e) stmt
74 | Switch Expr [Case] -- switch (e) clauses
75 | While Expr Stmt -- while (e) do stmt
76 | DoWhile Stmt Expr -- do stmt while (e);
77 | Break (Maybe Id) -- break lab;
78 | Continue (Maybe Id) -- continue lab;
79 | Labelled Id Stmt -- lab: stmt
80 | Return (Maybe Expr) -- return expr;
81 | VarDeclStmt [VarDecl] -- var x, y=42;
82 | FunctionStmt Id [Id] [Stmt] -- function f(x, y, z) {...}
85data Case
86 = Case Expr [Stmt]
87 | Default [Stmt]
90data VarDecl = VarDecl Id (Maybe Expr)
94-- OPERATORS
97data InfixOp
98 = OpLT -- <
99 | OpLEq -- <=
100 | OpGT -- >
101 | OpGEq -- >=
102 | OpIn -- in
103 | OpInstanceof -- instanceof
104 | OpEq -- ==
105 | OpNEq -- !=
106 | OpStrictEq -- ===
107 | OpStrictNEq -- !===
108 | OpLAnd -- &&
109 | OpLOr -- ||
110 | OpMul -- *
111 | OpDiv -- /
112 | OpMod -- %
113 | OpSub -- -
114 | OpLShift -- <<
115 | OpSpRShift -- >>
116 | OpZfRShift -- >>>
117 | OpBAnd -- &
118 | OpBXor -- ^
119 | OpBOr -- |
120 | OpAdd -- +
123data AssignOp
124 = OpAssign -- =
125 | OpAssignAdd -- +=
126 | OpAssignSub -- -=
127 | OpAssignMul -- *=
128 | OpAssignDiv -- /=
129 | OpAssignMod -- %=
130 | OpAssignLShift -- <<=
131 | OpAssignSpRShift -- >>=
132 | OpAssignZfRShift -- >>>=
133 | OpAssignBAnd -- &=
134 | OpAssignBXor -- ^=
135 | OpAssignBOr -- |=
138data PrefixOp
139 = PrefixLNot -- !
140 | PrefixBNot -- ~
141 | PrefixPlus -- +
142 | PrefixMinus -- -
143 | PrefixTypeof -- typeof
144 | PrefixVoid -- void
145 | PrefixDelete -- delete
149-- CONVERT TO LAZY TEXT
152stmtsToText :: [Stmt] -> LazyText.Text
153stmtsToText stmts =
154 toLazyText (fromStmtBlock "" stmts)
158-- HELPERS
161deeper :: Builder -> Builder
162deeper indent =
163 "\t" <> indent
166commaSep :: [Builder] -> Builder
167commaSep builders =
168 mconcat (List.intersperse ", " builders)
171commaNewlineSep :: Builder -> [Builder] -> Builder
172commaNewlineSep indent builders =
173 mconcat (List.intersperse (",\n" <> deeper indent) builders)
177-- STATEMENTS
180fromStmtBlock :: Builder -> [Stmt] -> Builder
181fromStmtBlock indent stmts =
182 mconcat (map (fromStmt indent) stmts)
185fromStmt :: Builder -> Stmt -> Builder
186fromStmt indent statement =
187 case statement of
188 Block stmts ->
189 fromStmtBlock indent stmts
191 EmptyStmt ->
192 mempty
194 ExprStmt expr ->
195 indent <> snd (fromExpr indent Whatever expr) <> ";\n"
197 IfStmt condition thenStmt elseStmt ->
198 mconcat
199 [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
200 , fromStmt (deeper indent) thenStmt
201 , indent, "} else {\n"
202 , fromStmt (deeper indent) elseStmt
203 , indent, "}\n"
204 ]
206 IfSingleStmt condition thenStmt ->
207 mconcat
208 [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
209 , fromStmt (deeper indent) thenStmt
210 , indent, "}\n"
211 ]
213 Switch expr clauses ->
214 mconcat
215 [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
216 , mconcat (map (fromClause (deeper indent)) clauses)
217 , indent, "}\n"
218 ]
220 While expr stmt ->
221 mconcat
222 [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
223 , fromStmt (deeper indent) stmt
224 , indent, "}\n"
225 ]
227 DoWhile stmt expr ->
228 mconcat
229 [ indent, "do {\n"
230 , fromStmt (deeper indent) stmt
231 , indent, "} while(", snd (fromExpr indent Whatever expr), ");\n"
232 ]
234 Break Nothing ->
235 indent <> "break;\n"
237 Break (Just label) ->
238 indent <> "break " <> fromId label <> ";\n"
240 Continue Nothing ->
241 indent <> "continue;\n"
243 Continue (Just label) ->
244 indent <> "continue " <> fromId label <> ";\n"
246 Labelled label stmt ->
247 mconcat
248 [ indent, fromId label, ":\n"
249 , fromStmt indent stmt
250 ]
252 Return Nothing ->
253 indent <> "return;\n"
255 Return (Just expr) ->
256 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
258 VarDeclStmt [] ->
259 mempty
261 VarDeclStmt decls ->
262 indent <> "var " <> commaNewlineSep indent (map (fromVarDecl indent) decls) <> ";\n"
264 FunctionStmt name args stmts ->
265 indent <> "function " <> fromId name <> "(" <> commaSep (map fromId args) <> ") {\n"
266 <>
267 fromStmtBlock (deeper indent) stmts
268 <>
269 indent <> "}\n"
273-- SWITCH CLAUSES
276fromClause :: Builder -> Case -> Builder
277fromClause indent clause =
278 case clause of
279 Case expr stmts ->
280 indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
281 <> fromStmtBlock (deeper indent) stmts
283 Default stmts ->
284 indent <> "default:\n"
285 <> fromStmtBlock (deeper indent) stmts
289-- ID
292fromId :: Id -> Builder
293fromId (Id name) =
294 fromText name
298-- VAR DECLS
301fromVarDecl :: Builder -> VarDecl -> Builder
302fromVarDecl indent (VarDecl (Id name) maybeExpr) =
303 case maybeExpr of
304 Nothing ->
305 fromText name
307 Just expr ->
308 fromText name <> " = " <> snd (fromExpr indent Whatever expr)
312-- EXPRESSIONS
315data Lines = One | Many deriving (Eq)
318merge :: Lines -> Lines -> Lines
319merge a b =
320 if a == Many || b == Many then Many else One
323linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
324linesMap func xs =
325 let
326 pairs =
327 map func xs
328 in
329 ( any ((==) Many . fst) pairs
330 , map snd pairs
331 )
334data Grouping = Atomic | Whatever
337parensFor :: Grouping -> Builder -> Builder
338parensFor grouping builder =
339 case grouping of
340 Atomic ->
341 "(" <> builder <> ")"
343 Whatever ->
344 builder
347fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
348fromExpr indent grouping expression =
349 case expression of
350 String string ->
351 (One, quoted string)
353 Float n ->
354 (One, realFloat n)
356 Int n ->
357 (One, decimal n)
359 Bool bool ->
360 (One, if bool then "true" else "false")
362 Null ->
363 (One, "null")
365 Array exprs ->
366 (,) Many $
367 let
368 (anyMany, builders) =
369 linesMap (fromExpr indent Whatever) exprs
370 in
371 if anyMany then
372 "[\n"
373 <> deeper indent
374 <> commaNewlineSep indent builders
375 <> "\n" <> indent <> "]"
377 else
378 "[" <> commaSep builders <> "]"
380 Object fields ->
381 (,) Many $
382 let
383 deeperIndent =
384 deeper indent
386 (anyMany, builders) =
387 linesMap (fromField deeperIndent) fields
388 in
389 if anyMany then
390 "{\n"
391 <> deeperIndent
392 <> commaNewlineSep indent builders
393 <> "\n" <> indent <> "}"
395 else
396 "{" <> commaSep builders <> "}"
398 VarRef name ->
399 (One, fromId name)
401 DotRef expr (Id name) ->
402 makeDot indent expr name
404 BracketRef expr bracketedExpr ->
405 makeBracketed indent expr bracketedExpr
407 Prefix op expr ->
408 let
409 (lines, builder) =
410 fromExpr indent Atomic expr
411 in
412 ( lines
413 , parensFor grouping (fromPrefix op <> builder)
414 )
416 Infix op leftExpr rightExpr ->
417 let
418 (leftLines, left) =
419 fromExpr indent Atomic leftExpr
421 (rightLines, right) =
422 fromExpr indent Atomic rightExpr
423 in
424 ( merge leftLines rightLines
425 , parensFor grouping (left <> fromInfix op <> right)
426 )
428 If condExpr thenExpr elseExpr ->
429 let
430 condB = snd (fromExpr indent Atomic condExpr)
431 thenB = snd (fromExpr indent Atomic thenExpr)
432 elseB = snd (fromExpr indent Atomic elseExpr)
433 in
434 ( Many
435 , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
436 )
438 Assign op lValue expr ->
439 let
440 (leftLines, left) =
441 fromLValue indent lValue
443 (rightLines, right) =
444 fromExpr indent Whatever expr
445 in
446 ( merge leftLines rightLines
447 , parensFor grouping (left <> fromAssign op <> right)
448 )
450 Call function args ->
451 (,) Many $
452 let
453 deeperIndent =
454 deeper indent
456 funcB =
457 snd (fromExpr indent Atomic function)
459 (anyMany, argsB) =
460 linesMap (fromExpr deeperIndent Whatever) args
461 in
462 if anyMany then
463 funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
465 else
466 funcB <> "(" <> commaSep argsB <> ")"
468 Function maybeName args stmts ->
469 (,) Many $
470 "function " <> maybe mempty fromId maybeName <> "(" <> commaSep (map fromId args) <> ") {\n"
471 <>
472 fromStmtBlock (deeper indent) stmts
473 <>
474 indent <> "}"
478-- FIELDS
481fromField :: Builder -> (Prop, Expr) -> (Lines, Builder)
482fromField indent (prop, expr) =
483 let
484 (lines, builder) =
485 fromExpr indent Whatever expr
486 in
487 ( lines
488 , fromProp prop <> ": " <> builder
489 )
492fromProp :: Prop -> Builder
493fromProp prop =
494 case prop of
495 IdProp name ->
496 fromId name
498 StringProp string ->
499 quoted string
501 IntProp n ->
502 decimal n
506-- STRINGS
509quoted :: Text -> Builder
510quoted str =
511 "'" <> fromText str <> "'"
515-- VALUES
518fromLValue :: Builder -> LValue -> (Lines, Builder)
519fromLValue indent lValue =
520 case lValue of
521 LVar name ->
522 (One, fromText name)
524 LDot expr field ->
525 makeDot indent expr field
527 LBracket expr bracketedExpr ->
528 makeBracketed indent expr bracketedExpr
531makeDot :: Builder -> Expr -> Text -> (Lines, Builder)
532makeDot indent expr field =
533 let
534 (lines, builder) =
535 fromExpr indent Atomic expr
536 in
537 (lines, builder <> "." <> fromText field)
540makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
541makeBracketed indent expr bracketedExpr =
542 let
543 (lines, builder) =
544 fromExpr indent Atomic expr
546 (bracketedLines, bracketedBuilder) =
547 fromExpr indent Whatever bracketedExpr
548 in
549 ( merge lines bracketedLines
550 , builder <> "[" <> bracketedBuilder <> "]"
551 )
555-- OPERATORS
558fromPrefix :: PrefixOp -> Builder
559fromPrefix op =
560 case op of
561 PrefixLNot -> "!"
562 PrefixBNot -> "~"
563 PrefixPlus -> "+"
564 PrefixMinus -> "-"
565 PrefixTypeof -> "typeof "
566 PrefixVoid -> "void "
567 PrefixDelete -> "delete "
570fromAssign :: AssignOp -> Builder
571fromAssign op =
572 case op of
573 OpAssign -> " = "
574 OpAssignAdd -> " += "
575 OpAssignSub -> " -= "
576 OpAssignMul -> " *= "
577 OpAssignDiv -> " /= "
578 OpAssignMod -> " %= "
579 OpAssignLShift -> " <<= "
580 OpAssignSpRShift -> " >>= "
581 OpAssignZfRShift -> " >>>= "
582 OpAssignBAnd -> " &= "
583 OpAssignBXor -> " ^= "
584 OpAssignBOr -> " |= "
587fromInfix :: InfixOp -> Builder
588fromInfix op =
589 case op of
590 OpLT -> " < "
591 OpLEq -> " <= "
592 OpGT -> " > "
593 OpGEq -> " >= "
594 OpIn -> " in "
595 OpInstanceof -> " instanceof "
596 OpEq -> " == "
597 OpNEq -> " != "
598 OpStrictEq -> " === "
599 OpStrictNEq -> " !=== "
600 OpLAnd -> " && "
601 OpLOr -> " || "
602 OpMul -> " * "
603 OpDiv -> " / "
604 OpMod -> " % "
605 OpSub -> " - "
606 OpLShift -> " << "
607 OpSpRShift -> " >> "
608 OpZfRShift -> " >>> "
609 OpBAnd -> " & "
610 OpBXor -> " ^ "
611 OpBOr -> " | "
612 OpAdd -> " + "