@@ -2,11 +2,13 @@ module Generate.JavaScript (generate) where
22
33import Control.Applicative ((<$>),(<*>))
44import Control.Arrow (first, second, (***))
5−import Control.Monad.State
5+import Control.Monad.State as State
66import qualified Data.List as List
77import qualified Data.Map as Map
88import qualified Data.Maybe as Maybe
9+import Language.ECMAScript3.PrettyPrint as ES
910import Language.ECMAScript3.Syntax
11+import qualified Text.PrettyPrint.Leijen as PP
1012
1113import AST.Expression.General as Expr
1214import qualified AST.Expression.Optimized as Opt
@@ -28,8 +30,15 @@ import qualified Reporting.Crash as Crash
2830
2931
3032generate :: Module.Optimized -> String
31−generate modul =
32− error "TODO" modul exprToCode
33+generate module_ =
34+ let
35+ (definitions, _) =
36+ flattenLets [] (Module.program (Module.body module_))
37+
38+ stmts =
39+ concat (State.evalState (mapM defToStatements definitions) 0)
40+ in
41+ PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint stmts)) ""
3342
3443
3544-- CODE CHUNKS
@@ -222,7 +231,7 @@ generateFunction (args, initialBody) =
222231generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
223232generateTailFunction name (args, initialBody) =
224233 do (argVars, patternDefs) <- destructuredArgs args
225− label <- Id () <$> Case.newVar
234+ label <- Id () <$> Var.fresh
226235 code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
227236 let whileLoop =
228237 JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
@@ -260,7 +269,7 @@ destructPattern pattern@(A.A ann pat) =
260269 return (Var.safe x, Nothing)
261270
262271 _ ->
263− do arg <- Case.newVar
272+ do arg <- Var.fresh
264273 return
265274 ( arg
266275 , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
@@ -287,7 +296,7 @@ generateApplication tcc expr =
287296 case isTailCall tcc func arity of
288297 Just (argNames, label) ->
289298 do args' <- mapM toJsExpr args
290− tempNames <- mapM (\_ -> Case.newVar) args
299+ tempNames <- mapM (\_ -> Var.fresh) args
291300 jsBlock $
292301 VarDeclStmt () (zipWith varDecl tempNames args')
293302 : zipWith reassign argNames tempNames
@@ -336,6 +345,13 @@ generateLet tcc givenDefs givenBody =
336345 jsBlock (stmts ++ toStatementList code)
337346
338347
348+flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
349+flattenLets defs lexpr@(A.A _ expr) =
350+ case expr of
351+ Let ds body -> flattenLets (defs ++ ds) body
352+ _ -> (defs, lexpr)
353+
354+
339355-- GENERATE IFS
340356
341357generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
@@ -473,97 +489,7 @@ defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
473489
474490generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
475491generateCase tcc expr branches =
476− do (tempVar, initialMatch) <-
477− Case.toMatch branches
478−
479− (revisedMatch, stmt) <-
480− case expr of
481− A.A _ (Var (Var.Canonical Var.Local x)) ->
482− return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])
483−
484− A.A _ (Var (Var.Canonical (Var.TopLevel _) x)) ->
485− return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])
486−
487− _ ->
488− do expr' <- toJsExpr expr
489− return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
490−
491− match' <- match tcc revisedMatch
492−
493− jsBlock (stmt ++ match')
494−
495−
496−match :: TailCallContext -> Case.Match -> State Int [Statement ()]
497−match tcc mtch =
498− case mtch of
499− Case.Match name clauses mtch' ->
500− do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
501− mtch'' <- match tcc mtch'
502− return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
503− where
504− isLiteral p =
505− case p of
506− Case.Clause (Right _) _ _ ->
507− True
508− _ ->
509− False
510−
511− access name =
512− if any isLiteral clauses then
513− obj [name]
514− else
515− obj (Help.splitDots name ++ ["ctor"])
516−
517− format isChars expr =
518− if or isChars then
519− InfixExpr () OpAdd expr (string "")
520− else
521− expr
522−
523− Case.Fail ->
524− return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
525−
526− Case.Break ->
527− return [BreakStmt () Nothing]
528−
529− Case.Other expr ->
530− toStatementList <$> exprToCode tcc expr
531−
532− Case.Seq ms ->
533− concat <$> mapM (match tcc) (dropEnd [] ms)
534− where
535− dropEnd acc [] = acc
536− dropEnd acc (m:ms) =
537− case m of
538− Case.Other _ -> acc ++ [m]
539− _ -> dropEnd (acc ++ [m]) ms
540−
541−
542−clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
543−clause tcc variable (Case.Clause value vars mtch) =
544− do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
545− return ((,) isChar (CaseClause () pattern statemens))
546− where
547− vars' =
548− map (\n -> variable ++ "._" ++ show n) [0..]
549−
550− (isChar, pattern) =
551− case value of
552− Right (Chr c) -> (True, string [c])
553− _ ->
554− (,) False $
555− case value of
556− Right (Boolean b) -> BoolLit () b
557− Right lit -> Literal.literal lit
558− Left (Var.Canonical _ name) ->
559− string name
560−
561−
562−flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
563−flattenLets defs lexpr@(A.A _ expr) =
564− case expr of
565− Let ds body -> flattenLets (defs ++ ds) body
566− _ -> (defs, lexpr)
492+ error "TODO" tcc expr branches
567493
568494
569495-- BINARY OPERATORS