git.iko.soy/elk
on ceb9175 help sign in
elk/src/Generate/JavaScript/Expression.hs
622 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 JsExpr <$> BuiltIn.outgoingPort name (Foreign.encode tipe)
205 IncomingPort name tipe ->
206 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
207 JsExpr <$> BuiltIn.incomingPort name jsDecoder
209 Program kind body ->
210 generateProgram kind body
212 GLShader src ->
213 do string <- Literal.literal (L.Str src)
214 jsExpr $ JS.Object [(JS.StringProp "src", string)]
216 Crash home region maybeBranchProblem ->
217 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
218 JsExpr <$> BuiltIn.crash home region maybeOptBranchProblem
222-- PROGRAMS
225generateProgram :: Can.Main -> Opt.Expr -> Generator Code
226generateProgram kind body =
227 case kind of
228 Can.VDom ->
229 do html <- generateJsExpr body
230 func <- BuiltIn.staticProgram
231 jsExpr (func <| html)
233 Can.NoFlags ->
234 do almostProgram <- generateJsExpr body
235 jsExpr (JS.Call almostProgram [])
237 Can.Flags tipe ->
238 do almostProgram <- generateJsExpr body
239 flagDecoder <- generateJsExpr (Foreign.decode tipe)
240 jsExpr (almostProgram <| flagDecoder)
244-- DEFINITIONS
247generateLetDef :: (Text, Opt.Def) -> Generator JS.Stmt
248generateLetDef (name, def) =
249 do jsBody <- generateDef name def
250 return $ JS.VarDeclStmt [ Help.varDecl name jsBody ]
253generateDef :: Text -> Opt.Def -> Generator JS.Expr
254generateDef name def =
255 case def of
256 Opt.TailDef argNames body ->
257 generateTailFunction name argNames body
259 Opt.Def body ->
260 generateJsExpr body
263generateTailFunction :: Text -> [Text] -> Opt.Expr -> Generator JS.Expr
264generateTailFunction name args body =
265 do code <- generateCode body
266 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
267 JS.Labelled
268 (JS.Id (Var.safe name))
269 (JS.While (JS.Bool True) (toStatement code))
273-- FUNCTIONS
276generateFunction :: [Text] -> Opt.Expr -> Generator Code
277generateFunction args body =
278 do code <- generateCode body
279 jsExpr (generateFunctionWithArity args code)
282generateFunctionWithArity :: [Text] -> Code -> JS.Expr
283generateFunctionWithArity rawArgs code =
284 let
285 args = map Var.safe rawArgs
286 arity = length args
287 in
288 if 2 <= arity && arity <= 9 then
289 let
290 fN = "F" <> Text.pack (show arity)
291 in
292 ref fN <| function args (toStatementList code)
293 else
294 let
295 (lastArg:otherArgs) = reverse args
296 innerBody = function [lastArg] (toStatementList code)
297 in
298 foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs
302-- GENERATE CALL
305generateCall :: Opt.Expr -> [Opt.Expr] -> Generator Code
306generateCall func args =
307 case (func, args) of
308 (Opt.VarGlobal (V.Global home name), [arg]) ->
309 case name of
310 "complement" | home == bitwise -> genPrefix JS.PrefixBNot arg
311 "not" | home == basics -> genPrefix JS.PrefixLNot arg
312 _ -> generateCallHelp func args
314 (Opt.VarGlobal (V.Global home name), [ left, right ]) | home == bitwise ->
315 case name of
316 "and" -> genInfix JS.OpBAnd left right
317 "or" -> genInfix JS.OpBOr left right
318 "xor" -> genInfix JS.OpBXor left right
319 "shiftLeftBy" -> genInfix JS.OpLShift right left
320 "shiftRightBy" -> genInfix JS.OpSpRShift right left
321 "shiftRightZfBy" -> genInfix JS.OpZfRShift right left
322 _ -> generateCallHelp func args
324 _ ->
325 generateCallHelp func args
328genPrefix :: JS.PrefixOp -> Opt.Expr -> Generator Code
329genPrefix op arg =
330 do jsArg <- generateJsExpr arg
331 jsExpr (JS.Prefix op jsArg)
334genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> Generator Code
335genInfix op left right =
336 do jsLeft <- generateJsExpr left
337 jsRight <- generateJsExpr right
338 jsExpr $ JS.Infix op jsLeft jsRight
341basics :: ModuleName.Canonical
342basics =
343 ModuleName.inCore "Basics"
346bitwise :: ModuleName.Canonical
347bitwise =
348 ModuleName.inCore "Bitwise"
351generateCallHelp :: Opt.Expr -> [Opt.Expr] -> Generator Code
352generateCallHelp func args =
353 let
354 arity = length args
355 aN = "A" <> Text.pack (show arity)
356 in
357 do jsFunc <- generateJsExpr func
358 jsArgs <- mapM generateJsExpr args
359 jsExpr $
360 if 2 <= arity && arity <= 9 then
361 JS.Call (ref aN) (jsFunc:jsArgs)
362 else
363 foldl1 (<|) (jsFunc:jsArgs)
367-- GENERATE IFS
370generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Generator Code
371generateIf givenBranches givenFinally =
372 let
373 (branches, finally) =
374 crushIfs givenBranches givenFinally
376 convertBranch (condition, expr) =
377 (,) <$> generateJsExpr condition <*> generateCode expr
379 ifExpression (condition, branch) otherwise =
380 JS.If condition branch otherwise
382 ifStatement (condition, branch) otherwise =
383 JS.IfStmt condition branch otherwise
384 in
385 do jsBranches <- mapM convertBranch branches
386 jsFinally <- generateCode finally
388 if any isBlock (jsFinally : map snd jsBranches)
389 then
390 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
391 else
392 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
395crushIfs
396 :: [(Opt.Expr, Opt.Expr)]
397 -> Opt.Expr
398 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
399crushIfs branches finally =
400 crushIfsHelp [] branches finally
403crushIfsHelp
404 :: [(Opt.Expr, Opt.Expr)]
405 -> [(Opt.Expr, Opt.Expr)]
406 -> Opt.Expr
407 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
408crushIfsHelp visitedBranches unvisitedBranches finally =
409 case unvisitedBranches of
410 [] ->
411 case finally of
412 If subBranches subFinally ->
413 crushIfsHelp visitedBranches subBranches subFinally
415 _ ->
416 (reverse visitedBranches, finally)
418 (Literal (L.Boolean True), branch) : _ ->
419 crushIfsHelp visitedBranches [] branch
421 visiting : unvisited ->
422 crushIfsHelp (visiting : visitedBranches) unvisited finally
426-- CASE EXPRESSIONS
429generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> Generator [JS.Stmt]
430generateCase exprName decider jumps =
431 do labelRoot <- Var.fresh
432 decider <- generateDecider exprName labelRoot decider
433 foldM (goto labelRoot) decider jumps
437-- handle any jumps
440goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> Generator [JS.Stmt]
441goto labelRoot deciderStmts (target, branch) =
442 let
443 labeledDeciderStmt =
444 JS.Labelled
445 (toLabel labelRoot target)
446 (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))
447 in
448 do code <- generateCode branch
449 return (labeledDeciderStmt : toStatementList code)
452toLabel :: Text -> Int -> JS.Id
453toLabel root target =
454 JS.Id (root <> "_" <> Text.pack (show target))
458-- turn deciders into ifs and switches
461generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> Generator [JS.Stmt]
462generateDecider exprName labelRoot decisionTree =
463 case decisionTree of
464 Opt.Leaf (Opt.Inline branch) ->
465 toStatementList <$> generateCode branch
467 Opt.Leaf (Opt.Jump target) ->
468 return [ JS.Break (Just (toLabel labelRoot target)) ]
470 Opt.Chain testChain success failure ->
471 let
472 makeTest (path, test) =
473 do testExpr <- pathToTestableExpr exprName path test
474 JS.Infix JS.OpStrictEq testExpr <$> testToExpr test
475 in
476 do testExprs <- mapM makeTest testChain
477 let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
478 thenBranch <- generateDecider exprName labelRoot success
479 elseBranch <- generateDecider exprName labelRoot failure
480 return [ JS.IfStmt cond (JS.Block thenBranch) (JS.Block elseBranch) ]
482 Opt.FanOut path edges fallback ->
483 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
484 caseClauses <- mapM (edgeToCase exprName labelRoot) edges
485 caseDefault <- JS.Default <$> generateDecider exprName labelRoot fallback
486 return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
489edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> Generator JS.Case
490edgeToCase exprName labelRoot (test, subTree) =
491 JS.Case
492 <$> testToExpr test
493 <*> generateDecider exprName labelRoot subTree
496testToExpr :: DT.Test -> Generator JS.Expr
497testToExpr test =
498 case test of
499 DT.Constructor (V.Canonical _ tag) ->
500 return $ JS.String tag
502 DT.Literal (L.Chr char) ->
503 return $ JS.String char
505 DT.Literal lit ->
506 Literal.literal lit
510-- work with paths
513pathToTestableExpr :: Text -> DT.Path -> DT.Test -> Generator JS.Expr
514pathToTestableExpr root path exampleTest =
515 do accessExpr <- generateJsExpr (pathToExpr root path)
516 case exampleTest of
517 DT.Constructor _ ->
518 return $ JS.DotRef accessExpr (JS.Id "ctor")
520 DT.Literal (L.Chr _) ->
521 return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
523 DT.Literal _ ->
524 return accessExpr
527pathToExpr :: Text -> DT.Path -> Opt.Expr
528pathToExpr root fullPath =
529 go (Opt.VarLocal root) fullPath
530 where
531 go expr path =
532 case path of
533 DT.Position index subpath ->
534 go (Opt.CtorAccess expr index) subpath
536 DT.Field field subpath ->
537 go (Opt.Access expr field) subpath
539 DT.Empty ->
540 expr
542 DT.Alias ->
543 expr
547-- BINARY OPERATORS
550generateBinop :: V.Global -> Opt.Expr -> Opt.Expr -> Generator Code
551generateBinop op left right =
552 do jsLeft <- generateJsExpr left
553 jsRight <- generateJsExpr right
554 JsExpr <$> generateBinopHelp op jsLeft jsRight
558-- BINARY OPERATOR HELPERS
561generateBinopHelp :: V.Global -> JS.Expr -> JS.Expr -> Generator JS.Expr
562generateBinopHelp var@(V.Global home op) jsLeft jsRight =
563 let
564 simpleMake left right =
565 do func <- Var.global var
566 return $ JS.Call (ref "A2") [ func, left, right ]
567 in
568 if home == basics then
569 (Map.findWithDefault simpleMake op basicsOps) jsLeft jsRight
571 else if op == "::" && home == list then
572 BuiltIn.cons jsLeft jsRight
574 else
575 simpleMake jsLeft jsRight
578list :: ModuleName.Canonical
579list =
580 ModuleName.inCore "List"
583basicsOps :: Map.Map Text (JS.Expr -> JS.Expr -> Generator JS.Expr)
584basicsOps =
585 Map.fromList (basicsOpsNormal ++ basicsOpsSpecial)
588basicsOpsNormal :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
589basicsOpsNormal =
590 let
591 (=*>) str op =
592 ( str, \left right -> return (JS.Infix op left right) )
593 in
594 [ "+" =*> JS.OpAdd
595 , "-" =*> JS.OpSub
596 , "*" =*> JS.OpMul
597 , "/" =*> JS.OpDiv
598 , "&&" =*> JS.OpLAnd
599 , "||" =*> JS.OpLOr
600 ]
603basicsOpsSpecial :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
604basicsOpsSpecial =
605 let
606 (=*>) = (,)
607 in
608 [ "^" =*> \a b -> return $ JS.Call (obj ["Math","pow"]) [a,b]
609 , "==" =*> BuiltIn.eq
610 , "/=" =*> \a b -> JS.Prefix JS.PrefixLNot <$> BuiltIn.eq a b
611 , "<" =*> cmp JS.OpLT 0
612 , ">" =*> cmp JS.OpGT 0
613 , "<=" =*> cmp JS.OpLT 1
614 , ">=" =*> cmp JS.OpGT (-1)
615 , "//" =*> \a b -> return $ JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
616 ]
619cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> Generator JS.Expr
620cmp op n a b =
621 do ordering <- BuiltIn.cmp a b
622 return $ JS.Infix op ordering (JS.Int n)