@@ -0,0 +1,504 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Generate.JavaScript.Builder (stmtsToText) where
5+import qualified Data.List as List
6+import Data.Monoid ((<>))
7+import qualified Data.Text.Lazy as LazyText
8+import Data.Text.Lazy.Builder
9+import Data.Text.Lazy.Builder.Int (decimal)
10+import Data.Text.Lazy.Builder.RealFloat (realFloat)
11+import Language.ECMAScript3.Syntax
12+import Prelude hiding (lines)
16+-- CONVERT TO LAZY TEXT
19+stmtsToText :: [Statement a] -> LazyText.Text
21+ toLazyText (fromStmtBlock "" stmts)
28+deeper :: Builder -> Builder
33+commaSep :: [Builder] -> Builder
35+ mconcat (List.intersperse ", " builders)
38+commaNewlineSep :: Builder -> [Builder] -> Builder
39+commaNewlineSep indent builders =
40+ mconcat (List.intersperse (",\n" <> deeper indent) builders)
47+fromStmtBlock :: Builder -> [Statement a] -> Builder
48+fromStmtBlock indent stmts =
49+ mconcat (map (fromStmt indent) stmts)
52+fromStmt :: Builder -> Statement a -> Builder
53+fromStmt indent statement =
56+ fromStmtBlock indent stmts
62+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"
64+ IfStmt _ condition thenStmt elseStmt ->
66+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
67+ , fromStmt (deeper indent) thenStmt
68+ , indent, "} else {\n"
69+ , fromStmt (deeper indent) elseStmt
73+ IfSingleStmt _ condition thenStmt ->
75+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
76+ , fromStmt (deeper indent) thenStmt
80+ SwitchStmt _ expr clauses ->
82+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
83+ , mconcat (map (fromClause (deeper indent)) clauses)
87+ WhileStmt _ expr stmt ->
89+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
90+ , fromStmt (deeper indent) stmt
94+ DoWhileStmt _ stmt expr ->
97+ , fromStmt (deeper indent) stmt
98+ , indent, "} while(", snd (fromExpr indent Whatever expr), ");\n"
101+ BreakStmt _ Nothing ->
102+ indent <> "break;\n"
104+ BreakStmt _ (Just label) ->
105+ indent <> "break " <> fromId label <> ";\n"
107+ ContinueStmt _ Nothing ->
108+ indent <> "continue;\n"
110+ ContinueStmt _ (Just label) ->
111+ indent <> "continue " <> fromId label <> ";\n"
113+ LabelledStmt _ label stmt ->
115+ [ indent, fromId label, ":\n"
116+ , fromStmt indent stmt
119+ ForInStmt _ _ _ _ ->
122+ ForStmt _ _ _ _ _ ->
129+ indent <> "throw " <> snd (fromExpr indent Whatever expr) <> ";\n"
131+ ReturnStmt _ Nothing ->
132+ indent <> "return;\n"
134+ ReturnStmt _ (Just expr) ->
135+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
143+ VarDeclStmt _ decls ->
144+ indent <> "var " <> commaNewlineSep indent (map (fromVarDecl indent) decls) <> ";\n"
146+ FunctionStmt _ name args stmts ->
147+ indent <> "function " <> fromId name <> "(" <> commaSep (map fromId args) <> ") {\n"
149+ fromStmtBlock (deeper indent) stmts
158+fromClause :: Builder -> CaseClause a -> Builder
159+fromClause indent clause =
161+ CaseClause _ expr stmts ->
162+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
163+ <> fromStmtBlock (deeper indent) stmts
165+ CaseDefault _ stmts ->
166+ indent <> "default:\n"
167+ <> fromStmtBlock (deeper indent) stmts
174+fromId :: Id a -> Builder
183+fromVarDecl :: Builder -> VarDecl a -> Builder
184+fromVarDecl indent (VarDecl _ (Id _ name) maybeExpr) =
190+ fromString name <> " = " <> snd (fromExpr indent Whatever expr)
197+data Lines = One | Many deriving (Eq)
201+(!) :: a -> b -> (a, b)
208+merge :: Lines -> Lines -> Lines
210+ if a == Many || b == Many then Many else One
213+linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
219+ ( any ((==) Many . fst) pairs
224+data Grouping = Atomic | Whatever
227+parensFor :: Grouping -> Builder -> Builder
228+parensFor grouping builder =
231+ "(" <> builder <> ")"
237+fromExpr :: Builder -> Grouping -> Expression a -> (Lines, Builder)
238+fromExpr indent grouping expression =
240+ StringLit _ string ->
241+ One ! fromString (show string)
243+ RegexpLit _ _ _ _ ->
264+ (anyMany, builders) =
265+ linesMap (fromExpr indent Whatever) exprs
270+ <> commaNewlineSep indent builders
271+ <> "\n" <> indent <> "]"
274+ "[" <> commaSep builders <> "]"
276+ ObjectLit _ fields ->
282+ (anyMany, builders) =
283+ linesMap (fromField deeperIndent) fields
288+ <> commaNewlineSep indent builders
289+ <> "\n" <> indent <> "}"
292+ "{" <> commaSep builders <> "}"
300+ DotRef _ expr (Id _ name) ->
301+ makeDot indent expr name
303+ BracketRef _ expr bracketedExpr ->
304+ makeBracketed indent expr bracketedExpr
309+ PrefixExpr _ op expr ->
312+ fromExpr indent Atomic expr
314+ lines ! parensFor grouping (fromPrefix op <> builder)
316+ UnaryAssignExpr _ _ _ ->
319+ InfixExpr _ op leftExpr rightExpr ->
322+ fromExpr indent Atomic leftExpr
324+ (rightLines, right) =
325+ fromExpr indent Atomic rightExpr
327+ merge leftLines rightLines !
328+ parensFor grouping (left <> fromInfix op <> right)
330+ CondExpr _ condExpr thenExpr elseExpr ->
332+ condB = snd (fromExpr indent Atomic condExpr)
333+ thenB = snd (fromExpr indent Atomic thenExpr)
334+ elseB = snd (fromExpr indent Atomic elseExpr)
337+ parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
339+ AssignExpr _ op lValue expr ->
342+ fromLValue indent lValue
344+ (rightLines, right) =
345+ fromExpr indent Whatever expr
347+ merge leftLines rightLines !
348+ parensFor grouping (left <> fromAssign op <> right)
353+ CallExpr _ function args ->
360+ snd (fromExpr indent Atomic function)
363+ linesMap (fromExpr deeperIndent Whatever) args
366+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
369+ funcB <> "(" <> commaSep argsB <> ")"
371+ FuncExpr _ maybeName args stmts ->
373+ "function " <> maybe mempty fromId maybeName <> "(" <> commaSep (map fromId args) <> ") {\n"
375+ fromStmtBlock (deeper indent) stmts
384+fromField :: Builder -> (Prop a, Expression a) -> (Lines, Builder)
385+fromField indent (prop, expr) =
388+ fromExpr indent Whatever expr
391+ fromProp prop <> ": " <> builder
394+fromProp :: Prop a -> Builder
400+ PropString _ string ->
401+ fromString (show string)
411+fromLValue :: Builder -> LValue a -> (Lines, Builder)
412+fromLValue indent lValue =
415+ One ! fromString name
417+ LDot _ expr field ->
418+ makeDot indent expr field
420+ LBracket _ expr bracketedExpr ->
421+ makeBracketed indent expr bracketedExpr
424+makeDot :: Builder -> Expression a -> String -> (Lines, Builder)
425+makeDot indent expr field =
428+ fromExpr indent Atomic expr
430+ lines ! builder <> "." <> fromString field
433+makeBracketed :: Builder -> Expression a -> Expression a -> (Lines, Builder)
434+makeBracketed indent expr bracketedExpr =
437+ fromExpr indent Atomic expr
439+ (bracketedLines, bracketedBuilder) =
440+ fromExpr indent Whatever bracketedExpr
442+ merge lines bracketedLines !
443+ builder <> "[" <> bracketedBuilder <> "]"
450+fromPrefix :: PrefixOp -> Builder
457+ PrefixTypeof -> "typeof "
458+ PrefixVoid -> "void "
459+ PrefixDelete -> "delete "
462+fromAssign :: AssignOp -> Builder
466+ OpAssignAdd -> " += "
467+ OpAssignSub -> " -= "
468+ OpAssignMul -> " *= "
469+ OpAssignDiv -> " /= "
470+ OpAssignMod -> " %= "
471+ OpAssignLShift -> " <<= "
472+ OpAssignSpRShift -> " >>= "
473+ OpAssignZfRShift -> " >>>= "
474+ OpAssignBAnd -> " &= "
475+ OpAssignBXor -> " ^= "
476+ OpAssignBOr -> " |= "
479+fromInfix :: InfixOp -> Builder
487+ OpInstanceof -> " instanceof "
490+ OpStrictEq -> " === "
491+ OpStrictNEq -> " !=== "
499+ OpSpRShift -> " >> "
500+ OpZfRShift -> " >>> "