@@ -1,17 +1,18 @@
11module Generate.JavaScript (generate) where
22
33import Control.Applicative ((<$>),(<*>))
4−import Control.Arrow (first,(***))
4+import Control.Arrow (first, second, (***))
55import Control.Monad.State
66import qualified Data.List as List
77import qualified Data.Map as Map
8+import qualified Data.Maybe as Maybe
89import qualified Data.Set as Set
910import Language.ECMAScript3.PrettyPrint
1011import Language.ECMAScript3.Syntax
1112
1213import AST.Module
13−import AST.Expression.General
14−import qualified AST.Expression.Canonical as Canonical
14+import AST.Expression.General as Expr
15+import qualified AST.Expression.Optimized as Opt
1516import qualified AST.Helpers as Help
1617import AST.Literal
1718import qualified AST.Module as Module
@@ -19,19 +20,22 @@ import qualified AST.Pattern as P
1920import qualified AST.Variable as Var
2021import Elm.Utils ((|>))
2122import Generate.JavaScript.Helpers as Help
22−import qualified Generate.Cases as Case
23+import qualified Generate.JavaScript.Crash as Crash
2324import qualified Generate.JavaScript.Port as Port
2425import qualified Generate.JavaScript.Variable as Var
26+import qualified Optimize.Cases as Case
2527import qualified Reporting.Annotation as A
26−import qualified Reporting.Region as R
28+import qualified Reporting.Crash as Crash
2729
2830
31+-- HELPERS
32+
2933internalImports :: Module.Name -> [VarDecl ()]
3034internalImports name =
3135 [ varDecl "_N" (obj ["Elm","Native"])
3236 , include "_U" "Utils"
3337 , include "_L" "List"
34− , varDecl Help.localModuleName (string (Module.nameToString name))
38+ , varDecl Crash.localModuleName (string (Module.nameToString name))
3539 ]
3640 where
3741 include :: String -> String -> VarDecl ()
@@ -59,51 +63,131 @@ literal lit =
5963 Boolean b -> BoolLit () b
6064
6165
62−expression :: Canonical.Expr -> State Int (Expression ())
63−expression (A.A region expr) =
66+-- CODE CHUNKS
67+
68+data Code
69+ = JsExpr (Expression ())
70+ | JsBlock [Statement ()]
71+
72+
73+jsExpr :: Expression () -> State Int Code
74+jsExpr exp =
75+ return (JsExpr exp)
76+
77+
78+jsBlock :: [Statement ()] -> State Int Code
79+jsBlock exp =
80+ return (JsBlock exp)
81+
82+
83+isBlock :: Code -> Bool
84+isBlock code =
85+ case code of
86+ JsBlock _ -> True
87+ JsExpr _ -> False
88+
89+
90+toStatementList :: Code -> [Statement ()]
91+toStatementList code =
92+ case code of
93+ JsExpr expr ->
94+ [ ret expr ]
95+ JsBlock stmts ->
96+ stmts
97+
98+
99+toStatement :: Code -> Statement ()
100+toStatement code =
101+ case code of
102+ JsExpr expr ->
103+ ret expr
104+ JsBlock [stmt] ->
105+ stmt
106+ JsBlock stmts ->
107+ BlockStmt () stmts
108+
109+
110+toExpr :: Code -> Expression ()
111+toExpr code =
112+ case code of
113+ JsExpr expr ->
114+ expr
115+ JsBlock stmts ->
116+ function [] stmts `call` []
117+
118+
119+-- TAIL CALL CONTEXT
120+
121+type TailCallContext =
122+ Maybe (String, [String], Label)
123+
124+
125+type Label =
126+ Id ()
127+
128+
129+-- EXPRESSIONS
130+
131+toJsExpr :: Opt.Expr -> State Int (Expression ())
132+toJsExpr =
133+ exprToJsExpr Nothing
134+
135+
136+toCode :: Opt.Expr -> State Int Code
137+toCode =
138+ exprToCode Nothing
139+
140+
141+exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())
142+exprToJsExpr tcc canonicalExpr =
143+ toExpr <$> exprToCode tcc canonicalExpr
144+
145+
146+exprToCode :: TailCallContext -> Opt.Expr -> State Int Code
147+exprToCode tcc annotatedExpr@(A.A _ expr) =
64148 case expr of
65149 Var var ->
66− return $ Var.canonical var
150+ jsExpr $ Var.canonical var
67151
68152 Literal lit ->
69− return $ literal lit
153+ jsExpr $ literal lit
70154
71155 Range lo hi ->
72− do lo' <- expression lo
73− hi' <- expression hi
74− return $ _List "range" `call` [lo',hi']
156+ do lo' <- toJsExpr lo
157+ hi' <- toJsExpr hi
158+ jsExpr $ _List "range" `call` [lo',hi']
75159
76− Access e field ->
77− do e' <- expression e
78− return $ DotRef () e' (var (Var.varName field))
160+ Access record field ->
161+ do record' <- toJsExpr record
162+ jsExpr $ DotRef () record' (var (Var.varName field))
79163
80− Remove e field ->
81− do e' <- expression e
82− return $ _Utils "remove" `call` [ string (Var.varName field), e' ]
164+ Remove record field ->
165+ do record' <- toJsExpr record
166+ jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]
83167
84− Insert e field value ->
85− do value' <- expression value
86− e' <- expression e
87− return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]
168+ Insert record field value ->
169+ do value' <- toJsExpr value
170+ record' <- toJsExpr record
171+ jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]
88172
89− Modify e fields ->
90− do e' <- expression e
173+ Modify record fields ->
174+ do record' <- toJsExpr record
91175 fields' <-
92176 forM fields $ \(field, value) ->
93− do value' <- expression value
177+ do value' <- toJsExpr value
94178 return $ ArrayLit () [ string (Var.varName field), value' ]
95179
96− return $ _Utils "replace" `call` [ArrayLit () fields', e']
180+ jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
97181
98182 Record fields ->
99183 do fields' <-
100184 forM fields $ \(field, e) ->
101− (,) (Var.varName field) <$> expression e
185+ (,) (Var.varName field) <$> toJsExpr e
102186
103187 let fieldMap =
104188 List.foldl' combine Map.empty fields'
105189
106− return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
190+ jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
107191 where
108192 combine record (field, value) =
109193 Map.insertWith (++) field [value] record
@@ -115,201 +199,370 @@ expression (A.A region expr) =
115199 visible fs =
116200 map (first prop) (Map.toList (Map.map head fs))
117201
118− Binop op e1 e2 ->
119− binop region op e1 e2
202+ Binop op leftExpr rightExpr ->
203+ binop op leftExpr rightExpr
120204
121− Lambda pattern rawBody@(A.A ann _) ->
122− do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
123− body' <- expression body
124− return $
125− case length args < 2 || length args > 9 of
126− True -> foldr (==>) body' (map (:[]) args)
127− False -> ref ("F" ++ show (length args)) <| (args ==> body')
128− where
129− depattern (args, body) pattern =
130− case pattern of
131− A.A _ (P.Var x) ->
132− return (args ++ [ Var.varName x ], body)
133−
134− _ ->
135− do arg <- Case.newVar
136− return
137− ( args ++ [arg]
138− , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])
139− )
140−
141− (patterns, innerBody) =
142− collect [pattern] rawBody
143−
144− collect patterns lexpr@(A.A _ expr) =
145− case expr of
146− Lambda p e -> collect (p:patterns) e
147− _ -> (patterns, lexpr)
148−
149− App e1 e2 ->
150− do func' <- expression func
151− args' <- mapM expression args
152− return $
153− case args' of
154− [arg] -> func' <| arg
155− _ | length args' <= 9 -> ref aN `call` (func':args')
156− | otherwise -> foldl1 (<|) (func':args')
157− where
158− aN = "A" ++ show (length args)
159− (func, args) = getArgs e1 [e2]
160− getArgs func args =
161− case func of
162− (A.A _ (App f arg)) -> getArgs f (arg : args)
163− _ -> (func, args)
164−
165− Let defs e ->
166− do let (defs',e') = flattenLets defs e
167− stmts <- concat <$> mapM definition defs'
168− exp <- expression e'
169− return $ function [] (stmts ++ [ ret exp ]) `call` []
170−
171− MultiIf branches ->
172− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
173− return $
174− case last branches of
175− (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
176− safeIfs branches'
177− (A.A _ (Literal (Boolean True)), _) ->
178− safeIfs branches'
179− _ ->
180− ifs branches' (throw "badIf" region)
181− where
182− safeIfs branches = ifs (init branches) (snd (last branches))
183− ifs branches finally = foldr iff finally branches
184− iff (if', then') else' = CondExpr () if' then' else'
185−
186− Case e cases ->
187− do (tempVar,initialMatch) <- Case.toMatch cases
188− (revisedMatch, stmt) <-
189− case e of
190− A.A _ (Var (Var.Canonical Var.Local x)) ->
191− return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
192− _ ->
193− do e' <- expression e
194− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
195− match' <- match region revisedMatch
196− return (function [] (stmt ++ match') `call` [])
197−
198− ExplicitList es ->
199− do es' <- mapM expression es
200− return $ _List "fromArray" <| ArrayLit () es'
201−
202− Data name es ->
203− do es' <- mapM expression es
204− return $ ObjectLit () (ctor : fields es')
205+ Lambda _ _ ->
206+ generateFunction (Expr.collectLambdas annotatedExpr)
207+
208+ App _ _ ->
209+ generateApplication tcc annotatedExpr
210+
211+ Let defs body ->
212+ generateLet tcc defs body
213+
214+ MultiIf branches finally ->
215+ generateIf tcc branches finally
216+
217+ Case expr branches ->
218+ generateCase tcc expr branches
219+
220+ ExplicitList elements ->
221+ do jsElements <- mapM toJsExpr elements
222+ jsExpr $ _List "fromArray" <| ArrayLit () jsElements
223+
224+ Data tag members ->
225+ do jsMembers <- mapM toJsExpr members
226+ jsExpr $ ObjectLit () (ctor : fields jsMembers)
205227 where
206− ctor = (prop "ctor", string name)
228+ ctor = (prop "ctor", string tag)
207229 fields =
208230 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
209231
210232 GLShader _uid src _tipe ->
211− return $ ObjectLit () [(PropString () "src", literal (Str src))]
233+ jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]
212234
213235 Port impl ->
214236 case impl of
215237 In name portType ->
216− return (Port.inbound name portType)
238+ jsExpr (Port.inbound name portType)
217239
218240 Out name expr portType ->
219− do expr' <- expression expr
220− return (Port.outbound name expr' portType)
241+ do expr' <- toJsExpr expr
242+ jsExpr (Port.outbound name expr' portType)
221243
222244 Task name expr portType ->
223− do expr' <- expression expr
224− return (Port.task name expr' portType)
225−
226−
227−definition :: Canonical.Def -> State Int [Statement ()]
228−definition (Canonical.Definition annPattern expr@(A.A region _) _) =
229− do expr' <- expression expr
230− let assign x = varDecl x expr'
231− let (A.A patternRegion pattern) = annPattern
232− case pattern of
233− P.Var x
234− | Help.isOp x ->
235− let op = LBracket () (ref "_op") (string x) in
236− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
237−
238− | otherwise ->
239− return [ VarDeclStmt () [ assign (Var.varName x) ] ]
240−
241− P.Record fields ->
242− let setField f = varDecl f (obj ["$",f]) in
243− return [ VarDeclStmt () (assign "$" : map setField fields) ]
244−
245− P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
246− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
247− where
248− vars = getVars patterns
249− getVars patterns =
250− case patterns of
251− A.A _ (P.Var x) : rest ->
252− (Var.varName x :) `fmap` getVars rest
253− [] ->
254− Just []
255− _ ->
256− Nothing
257−
258− decl x n = varDecl x (obj ["$","_" ++ show n])
259− setup vars
260− | Help.isTuple name = assign "$" : vars
261− | otherwise = assign "_raw" : safeAssign : vars
262−
263− safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
264− if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
265− exception = Help.throw "badCase" region
245+ do expr' <- toJsExpr expr
246+ jsExpr (Port.task name expr' portType)
247+
248+ Crash details ->
249+ jsExpr $ Crash.crash details
250+
251+
252+-- FUNCTIONS
253+
254+generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
255+generateFunction (args, initialBody) =
256+ do (argVars, patternDefs) <- destructuredArgs args
257+ code <- generateLet Nothing patternDefs initialBody
258+ jsExpr (generateFunctionWithArity argVars code)
259+
260+
261+generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
262+generateTailFunction name (args, initialBody) =
263+ do (argVars, patternDefs) <- destructuredArgs args
264+ label <- Id () <$> Case.newVar
265+ code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
266+ let whileLoop =
267+ JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
268+ return (generateFunctionWithArity argVars whileLoop)
269+
270+
271+generateFunctionWithArity :: [String] -> Code -> Expression ()
272+generateFunctionWithArity args code =
273+ let
274+ arity = length args
275+ in
276+ if 2 <= arity && arity <= 9 then
277+ let
278+ fN = "F" ++ show arity
279+ in
280+ ref fN <| function args (toStatementList code)
281+ else
282+ let
283+ (lastArg:otherArgs) = reverse args
284+ innerBody = function [lastArg] (toStatementList code)
285+ in
286+ foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
287+
288+
289+destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])
290+destructuredArgs args =
291+ do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
292+ return (argVars, Maybe.catMaybes maybePatternDefs)
293+
294+
295+destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)
296+destructPattern pattern@(A.A ann pat) =
297+ case pat of
298+ P.Var x ->
299+ return (Var.varName x, Nothing)
300+
301+ _ ->
302+ do arg <- Case.newVar
303+ return
304+ ( arg
305+ , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
306+ )
307+
308+
309+-- APPLICATIONS
310+
311+generateApplication :: TailCallContext -> Opt.Expr -> State Int Code
312+generateApplication tcc expr =
313+ let
314+ (func:args) =
315+ Expr.collectApps expr
316+
317+ arity =
318+ length args
319+
320+ reassign name tempName =
321+ ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
322+
323+ aN =
324+ "A" ++ show arity
325+ in
326+ case isTailCall tcc func arity of
327+ Just (argNames, label) ->
328+ do args' <- mapM toJsExpr args
329+ tempNames <- mapM (\_ -> Case.newVar) args
330+ jsBlock $
331+ VarDeclStmt () (zipWith varDecl tempNames args')
332+ : zipWith reassign argNames tempNames
333+ ++ [ContinueStmt () (Just label)]
266334
267− _ ->
268− do defs' <- concat <$> mapM toDef vars
269− return (VarDeclStmt () [assign "_"] : defs')
270− where
271− vars = P.boundVarList annPattern
272− mkVar = A.A region . localVar
273− toDef y =
274− let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]
275− pat = A.A patternRegion (P.Var y)
276− in
277− definition (Canonical.Definition pat expr Nothing)
278−
279−
280−match :: R.Region -> Case.Match -> State Int [Statement ()]
281−match region mtch =
335+ _ ->
336+ do func' <- toJsExpr func
337+ args' <- mapM toJsExpr args
338+ jsExpr $
339+ if 2 <= arity && arity <= 9 then
340+ ref aN `call` (func':args')
341+ else
342+ foldl1 (<|) (func':args')
343+
344+
345+isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)
346+isTailCall tcc (A.A _ func) arity =
347+ case (func, tcc) of
348+ (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->
349+ if name == tcName && length tcArgs == arity then
350+ Just (tcArgs, tcLabel)
351+ else
352+ Nothing
353+
354+ _ ->
355+ Nothing
356+
357+
358+-- LET EXPRESSIONS
359+
360+generateLet
361+ :: TailCallContext
362+ -> [Opt.Def]
363+ -> Opt.Expr
364+ -> State Int Code
365+generateLet tcc givenDefs givenBody =
366+ do let (defs, body) = flattenLets givenDefs givenBody
367+ stmts <- concat <$> mapM defToStatements defs
368+ code <- exprToCode tcc body
369+ jsBlock (stmts ++ toStatementList code)
370+
371+
372+-- GENERATE IFS
373+
374+generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
375+generateIf tcc givenBranches givenFinally =
376+ let
377+ (branches, finally) =
378+ crushIfs givenBranches givenFinally
379+
380+ convertBranch (condition, expr) =
381+ (,) <$> toJsExpr condition <*> exprToCode tcc expr
382+
383+ ifExpression (condition, branch) otherwise =
384+ CondExpr () condition branch otherwise
385+
386+ ifStatement (condition, branch) otherwise =
387+ IfStmt () condition branch otherwise
388+ in
389+ do jsBranches <- mapM convertBranch branches
390+ jsFinally <- exprToCode tcc finally
391+
392+ if any isBlock (jsFinally : map snd jsBranches)
393+ then
394+ jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
395+ else
396+ jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
397+
398+
399+crushIfs
400+ :: [(Opt.Expr, Opt.Expr)]
401+ -> Opt.Expr
402+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
403+crushIfs branches finally =
404+ crushIfsHelp [] branches finally
405+
406+
407+crushIfsHelp
408+ :: [(Opt.Expr, Opt.Expr)]
409+ -> [(Opt.Expr, Opt.Expr)]
410+ -> Opt.Expr
411+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
412+crushIfsHelp visitedBranches unvisitedBranches finally =
413+ case unvisitedBranches of
414+ [] ->
415+ case finally of
416+ A.A _ (MultiIf subBranches subFinally) ->
417+ crushIfsHelp visitedBranches subBranches subFinally
418+
419+ _ ->
420+ (reverse visitedBranches, finally)
421+
422+ (A.A _ (Literal (Boolean True)), branch) : _ ->
423+ crushIfsHelp visitedBranches [] branch
424+
425+ (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), branch) : _ ->
426+ crushIfsHelp visitedBranches [] branch
427+
428+ visiting : unvisited ->
429+ crushIfsHelp (visiting : visitedBranches) unvisited finally
430+
431+
432+
433+-- DEFINITIONS
434+
435+defToStatements :: Opt.Def -> State Int [Statement ()]
436+defToStatements def@(Opt.Definition facts pattern expr) =
437+ case Opt.tailRecursionDetails facts of
438+ Just name ->
439+ do func <- generateTailFunction name (Expr.collectLambdas expr)
440+ return [ VarDeclStmt () [ varDecl name func ] ]
441+
442+ Nothing ->
443+ defToStatementsHelp facts pattern =<< toJsExpr expr
444+
445+
446+defToStatementsHelp
447+ :: Opt.Facts
448+ -> P.Optimized
449+ -> Expression ()
450+ -> State Int [Statement ()]
451+defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
452+ let
453+ define x =
454+ varDecl x jsExpr
455+ in
456+ case pattern of
457+ P.Var x ->
458+ if Help.isOp x then
459+ let
460+ op = LBracket () (ref "_op") (string x)
461+ in
462+ return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
463+ else
464+ return [ VarDeclStmt () [ define (Var.varName x) ] ]
465+
466+ P.Record fields ->
467+ let
468+ setField name =
469+ varDecl name (obj ["$",name])
470+ in
471+ return [ VarDeclStmt () (define "$" : map setField fields) ]
472+
473+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
474+ return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
475+ where
476+ vars = getVars patterns
477+ getVars patterns =
478+ case patterns of
479+ A.A _ (P.Var x) : rest ->
480+ (Var.varName x :) `fmap` getVars rest
481+ [] ->
482+ Just []
483+ _ ->
484+ Nothing
485+
486+ decl x n = varDecl x (obj ["$","_" ++ show n])
487+ setup vars
488+ | Help.isTuple name = define "$" : vars
489+ | otherwise = define "_raw" : safeAssign : vars
490+
491+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
492+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
493+ exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
494+
495+ _ ->
496+ do defs' <- concat <$> mapM toDef vars
497+ return (VarDeclStmt () [define "_"] : defs')
498+ where
499+ vars = P.boundVarList annPattern
500+ mkVar = A.A () . localVar
501+ toDef y =
502+ let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
503+ pat = A.A () (P.Var y)
504+ in
505+ defToStatements (Opt.Definition facts pat expr)
506+
507+
508+-- CASE EXPRESSIONS
509+
510+generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
511+generateCase tcc expr branches =
512+ do (tempVar, initialMatch) <-
513+ Case.toMatch branches
514+
515+ (revisedMatch, stmt) <-
516+ case expr of
517+ A.A _ (Var (Var.Canonical Var.Local x)) ->
518+ return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
519+ _ ->
520+ do expr' <- toJsExpr expr
521+ return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
522+
523+ match' <- match tcc revisedMatch
524+
525+ jsBlock (stmt ++ match')
526+
527+
528+match :: TailCallContext -> Case.Match -> State Int [Statement ()]
529+match tcc mtch =
282530 case mtch of
283531 Case.Match name clauses mtch' ->
284− do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
285− mtch'' <- match region mtch'
532+ do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
533+ mtch'' <- match tcc mtch'
286534 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
287535 where
288536 isLiteral p =
289537 case p of
290− Case.Clause (Right _) _ _ -> True
291− _ -> False
292−
293− access name
294− | any isLiteral clauses = obj [name]
295− | otherwise = obj (Help.splitDots name ++ ["ctor"])
296−
297− format isChars e
298− | or isChars = InfixExpr () OpAdd e (string "")
299− | otherwise = e
538+ Case.Clause (Right _) _ _ ->
539+ True
540+ _ ->
541+ False
542+
543+ access name =
544+ if any isLiteral clauses then
545+ obj [name]
546+ else
547+ obj (Help.splitDots name ++ ["ctor"])
548+
549+ format isChars expr =
550+ if or isChars then
551+ InfixExpr () OpAdd expr (string "")
552+ else
553+ expr
300554
301555 Case.Fail ->
302− return [ ExprStmt () (Help.throw "badCase" region) ]
556+ return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
303557
304558 Case.Break ->
305559 return [BreakStmt () Nothing]
306560
307− Case.Other e ->
308− do e' <- expression e
309− return [ ret e' ]
561+ Case.Other expr ->
562+ toStatementList <$> exprToCode tcc expr
310563
311564 Case.Seq ms ->
312− concat <$> mapM (match region) (dropEnd [] ms)
565+ concat <$> mapM (match tcc) (dropEnd [] ms)
313566 where
314567 dropEnd acc [] = acc
315568 dropEnd acc (m:ms) =
@@ -318,9 +571,10 @@ match region mtch =
318571 _ -> dropEnd (acc ++ [m]) ms
319572
320573
321−clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
322−clause region variable (Case.Clause value vars mtch) =
323− (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
574+clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
575+clause tcc variable (Case.Clause value vars mtch) =
576+ do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
577+ return ((,) isChar (CaseClause () pattern statemens))
324578 where
325579 vars' =
326580 map (\n -> variable ++ "._" ++ show n) [0..]
@@ -337,14 +591,14 @@ clause region variable (Case.Clause value vars mtch) =
337591 string name
338592
339593
340−flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
594+flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
341595flattenLets defs lexpr@(A.A _ expr) =
342596 case expr of
343597 Let ds body -> flattenLets (defs ++ ds) body
344598 _ -> (defs, lexpr)
345599
346600
347−generate :: CanonicalModule -> String
601+generate :: Module.Optimized -> String
348602generate modul =
349603 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
350604 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
@@ -393,7 +647,7 @@ generate modul =
393647 Module.program (Module.body modul)
394648 |> flattenLets []
395649 |> fst
396− |> mapM definition
650+ |> mapM defToStatements
397651
398652 setup namespace path =
399653 map create paths
@@ -430,63 +684,104 @@ generate modul =
430684 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
431685
432686
687+-- BINARY OPERATORS
688+
433689binop
434− :: R.Region
435− -> Var.Canonical
436− -> Canonical.Expr
437− -> Canonical.Expr
438− -> State Int (Expression ())
439−binop region func@(Var.Canonical home op) e1 e2 =
440− case (home, op) of
441− (Var.Module ["Basics"], ">>") ->
442− do es <- mapM expression (collectLeftAssoc [e2] e1)
443− return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
444−
445− (Var.Module ["Basics"], "<<") ->
446− do es <- mapM expression (e1 : collectRightAssoc [] e2)
447− return $ ["$"] ==> foldr (<|) (ref "$") es
448−
449− (Var.Module ["Basics"], "<|") ->
450− do e2' <- expression e2
451− es <- mapM expression (collectRightAssoc [] e1)
452− return $ foldr (<|) e2' es
453−
454− (Var.BuiltIn, "::") ->
455− expression (A.A region (Data "::" [e1,e2]))
456−
457− (Var.Module ["Basics"], _) ->
458− do e1' <- expression e1
459− e2' <- expression e2
460− case Map.lookup op basicOps of
461− Just f ->
462− return (f e1' e2')
463−
464− Nothing ->
465− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
690+ :: Var.Canonical
691+ -> Opt.Expr
692+ -> Opt.Expr
693+ -> State Int Code
694+binop func left right
695+ | func == Var.Canonical Var.BuiltIn "::" =
696+ toCode (A.A () (Data "::" [left,right]))
466697
467− _ ->
468− do e1' <- expression e1
469− e2' <- expression e2
470− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
698+ | func == forwardCompose =
699+ compose (collectLeftAssoc forwardCompose left right)
471700
472− where
473− collectRightAssoc es e =
474− case e of
475− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
476− collectRightAssoc (es ++ [e1]) e2
477− _ -> es ++ [e]
478−
479− collectLeftAssoc es e =
480− case e of
481− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
482− collectLeftAssoc (e2 : es) e1
483− _ -> e : es
484−
485− basicOps =
486− Map.fromList (infixOps ++ specialOps)
487−
488− infixOps =
489− let infixOp str op = (str, InfixExpr () op) in
701+ | func == backwardCompose =
702+ compose (collectRightAssoc backwardCompose left right)
703+
704+ | func == forwardApply =
705+ pipe (collectLeftAssoc forwardApply left right)
706+
707+ | func == backwardApply =
708+ pipe (collectRightAssoc backwardApply left right)
709+
710+ | otherwise =
711+ do jsLeft <- toJsExpr left
712+ jsRight <- toJsExpr right
713+ jsExpr (makeExpr func jsLeft jsRight)
714+
715+
716+-- CONTROL FLOW OPERATOR HELPERS
717+
718+apply :: Expression () -> Expression () -> Expression ()
719+apply arg func =
720+ func <| arg
721+
722+
723+compose :: [Opt.Expr] -> State Int Code
724+compose functions =
725+ do jsFunctions <- mapM toJsExpr functions
726+ jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
727+
728+
729+pipe :: [Opt.Expr] -> State Int Code
730+pipe expressions =
731+ do (value:functions) <- mapM toJsExpr expressions
732+ jsExpr $ List.foldl' apply value functions
733+
734+
735+forwardCompose :: Var.Canonical
736+forwardCompose =
737+ inBasics ">>"
738+
739+
740+backwardCompose :: Var.Canonical
741+backwardCompose =
742+ inBasics "<<"
743+
744+
745+forwardApply :: Var.Canonical
746+forwardApply =
747+ inBasics "|>"
748+
749+
750+backwardApply :: Var.Canonical
751+backwardApply =
752+ inBasics "<|"
753+
754+
755+inBasics :: String -> Var.Canonical
756+inBasics name =
757+ Var.Canonical (Var.Module ["Basics"]) name
758+
759+
760+-- BINARY OPERATOR HELPERS
761+
762+makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
763+makeExpr qualifiedOp@(Var.Canonical home op) =
764+ let
765+ simpleMake left right =
766+ ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
767+ in
768+ if home == Var.Module ["Basics"] then
769+ Map.findWithDefault simpleMake op basicOps
770+ else
771+ simpleMake
772+
773+
774+basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
775+basicOps =
776+ Map.fromList (infixOps ++ specialOps)
777+
778+
779+infixOps :: [(String, Expression () -> Expression () -> Expression ())]
780+infixOps =
781+ let
782+ infixOp str op =
783+ (str, InfixExpr () op)
784+ in
490785 [ infixOp "+" OpAdd
491786 , infixOp "-" OpSub
492787 , infixOp "*" OpMul
@@ -495,17 +790,56 @@ binop region func@(Var.Canonical home op) e1 e2 =
495790 , infixOp "||" OpLOr
496791 ]
497792
498− specialOps =
499− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
500− , (,) "|>" $ flip (<|)
501− , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
502− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
503− , (,) "<" $ cmp OpLT 0
504− , (,) ">" $ cmp OpGT 0
505− , (,) "<=" $ cmp OpLT 1
506− , (,) ">=" $ cmp OpGT (-1)
507− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
508− ]
509793
510− cmp op n a b =
511− InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
794+specialOps :: [(String, Expression () -> Expression () -> Expression ())]
795+specialOps =
796+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
797+ , (,) "|>" $ flip (<|)
798+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
799+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
800+ , (,) "<" $ cmp OpLT 0
801+ , (,) ">" $ cmp OpGT 0
802+ , (,) "<=" $ cmp OpLT 1
803+ , (,) ">=" $ cmp OpGT (-1)
804+ , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
805+ ]
806+
807+
808+cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
809+cmp op n a b =
810+ InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
811+
812+
813+-- BINARY OPERATOR COLLECTORS
814+
815+-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
816+collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
817+collectRightAssoc desiredOp left right =
818+ collectRightAssocHelp desiredOp [left] right
819+
820+
821+collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
822+collectRightAssocHelp desiredOp exprList expr =
823+ case expr of
824+ A.A _ (Binop op left right) | op == desiredOp ->
825+ collectRightAssocHelp desiredOp (left : exprList) right
826+
827+ _ ->
828+ expr : exprList
829+
830+
831+-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
832+collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
833+collectLeftAssoc desiredOp left right =
834+ collectLeftAssocHelp desiredOp [right] left
835+
836+
837+collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
838+collectLeftAssocHelp desiredOp exprList expr =
839+ case expr of
840+ A.A _ (Binop op left right) | op == desiredOp ->
841+ collectLeftAssocHelp desiredOp (right : exprList) left
842+
843+ _ ->
844+ expr : exprList
845+