git.iko.soy/elk
on f775024 help sign in
elk/src/Generate/JavaScript/Expression.hs
623 lines 17 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generateDecl
4 )
5 where
7import Control.Arrow (second)
8import Control.Monad (foldM)
9import qualified Data.List as List
10import qualified Data.Map as Map
11import Data.Monoid ((<>))
12import qualified Data.Text as Text
13import Data.Text (Text)
15import qualified AST.Expression.Canonical as Can
16import AST.Expression.Optimized as Opt
17import qualified AST.Literal as L
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Variable as V
20import Generate.JavaScript.Helpers as Help
21import qualified Generate.JavaScript.Builder as JS
22import qualified Generate.JavaScript.BuiltIn as BuiltIn
23import qualified Generate.JavaScript.Foreign as Foreign
24import qualified Generate.JavaScript.Literal as Literal
25import qualified Generate.JavaScript.Variable as Var
26import Generate.JavaScript.Variable (Generator)
27import qualified Optimize.DecisionTree as DT
31-- GENERATE DECLARATION
34generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> Generator JS.Stmt
35generateDecl home name def =
36 do jsName <- Var.getGlobalName (V.Global home name)
37 jsBody <- generateDef name def
38 return $ JS.VarDeclStmt [ Help.varDecl jsName jsBody ]
42-- CODE CHUNKS
45data Code
46 = JsExpr JS.Expr
47 | JsBlock [JS.Stmt]
50jsExpr :: JS.Expr -> Generator Code
51jsExpr exp =
52 return (JsExpr exp)
55jsBlock :: [JS.Stmt] -> Generator Code
56jsBlock exp =
57 return (JsBlock exp)
60isBlock :: Code -> Bool
61isBlock code =
62 case code of
63 JsBlock _ -> True
64 JsExpr _ -> False
67toStatementList :: Code -> [JS.Stmt]
68toStatementList code =
69 case code of
70 JsExpr expr ->
71 [ JS.Return (Just expr) ]
73 JsBlock stmts ->
74 stmts
77toStatement :: Code -> JS.Stmt
78toStatement code =
79 case code of
80 JsExpr expr ->
81 JS.Return (Just expr)
83 JsBlock [stmt] ->
84 stmt
86 JsBlock stmts ->
87 JS.Block stmts
90toExpr :: Code -> JS.Expr
91toExpr code =
92 case code of
93 JsExpr expr ->
94 expr
96 JsBlock stmts ->
97 JS.Call (function [] stmts) []
101-- EXPRESSIONS
104generateJsExpr :: Opt.Expr -> Generator JS.Expr
105generateJsExpr optExpr =
106 toExpr <$> generateCode optExpr
109generateCode :: Opt.Expr -> Generator Code
110generateCode expr =
111 case expr of
112 VarLocal name ->
113 jsExpr $ Var.local name
115 VarGlobal name ->
116 JsExpr <$> Var.global name
118 Literal lit ->
119 JsExpr <$> Literal.literal lit
121 Access record field ->
122 do jsRecord <- generateJsExpr record
123 jsExpr $ JS.DotRef jsRecord (JS.Id (Var.safe field))
125 Update record fields ->
126 let
127 fieldToJs (field, value) =
128 do jsValue <- generateJsExpr value
129 return (Var.safe field, jsValue)
130 in
131 do jsRecord <- generateJsExpr record
132 jsFields <- mapM fieldToJs fields
133 JsExpr <$> BuiltIn.recordUpdate jsRecord jsFields
135 Record fields ->
136 let
137 toField (field, value) =
138 do jsValue <- generateJsExpr value
139 return (Var.safe field ==> jsValue)
140 in
141 do jsFields <- mapM toField fields
142 jsExpr $ JS.Object jsFields
144 Binop op leftExpr rightExpr ->
145 generateBinop op leftExpr rightExpr
147 Function args body ->
148 generateFunction args body
150 Call func args ->
151 generateCall func args
153 TailCall name argNames args ->
154 let
155 reassign name tempName =
156 JS.ExprStmt $
157 JS.Assign (JS.LVar (Var.safe name)) (ref tempName)
158 in
159 do args' <- mapM generateJsExpr args
160 tempNames <- mapM (\_ -> Var.fresh) args
161 jsBlock $
162 JS.VarDeclStmt (zipWith varDecl tempNames args')
163 : zipWith reassign argNames tempNames
164 ++ [JS.Continue (Just (JS.Id (Var.safe name)))]
166 Let defs body ->
167 do stmts <- mapM generateLetDef defs
168 code <- generateCode body
169 jsBlock (stmts ++ toStatementList code)
171 If branches finally ->
172 generateIf branches finally
174 Case exprName decider jumps ->
175 JsBlock <$> generateCase exprName decider jumps
177 List elements ->
178 do jsElements <- mapM generateJsExpr elements
179 JsExpr <$> BuiltIn.list jsElements
181 Ctor tag members ->
182 let
183 ctor =
184 "ctor" ==> JS.String tag
186 toEntry entry n =
187 ("_" <> Text.pack (show n)) ==> entry
188 in
189 do jsMembers <- mapM generateJsExpr members
190 jsExpr $ JS.Object (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
192 CtorAccess dataExpr index ->
193 do jsDataExpr <- generateJsExpr dataExpr
194 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))
196 Cmd moduleName _ ->
197 JsExpr <$> BuiltIn.effect moduleName
199 Sub moduleName _ ->
200 JsExpr <$> BuiltIn.effect moduleName
202 OutgoingPort name tipe ->
203 do encoder <- Foreign.encode tipe
204 JsExpr <$> BuiltIn.outgoingPort name encoder
206 IncomingPort name tipe ->
207 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
208 JsExpr <$> BuiltIn.incomingPort name jsDecoder
210 Program kind body ->
211 generateProgram kind body
213 GLShader src ->
214 do string <- Literal.literal (L.Str src)
215 jsExpr $ JS.Object [(JS.StringProp "src", string)]
217 Crash home region maybeBranchProblem ->
218 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
219 JsExpr <$> BuiltIn.crash home region maybeOptBranchProblem
223-- PROGRAMS
226generateProgram :: Can.Main -> Opt.Expr -> Generator Code
227generateProgram kind body =
228 case kind of
229 Can.VDom ->
230 do html <- generateJsExpr body
231 func <- BuiltIn.staticProgram
232 jsExpr (func <| html)
234 Can.NoFlags ->
235 do almostProgram <- generateJsExpr body
236 jsExpr (JS.Call almostProgram [])
238 Can.Flags tipe ->
239 do almostProgram <- generateJsExpr body
240 flagDecoder <- generateJsExpr (Foreign.decode tipe)
241 jsExpr (almostProgram <| flagDecoder)
245-- DEFINITIONS
248generateLetDef :: (Text, Opt.Def) -> Generator JS.Stmt
249generateLetDef (name, def) =
250 do jsBody <- generateDef name def
251 return $ JS.VarDeclStmt [ Help.varDecl name jsBody ]
254generateDef :: Text -> Opt.Def -> Generator JS.Expr
255generateDef name def =
256 case def of
257 Opt.TailDef argNames body ->
258 generateTailFunction name argNames body
260 Opt.Def body ->
261 generateJsExpr body
264generateTailFunction :: Text -> [Text] -> Opt.Expr -> Generator JS.Expr
265generateTailFunction name args body =
266 do code <- generateCode body
267 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
268 JS.Labelled
269 (JS.Id (Var.safe name))
270 (JS.While (JS.Bool True) (toStatement code))
274-- FUNCTIONS
277generateFunction :: [Text] -> Opt.Expr -> Generator Code
278generateFunction args body =
279 do code <- generateCode body
280 jsExpr (generateFunctionWithArity args code)
283generateFunctionWithArity :: [Text] -> Code -> JS.Expr
284generateFunctionWithArity rawArgs code =
285 let
286 args = map Var.safe rawArgs
287 arity = length args
288 in
289 if 2 <= arity && arity <= 9 then
290 let
291 fN = "F" <> Text.pack (show arity)
292 in
293 ref fN <| function args (toStatementList code)
294 else
295 let
296 (lastArg:otherArgs) = reverse args
297 innerBody = function [lastArg] (toStatementList code)
298 in
299 foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs
303-- GENERATE CALL
306generateCall :: Opt.Expr -> [Opt.Expr] -> Generator Code
307generateCall func args =
308 case (func, args) of
309 (Opt.VarGlobal (V.Global home name), [arg]) ->
310 case name of
311 "complement" | home == bitwise -> genPrefix JS.PrefixBNot arg
312 "not" | home == basics -> genPrefix JS.PrefixLNot arg
313 _ -> generateCallHelp func args
315 (Opt.VarGlobal (V.Global home name), [ left, right ]) | home == bitwise ->
316 case name of
317 "and" -> genInfix JS.OpBAnd left right
318 "or" -> genInfix JS.OpBOr left right
319 "xor" -> genInfix JS.OpBXor left right
320 "shiftLeftBy" -> genInfix JS.OpLShift right left
321 "shiftRightBy" -> genInfix JS.OpSpRShift right left
322 "shiftRightZfBy" -> genInfix JS.OpZfRShift right left
323 _ -> generateCallHelp func args
325 _ ->
326 generateCallHelp func args
329genPrefix :: JS.PrefixOp -> Opt.Expr -> Generator Code
330genPrefix op arg =
331 do jsArg <- generateJsExpr arg
332 jsExpr (JS.Prefix op jsArg)
335genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> Generator Code
336genInfix op left right =
337 do jsLeft <- generateJsExpr left
338 jsRight <- generateJsExpr right
339 jsExpr $ JS.Infix op jsLeft jsRight
342basics :: ModuleName.Canonical
343basics =
344 ModuleName.inCore "Basics"
347bitwise :: ModuleName.Canonical
348bitwise =
349 ModuleName.inCore "Bitwise"
352generateCallHelp :: Opt.Expr -> [Opt.Expr] -> Generator Code
353generateCallHelp func args =
354 let
355 arity = length args
356 aN = "A" <> Text.pack (show arity)
357 in
358 do jsFunc <- generateJsExpr func
359 jsArgs <- mapM generateJsExpr args
360 jsExpr $
361 if 2 <= arity && arity <= 9 then
362 JS.Call (ref aN) (jsFunc:jsArgs)
363 else
364 foldl1 (<|) (jsFunc:jsArgs)
368-- GENERATE IFS
371generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Generator Code
372generateIf givenBranches givenFinally =
373 let
374 (branches, finally) =
375 crushIfs givenBranches givenFinally
377 convertBranch (condition, expr) =
378 (,) <$> generateJsExpr condition <*> generateCode expr
380 ifExpression (condition, branch) otherwise =
381 JS.If condition branch otherwise
383 ifStatement (condition, branch) otherwise =
384 JS.IfStmt condition branch otherwise
385 in
386 do jsBranches <- mapM convertBranch branches
387 jsFinally <- generateCode finally
389 if any isBlock (jsFinally : map snd jsBranches)
390 then
391 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
392 else
393 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
396crushIfs
397 :: [(Opt.Expr, Opt.Expr)]
398 -> Opt.Expr
399 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
400crushIfs branches finally =
401 crushIfsHelp [] branches finally
404crushIfsHelp
405 :: [(Opt.Expr, Opt.Expr)]
406 -> [(Opt.Expr, Opt.Expr)]
407 -> Opt.Expr
408 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
409crushIfsHelp visitedBranches unvisitedBranches finally =
410 case unvisitedBranches of
411 [] ->
412 case finally of
413 If subBranches subFinally ->
414 crushIfsHelp visitedBranches subBranches subFinally
416 _ ->
417 (reverse visitedBranches, finally)
419 (Literal (L.Boolean True), branch) : _ ->
420 crushIfsHelp visitedBranches [] branch
422 visiting : unvisited ->
423 crushIfsHelp (visiting : visitedBranches) unvisited finally
427-- CASE EXPRESSIONS
430generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> Generator [JS.Stmt]
431generateCase exprName decider jumps =
432 do labelRoot <- Var.fresh
433 decider <- generateDecider exprName labelRoot decider
434 foldM (goto labelRoot) decider jumps
438-- handle any jumps
441goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> Generator [JS.Stmt]
442goto labelRoot deciderStmts (target, branch) =
443 let
444 labeledDeciderStmt =
445 JS.Labelled
446 (toLabel labelRoot target)
447 (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))
448 in
449 do code <- generateCode branch
450 return (labeledDeciderStmt : toStatementList code)
453toLabel :: Text -> Int -> JS.Id
454toLabel root target =
455 JS.Id (root <> "_" <> Text.pack (show target))
459-- turn deciders into ifs and switches
462generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> Generator [JS.Stmt]
463generateDecider exprName labelRoot decisionTree =
464 case decisionTree of
465 Opt.Leaf (Opt.Inline branch) ->
466 toStatementList <$> generateCode branch
468 Opt.Leaf (Opt.Jump target) ->
469 return [ JS.Break (Just (toLabel labelRoot target)) ]
471 Opt.Chain testChain success failure ->
472 let
473 makeTest (path, test) =
474 do testExpr <- pathToTestableExpr exprName path test
475 JS.Infix JS.OpStrictEq testExpr <$> testToExpr test
476 in
477 do testExprs <- mapM makeTest testChain
478 let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
479 thenBranch <- generateDecider exprName labelRoot success
480 elseBranch <- generateDecider exprName labelRoot failure
481 return [ JS.IfStmt cond (JS.Block thenBranch) (JS.Block elseBranch) ]
483 Opt.FanOut path edges fallback ->
484 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
485 caseClauses <- mapM (edgeToCase exprName labelRoot) edges
486 caseDefault <- JS.Default <$> generateDecider exprName labelRoot fallback
487 return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
490edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> Generator JS.Case
491edgeToCase exprName labelRoot (test, subTree) =
492 JS.Case
493 <$> testToExpr test
494 <*> generateDecider exprName labelRoot subTree
497testToExpr :: DT.Test -> Generator JS.Expr
498testToExpr test =
499 case test of
500 DT.Constructor (V.Canonical _ tag) ->
501 return $ JS.String tag
503 DT.Literal (L.Chr char) ->
504 return $ JS.String char
506 DT.Literal lit ->
507 Literal.literal lit
511-- work with paths
514pathToTestableExpr :: Text -> DT.Path -> DT.Test -> Generator JS.Expr
515pathToTestableExpr root path exampleTest =
516 do accessExpr <- generateJsExpr (pathToExpr root path)
517 case exampleTest of
518 DT.Constructor _ ->
519 return $ JS.DotRef accessExpr (JS.Id "ctor")
521 DT.Literal (L.Chr _) ->
522 return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
524 DT.Literal _ ->
525 return accessExpr
528pathToExpr :: Text -> DT.Path -> Opt.Expr
529pathToExpr root fullPath =
530 go (Opt.VarLocal root) fullPath
531 where
532 go expr path =
533 case path of
534 DT.Position index subpath ->
535 go (Opt.CtorAccess expr index) subpath
537 DT.Field field subpath ->
538 go (Opt.Access expr field) subpath
540 DT.Empty ->
541 expr
543 DT.Alias ->
544 expr
548-- BINARY OPERATORS
551generateBinop :: V.Global -> Opt.Expr -> Opt.Expr -> Generator Code
552generateBinop op left right =
553 do jsLeft <- generateJsExpr left
554 jsRight <- generateJsExpr right
555 JsExpr <$> generateBinopHelp op jsLeft jsRight
559-- BINARY OPERATOR HELPERS
562generateBinopHelp :: V.Global -> JS.Expr -> JS.Expr -> Generator JS.Expr
563generateBinopHelp var@(V.Global home op) jsLeft jsRight =
564 let
565 simpleMake left right =
566 do func <- Var.global var
567 return $ JS.Call (ref "A2") [ func, left, right ]
568 in
569 if home == basics then
570 (Map.findWithDefault simpleMake op basicsOps) jsLeft jsRight
572 else if op == "::" && home == list then
573 BuiltIn.cons jsLeft jsRight
575 else
576 simpleMake jsLeft jsRight
579list :: ModuleName.Canonical
580list =
581 ModuleName.inCore "List"
584basicsOps :: Map.Map Text (JS.Expr -> JS.Expr -> Generator JS.Expr)
585basicsOps =
586 Map.fromList (basicsOpsNormal ++ basicsOpsSpecial)
589basicsOpsNormal :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
590basicsOpsNormal =
591 let
592 (=*>) str op =
593 ( str, \left right -> return (JS.Infix op left right) )
594 in
595 [ "+" =*> JS.OpAdd
596 , "-" =*> JS.OpSub
597 , "*" =*> JS.OpMul
598 , "/" =*> JS.OpDiv
599 , "&&" =*> JS.OpLAnd
600 , "||" =*> JS.OpLOr
601 ]
604basicsOpsSpecial :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
605basicsOpsSpecial =
606 let
607 (=*>) = (,)
608 in
609 [ "^" =*> \a b -> return $ JS.Call (obj ["Math","pow"]) [a,b]
610 , "==" =*> BuiltIn.eq
611 , "/=" =*> \a b -> JS.Prefix JS.PrefixLNot <$> BuiltIn.eq a b
612 , "<" =*> cmp JS.OpLT 0
613 , ">" =*> cmp JS.OpGT 0
614 , "<=" =*> cmp JS.OpLT 1
615 , ">=" =*> cmp JS.OpGT (-1)
616 , "//" =*> \a b -> return $ JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
617 ]
620cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> Generator JS.Expr
621cmp op n a b =
622 do ordering <- BuiltIn.cmp a b
623 return $ JS.Infix op ordering (JS.Int n)