@@ -1,26 +1,13 @@
11module Generate.JavaScript (generate) where
22
3−import Control.Applicative ((<$>),(<*>))
4−import Control.Arrow (first, second, (***))
53import Control.Monad.State as State
6−import qualified Data.List as List
7−import qualified Data.Map as Map
84import Language.ECMAScript3.PrettyPrint as ES
95import Language.ECMAScript3.Syntax
106import qualified Text.PrettyPrint.Leijen as PP
117
12−import qualified AST.Expression.General as Expr
13−import AST.Expression.Optimized as Opt
14−import qualified AST.Literal as L
158import qualified AST.Module as Module
16−import qualified AST.Module.Name as ModuleName
17−import qualified AST.Variable as Var
18−import Generate.JavaScript.Helpers as Help
19−import qualified Generate.JavaScript.BuiltIn as BuiltIn
20−import qualified Generate.JavaScript.Literal as Literal
21−import qualified Generate.JavaScript.Port as Port
9+import qualified Generate.JavaScript.Expression as JS
2210import qualified Generate.JavaScript.Variable as Var
23−import qualified Optimize.Patterns.DecisionTree as DT
2411
2512
2613generate :: Module.Optimized -> String
@@ -33,515 +20,6 @@ generate module_ =
3320 Var.define "_op" (ObjectLit () [])
3421
3522 stmts =
36− State.evalState (mapM generateDef definitions) 0
23+ State.evalState (mapM JS.generateDef definitions) 0
3724 in
38− PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint (setup:stmts))) ""
39−
40−
41−-- CODE CHUNKS
42−
43−data Code
44− = JsExpr (Expression ())
45− | JsBlock [Statement ()]
46−
47−
48−jsExpr :: Expression () -> State Int Code
49−jsExpr exp =
50− return (JsExpr exp)
51−
52−
53−jsBlock :: [Statement ()] -> State Int Code
54−jsBlock exp =
55− return (JsBlock exp)
56−
57−
58−isBlock :: Code -> Bool
59−isBlock code =
60− case code of
61− JsBlock _ -> True
62− JsExpr _ -> False
63−
64−
65−toStatementList :: Code -> [Statement ()]
66−toStatementList code =
67− case code of
68− JsExpr expr ->
69− [ ret expr ]
70− JsBlock stmts ->
71− stmts
72−
73−
74−toStatement :: Code -> Statement ()
75−toStatement code =
76− case code of
77− JsExpr expr ->
78− ret expr
79− JsBlock [stmt] ->
80− stmt
81− JsBlock stmts ->
82− BlockStmt () stmts
83−
84−
85−toExpr :: Code -> Expression ()
86−toExpr code =
87− case code of
88− JsExpr expr ->
89− expr
90−
91− JsBlock stmts ->
92− function [] stmts `call` []
93−
94−
95−-- DEFINITIONS
96−
97−generateDef :: Opt.Def -> State Int (Statement ())
98−generateDef def =
99− do (home, name, jsBody) <-
100− case def of
101− Opt.TailDef (Opt.Facts home _) name argNames body ->
102− (,,) home name <$> generateTailFunction name argNames body
103−
104− Opt.Def (Opt.Facts home _) name body ->
105− (,,) home name <$> generateJsExpr body
106−
107− return (Var.define name jsBody)
108−
109−
110−-- EXPRESSIONS
111−
112−generateJsExpr :: Opt.Expr -> State Int (Expression ())
113−generateJsExpr optExpr =
114− toExpr <$> generateCode optExpr
115−
116−
117−generateCode :: Opt.Expr -> State Int Code
118−generateCode expr =
119− case expr of
120− Var var ->
121− jsExpr $ Var.canonical var
122−
123− Literal lit ->
124− jsExpr (Literal.literal lit)
125−
126− Range lo hi ->
127− do lo' <- generateJsExpr lo
128− hi' <- generateJsExpr hi
129− jsExpr $ BuiltIn.range lo' hi'
130−
131− Access record field ->
132− do record' <- generateJsExpr record
133− jsExpr $ DotRef () record' (var (Var.safe field))
134−
135− Update record fields ->
136− let
137− fieldToJs (field, value) =
138− do jsValue <- generateJsExpr value
139− return (Var.safe field, jsValue)
140− in
141− do jsRecord <- generateJsExpr record
142− jsFields <- mapM fieldToJs fields
143− jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
144−
145− Record fields ->
146− do fields' <-
147− forM fields $ \(field, e) ->
148− (,) (Var.safe field) <$> generateJsExpr e
149−
150− let fieldMap =
151− List.foldl' combine Map.empty fields'
152−
153− jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
154− where
155− combine record (field, value) =
156− Map.insertWith (++) field [value] record
157−
158− hidden fs =
159− ObjectLit () . map (prop *** ArrayLit ()) $
160− Map.toList (Map.filter (not . null) (Map.map tail fs))
161−
162− visible fs =
163− map (first prop) (Map.toList (Map.map head fs))
164−
165− Binop op leftExpr rightExpr ->
166− binop op leftExpr rightExpr
167−
168− Function args body ->
169− generateFunction args body
170−
171− Call func args ->
172− let
173− arity = length args
174− aN = "A" ++ show arity
175− in
176− do jsFunc <- generateJsExpr func
177− jsArgs <- mapM generateJsExpr args
178− jsExpr $
179− if 2 <= arity && arity <= 9 then
180− ref aN `call` (jsFunc:jsArgs)
181− else
182− foldl1 (<|) (jsFunc:jsArgs)
183−
184− TailCall name argNames args ->
185− let
186− reassign name tempName =
187− ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
188− in
189− do args' <- mapM generateJsExpr args
190− tempNames <- mapM (\_ -> Var.fresh) args
191− jsBlock $
192− VarDeclStmt () (zipWith varDecl tempNames args')
193− : zipWith reassign argNames tempNames
194− ++ [ContinueStmt () (Just (Id () name))]
195−
196− Let defs body ->
197− do stmts <- mapM generateDef defs
198− code <- generateCode body
199− jsBlock (stmts ++ toStatementList code)
200−
201− If branches finally ->
202− generateIf branches finally
203−
204− Case root decisionTree branches ->
205− JsBlock <$> generateCase root decisionTree branches
206−
207− ExplicitList elements ->
208− do jsElements <- mapM generateJsExpr elements
209− jsExpr $ BuiltIn.list jsElements
210−
211− Data tag members ->
212− do jsMembers <- mapM generateJsExpr members
213− jsExpr $ ObjectLit () (ctor : fields jsMembers)
214− where
215− ctor = (prop "ctor", string tag)
216− fields =
217− zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
218−
219− DataAccess dataExpr index ->
220− do jsDataExpr <- generateJsExpr dataExpr
221− jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
222−
223− GLShader _uid src _tipe ->
224− jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
225−
226− Port impl ->
227− case impl of
228− Expr.In name portType ->
229− jsExpr (Port.inbound name portType)
230−
231− Expr.Out name expr portType ->
232− do expr' <- generateJsExpr expr
233− jsExpr (Port.outbound name expr' portType)
234−
235− Expr.Task name expr portType ->
236− do expr' <- generateJsExpr expr
237− jsExpr (Port.task name expr' portType)
238−
239− Crash region maybeCaseCrashValue ->
240− jsExpr $ BuiltIn.crash region maybeCaseCrashValue
241−
242−
243−-- FUNCTIONS
244−
245−generateFunction :: [String] -> Opt.Expr -> State Int Code
246−generateFunction args body =
247− do code <- generateCode body
248− jsExpr (generateFunctionWithArity args code)
249−
250−
251−generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
252−generateTailFunction name args body =
253− do code <- generateCode body
254− return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
255− LabelledStmt ()
256− (Id () name)
257− (WhileStmt () (BoolLit () True) (toStatement code))
258−
259−
260−generateFunctionWithArity :: [String] -> Code -> Expression ()
261−generateFunctionWithArity rawArgs code =
262− let
263− args = map Var.safe rawArgs
264− arity = length args
265− in
266− if 2 <= arity && arity <= 9 then
267− let
268− fN = "F" ++ show arity
269− in
270− ref fN <| function args (toStatementList code)
271− else
272− let
273− (lastArg:otherArgs) = reverse args
274− innerBody = function [lastArg] (toStatementList code)
275− in
276− foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
277−
278−
279−-- GENERATE IFS
280−
281−generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
282−generateIf givenBranches givenFinally =
283− let
284− (branches, finally) =
285− crushIfs givenBranches givenFinally
286−
287− convertBranch (condition, expr) =
288− (,) <$> generateJsExpr condition <*> generateCode expr
289−
290− ifExpression (condition, branch) otherwise =
291− CondExpr () condition branch otherwise
292−
293− ifStatement (condition, branch) otherwise =
294− IfStmt () condition branch otherwise
295− in
296− do jsBranches <- mapM convertBranch branches
297− jsFinally <- generateCode finally
298−
299− if any isBlock (jsFinally : map snd jsBranches)
300− then
301− jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
302− else
303− jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
304−
305−
306−crushIfs
307− :: [(Opt.Expr, Opt.Expr)]
308− -> Opt.Expr
309− -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
310−crushIfs branches finally =
311− crushIfsHelp [] branches finally
312−
313−
314−crushIfsHelp
315− :: [(Opt.Expr, Opt.Expr)]
316− -> [(Opt.Expr, Opt.Expr)]
317− -> Opt.Expr
318− -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
319−crushIfsHelp visitedBranches unvisitedBranches finally =
320− case unvisitedBranches of
321− [] ->
322− case finally of
323− If subBranches subFinally ->
324− crushIfsHelp visitedBranches subBranches subFinally
325−
326− _ ->
327− (reverse visitedBranches, finally)
328−
329− (Literal (L.Boolean True), branch) : _ ->
330− crushIfsHelp visitedBranches [] branch
331−
332− visiting : unvisited ->
333− crushIfsHelp (visiting : visitedBranches) unvisited finally
334−
335−
336−-- CASE EXPRESSIONS
337−
338−generateCase
339− :: String
340− -> DT.DecisionTree Opt.Jump
341− -> [(Int, Opt.Branch)]
342− -> State Int [Statement ()]
343−generateCase root decisionTree jumpBranches =
344− do decider <- generateDecisionTree root decisionTree
345− foldM (goto root) decider jumpBranches
346−
347−
348−goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
349−goto root decider (target, branch) =
350− let
351− deciderStmt =
352− LabelledStmt ()
353− (targetLabel root target)
354− (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
355− in
356− do stmts <- generateBranch root branch
357− return (deciderStmt : stmts)
358−
359−
360−targetLabel :: String -> Int -> Id ()
361−targetLabel root target =
362− Id () (root ++ "_" ++ show target)
363−
364−
365−generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
366−generateDecisionTree root decisionTree =
367− case decisionTree of
368− DT.Match (Opt.Inline branch) ->
369− generateBranch root branch
370−
371− DT.Match (Opt.Jump target) ->
372− return [ BreakStmt () (Just (targetLabel root target)) ]
373−
374− DT.Decision testPath [(test, subTree)] (Just fallback) ->
375− let
376− (tests, deepestSubTree) =
377− collapseTests [(testPath, test)] fallback subTree
378−
379− makeTest (path, test) =
380− do testExpr <- pathToTestableExpr root path test
381− return (InfixExpr () OpStrictEq testExpr (testToExpr test))
382− in
383− do testExprs <- mapM makeTest tests
384− let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
385− thenBranch <- generateDecisionTree root deepestSubTree
386− elseBranch <- generateDecisionTree root fallback
387− return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
388−
389− DT.Decision testPath edges fallback ->
390− do testExpr <- pathToTestableExpr root testPath (fst (head edges))
391− caseClauses <- mapM (edgeToCaseClause root) edges
392− caseDefault <- fallbackToDefault root fallback
393− return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
394−
395−
396−collapseTests
397− :: [(DT.Path, DT.Test)]
398− -> DT.DecisionTree Opt.Jump
399− -> DT.DecisionTree Opt.Jump
400− -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)
401−collapseTests tests outerFallback decisionTree =
402− case decisionTree of
403− DT.Decision testPath [(test, subTree)] (Just fallback)
404− | fallback == outerFallback ->
405− collapseTests ((testPath, test) : tests) outerFallback subTree
406−
407− _ ->
408− (tests, decisionTree)
409−
410−
411−edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
412−edgeToCaseClause root (test, subTree) =
413− CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
414−
415−
416−pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
417−pathToTestableExpr root path exampleTest =
418− do accessExpr <- generateJsExpr (pathToExpr root path)
419− case exampleTest of
420− DT.Constructor _ ->
421− return (DotRef () accessExpr (Id () "ctor"))
422−
423− DT.Literal _ ->
424− return accessExpr
425−
426−
427−testToExpr :: DT.Test -> Expression ()
428−testToExpr test =
429− case test of
430− DT.Constructor (Var.Canonical _ tag) ->
431− StringLit () tag
432−
433− DT.Literal (L.Chr char) ->
434− StringLit () [char]
435−
436− DT.Literal lit ->
437− Literal.literal lit
438−
439−
440−fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
441−fallbackToDefault root fallback =
442− case fallback of
443− Nothing ->
444− return []
445−
446− Just subTree ->
447− do stmts <- generateDecisionTree root subTree
448− return [ CaseDefault () stmts ]
449−
450−
451−generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
452−generateBranch root (Opt.Branch substitutions expr) =
453− do substs <- mapM (loadPath root) substitutions
454− let substStmts =
455− if null substs then [] else [ VarDeclStmt () substs ]
456− code <- generateCode expr
457− return (substStmts ++ toStatementList code)
458−
459−
460−loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())
461−loadPath root (name, path) =
462− do jsAccessExpr <- generateJsExpr (pathToExpr root path)
463− return $ varDecl (Var.safe name) jsAccessExpr
464−
465−
466−pathToExpr :: String -> DT.Path -> Opt.Expr
467−pathToExpr root fullPath =
468− go (Opt.Var (Var.local root)) fullPath
469− where
470− go expr path =
471− case path of
472− DT.Position index subpath ->
473− go (Opt.DataAccess expr index) subpath
474−
475− DT.Field field subpath ->
476− go (Opt.Access expr field) subpath
477−
478− DT.Empty ->
479− expr
480−
481− DT.Alias ->
482− expr
483−
484−
485−-- BINARY OPERATORS
486−
487−binop
488− :: Var.Canonical
489− -> Opt.Expr
490− -> Opt.Expr
491− -> State Int Code
492−binop func left right =
493− do jsLeft <- generateJsExpr left
494− jsRight <- generateJsExpr right
495− jsExpr (makeExpr func jsLeft jsRight)
496−
497−
498−-- BINARY OPERATOR HELPERS
499−
500−makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
501−makeExpr qualifiedOp@(Var.Canonical home op) =
502− let
503− simpleMake left right =
504− ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
505− in
506− if home == Var.Module (ModuleName.inCore ["Basics"]) then
507− Map.findWithDefault simpleMake op basicOps
508− else
509− simpleMake
510−
511−
512−basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
513−basicOps =
514− Map.fromList (infixOps ++ specialOps)
515−
516−
517−infixOps :: [(String, Expression () -> Expression () -> Expression ())]
518−infixOps =
519− let
520− infixOp str op =
521− (str, InfixExpr () op)
522− in
523− [ infixOp "+" OpAdd
524− , infixOp "-" OpSub
525− , infixOp "*" OpMul
526− , infixOp "/" OpDiv
527− , infixOp "&&" OpLAnd
528− , infixOp "||" OpLOr
529− ]
530−
531−
532−specialOps :: [(String, Expression () -> Expression () -> Expression ())]
533−specialOps =
534− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
535− , (,) "==" $ \a b -> BuiltIn.eq a b
536− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
537− , (,) "<" $ cmp OpLT 0
538− , (,) ">" $ cmp OpGT 0
539− , (,) "<=" $ cmp OpLT 1
540− , (,) ">=" $ cmp OpGT (-1)
541− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
542− ]
543−
544−
545−cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
546−cmp op n a b =
547− InfixExpr () op (BuiltIn.compare a b) (IntLit () n)
25+ PP.displayS (PP.renderPretty 0.4 160 (ES.prettyPrint (setup:stmts))) ""