git.iko.soy/elk
on 8a89c86 help sign in
elk/src/Generate/JavaScript/Expression.hs
618 lines 17 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generateDecl
4 )
5 where
7import Prelude hiding (exp)
8import Control.Arrow (second)
9import Control.Monad (foldM)
10import qualified Data.List as List
11import qualified Data.Map as Map
12import Data.Monoid ((<>))
13import qualified Data.Text as Text
14import Data.Text (Text)
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.Literal as Literal
24import qualified Generate.JavaScript.Variable as Var
25import Generate.JavaScript.Variable (Generator)
26import qualified Optimize.DecisionTree as DT
30-- GENERATE DECLARATION
33generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> Generator JS.Stmt
34generateDecl home name def =
35 do jsName <- Var.globalName (V.Global home name)
36 jsBody <- generateDef name def
37 return $ JS.VarDeclStmt [ Help.varDecl jsName jsBody ]
41-- CODE CHUNKS
44data Code
45 = JsExpr JS.Expr
46 | JsBlock [JS.Stmt]
49jsExpr :: JS.Expr -> Generator Code
50jsExpr exp =
51 return (JsExpr exp)
54jsBlock :: [JS.Stmt] -> Generator Code
55jsBlock stmts =
56 return (JsBlock stmts)
59isBlock :: Code -> Bool
60isBlock code =
61 case code of
62 JsBlock _ -> True
63 JsExpr _ -> False
66toStatementList :: Code -> [JS.Stmt]
67toStatementList code =
68 case code of
69 JsExpr expr ->
70 [ JS.Return (Just expr) ]
72 JsBlock stmts ->
73 stmts
76toStatement :: Code -> JS.Stmt
77toStatement code =
78 case code of
79 JsExpr expr ->
80 JS.Return (Just expr)
82 JsBlock [stmt] ->
83 stmt
85 JsBlock stmts ->
86 JS.Block stmts
89toExpr :: Code -> JS.Expr
90toExpr code =
91 case code of
92 JsExpr expr ->
93 expr
95 JsBlock stmts ->
96 JS.Call (function [] stmts) []
100-- EXPRESSIONS
103generateJsExpr :: Opt.Expr -> Generator JS.Expr
104generateJsExpr optExpr =
105 toExpr <$> generateCode optExpr
108generateCode :: Opt.Expr -> Generator Code
109generateCode expr =
110 case expr of
111 VarLocal name ->
112 jsExpr $ Var.local name
114 VarGlobal name ->
115 JsExpr <$> Var.global name
117 Literal lit ->
118 JsExpr <$> Literal.literal lit
120 Access record field ->
121 do jsRecord <- generateJsExpr record
122 jsExpr $ JS.DotRef jsRecord (JS.Id (Var.safe field))
124 Update record fields ->
125 let
126 fieldToJs (field, value) =
127 do jsValue <- generateJsExpr value
128 return (Var.safe field, jsValue)
129 in
130 do jsRecord <- generateJsExpr record
131 jsFields <- mapM fieldToJs fields
132 JsExpr <$> BuiltIn.recordUpdate jsRecord jsFields
134 Record fields ->
135 let
136 toField (field, value) =
137 do jsValue <- generateJsExpr value
138 return (Var.safe field ==> jsValue)
139 in
140 do jsFields <- mapM toField fields
141 jsExpr $ JS.Object jsFields
143 Binop op leftExpr rightExpr ->
144 generateBinop op leftExpr rightExpr
146 Function args body ->
147 generateFunction args body
149 Call func args ->
150 generateCall func args
152 TailCall name argNames args ->
153 let
154 reassign argName tempName =
155 JS.ExprStmt $
156 JS.Assign (JS.LVar (Var.safe argName)) (ref tempName)
157 in
158 do args' <- mapM generateJsExpr args
159 tempNames <- mapM (\_ -> Var.fresh) args
160 jsBlock $
161 JS.VarDeclStmt (zipWith varDecl tempNames args')
162 : zipWith reassign argNames tempNames
163 ++ [JS.Continue (Just (JS.Id (Var.safe name)))]
165 Let defs body ->
166 do stmts <- mapM generateLetDef defs
167 code <- generateCode body
168 jsBlock (stmts ++ toStatementList code)
170 If branches finally ->
171 generateIf branches finally
173 Case exprName decider jumps ->
174 JsBlock <$> generateCase exprName decider jumps
176 List elements ->
177 do jsElements <- mapM generateJsExpr elements
178 JsExpr <$> BuiltIn.list jsElements
180 Ctor tag members ->
181 let
182 tagField =
183 "$" ==> JS.String tag
185 toEntry entry n =
186 (Help.toFieldName n) ==> entry
187 in
188 do jsMembers <- mapM generateJsExpr members
189 jsExpr $ JS.Object (tagField : zipWith toEntry jsMembers [ 0 :: Int .. ])
191 CtorAccess dataExpr index ->
192 do jsDataExpr <- generateJsExpr dataExpr
193 jsExpr $ JS.DotRef jsDataExpr (JS.Id (Help.toFieldName index))
195 Cmd moduleName _ ->
196 JsExpr <$> BuiltIn.effect moduleName
198 Sub moduleName _ ->
199 JsExpr <$> BuiltIn.effect moduleName
201 OutgoingPort name encoder ->
202 do jsEncoder <- generateJsExpr encoder
203 JsExpr <$> BuiltIn.outgoingPort name jsEncoder
205 IncomingPort name decoder ->
206 do jsDecoder <- generateJsExpr decoder
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 :: Opt.Main -> Opt.Expr -> Generator Code
226generateProgram kind body =
227 case kind of
228 Opt.Static ->
229 do html <- generateJsExpr body
230 func <- BuiltIn.staticProgram
231 jsExpr (func <| html)
233 Opt.Dynamic decoder ->
234 do almostProgram <- generateJsExpr body
235 flagDecoder <- generateJsExpr decoder
236 jsExpr (almostProgram <| flagDecoder)
240-- DEFINITIONS
243generateLetDef :: (Text, Opt.Def) -> Generator JS.Stmt
244generateLetDef (name, def) =
245 do jsBody <- generateDef name def
246 return $ JS.VarDeclStmt [ Help.varDecl (Var.safe name) jsBody ]
249generateDef :: Text -> Opt.Def -> Generator JS.Expr
250generateDef name def =
251 case def of
252 Opt.TailDef argNames body ->
253 generateTailFunction name argNames body
255 Opt.Def body ->
256 generateJsExpr body
259generateTailFunction :: Text -> [Text] -> Opt.Expr -> Generator JS.Expr
260generateTailFunction name args body =
261 do code <- generateCode body
262 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
263 JS.Labelled
264 (JS.Id (Var.safe name))
265 (JS.While (JS.Bool True) (toStatement code))
269-- FUNCTIONS
272generateFunction :: [Text] -> Opt.Expr -> Generator Code
273generateFunction args body =
274 do code <- generateCode body
275 jsExpr (generateFunctionWithArity args code)
278generateFunctionWithArity :: [Text] -> Code -> JS.Expr
279generateFunctionWithArity rawArgs code =
280 let
281 args = map Var.safe rawArgs
282 arity = length args
283 in
284 if 2 <= arity && arity <= 9 then
285 let
286 fN = "F" <> Text.pack (show arity)
287 in
288 ref fN <| function args (toStatementList code)
289 else
290 let
291 (lastArg:otherArgs) = reverse args
292 innerBody = function [lastArg] (toStatementList code)
293 in
294 foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs
298-- GENERATE CALL
301generateCall :: Opt.Expr -> [Opt.Expr] -> Generator Code
302generateCall func args =
303 case (func, args) of
304 (Opt.VarGlobal (V.Global home name), [arg]) ->
305 case name of
306 "complement" | home == bitwise -> genPrefix JS.PrefixBNot arg
307 "not" | home == basics -> genPrefix JS.PrefixLNot arg
308 _ -> generateCallHelp func args
310 (Opt.VarGlobal (V.Global home name), [ left, right ]) | home == bitwise ->
311 case name of
312 "and" -> genInfix JS.OpBAnd left right
313 "or" -> genInfix JS.OpBOr left right
314 "xor" -> genInfix JS.OpBXor left right
315 "shiftLeftBy" -> genInfix JS.OpLShift right left
316 "shiftRightBy" -> genInfix JS.OpSpRShift right left
317 "shiftRightZfBy" -> genInfix JS.OpZfRShift right left
318 _ -> generateCallHelp func args
320 _ ->
321 generateCallHelp func args
324genPrefix :: JS.PrefixOp -> Opt.Expr -> Generator Code
325genPrefix op arg =
326 do jsArg <- generateJsExpr arg
327 jsExpr (JS.Prefix op jsArg)
330genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> Generator Code
331genInfix op left right =
332 do jsLeft <- generateJsExpr left
333 jsRight <- generateJsExpr right
334 jsExpr $ JS.Infix op jsLeft jsRight
337basics :: ModuleName.Canonical
338basics =
339 ModuleName.inCore "Basics"
342bitwise :: ModuleName.Canonical
343bitwise =
344 ModuleName.inCore "Bitwise"
347generateCallHelp :: Opt.Expr -> [Opt.Expr] -> Generator Code
348generateCallHelp func args =
349 let
350 arity = length args
351 aN = "A" <> Text.pack (show arity)
352 in
353 do jsFunc <- generateJsExpr func
354 jsArgs <- mapM generateJsExpr args
355 jsExpr $
356 if 2 <= arity && arity <= 9 then
357 JS.Call (ref aN) (jsFunc:jsArgs)
358 else
359 foldl1 (<|) (jsFunc:jsArgs)
363-- GENERATE IFS
366generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Generator Code
367generateIf givenBranches givenFinally =
368 let
369 (branches, finally) =
370 crushIfs givenBranches givenFinally
372 convertBranch (condition, expr) =
373 (,) <$> generateJsExpr condition <*> generateCode expr
375 ifExpression (condition, branch) final =
376 JS.If condition branch final
378 ifStatement (condition, branch) final =
379 JS.IfStmt condition branch final
380 in
381 do jsBranches <- mapM convertBranch branches
382 jsFinally <- generateCode finally
384 if any isBlock (jsFinally : map snd jsBranches)
385 then
386 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
387 else
388 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
391crushIfs
392 :: [(Opt.Expr, Opt.Expr)]
393 -> Opt.Expr
394 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
395crushIfs branches finally =
396 crushIfsHelp [] branches finally
399crushIfsHelp
400 :: [(Opt.Expr, Opt.Expr)]
401 -> [(Opt.Expr, Opt.Expr)]
402 -> Opt.Expr
403 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
404crushIfsHelp visitedBranches unvisitedBranches finally =
405 case unvisitedBranches of
406 [] ->
407 case finally of
408 If subBranches subFinally ->
409 crushIfsHelp visitedBranches subBranches subFinally
411 _ ->
412 (reverse visitedBranches, finally)
414 (Literal (L.Boolean True), branch) : _ ->
415 crushIfsHelp visitedBranches [] branch
417 visiting : unvisited ->
418 crushIfsHelp (visiting : visitedBranches) unvisited finally
422-- CASE EXPRESSIONS
425generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> Generator [JS.Stmt]
426generateCase exprName decider jumps =
427 do labelRoot <- Var.fresh
428 jsDecider <- generateDecider exprName labelRoot decider
429 foldM (goto labelRoot) jsDecider jumps
433-- handle any jumps
436goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> Generator [JS.Stmt]
437goto labelRoot deciderStmts (target, branch) =
438 let
439 labeledDeciderStmt =
440 JS.Labelled
441 (toLabel labelRoot target)
442 (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))
443 in
444 do code <- generateCode branch
445 return (labeledDeciderStmt : toStatementList code)
448toLabel :: Text -> Int -> JS.Id
449toLabel root target =
450 JS.Id (root <> "_" <> Text.pack (show target))
454-- turn deciders into ifs and switches
457generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> Generator [JS.Stmt]
458generateDecider exprName labelRoot decisionTree =
459 case decisionTree of
460 Opt.Leaf (Opt.Inline branch) ->
461 toStatementList <$> generateCode branch
463 Opt.Leaf (Opt.Jump target) ->
464 return [ JS.Break (Just (toLabel labelRoot target)) ]
466 Opt.Chain testChain success failure ->
467 let
468 makeTest (path, test) =
469 do testExpr <- pathToTestableExpr exprName path test
470 JS.Infix JS.OpStrictEq testExpr <$> testToExpr test
471 in
472 do testExprs <- mapM makeTest testChain
473 let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
474 thenBranch <- generateDecider exprName labelRoot success
475 elseBranch <- generateDecider exprName labelRoot failure
476 return [ JS.IfStmt cond (JS.Block thenBranch) (JS.Block elseBranch) ]
478 Opt.FanOut path edges fallback ->
479 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
480 caseClauses <- mapM (edgeToCase exprName labelRoot) edges
481 caseDefault <- JS.Default <$> generateDecider exprName labelRoot fallback
482 return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
485edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> Generator JS.Case
486edgeToCase exprName labelRoot (test, subTree) =
487 JS.Case
488 <$> testToExpr test
489 <*> generateDecider exprName labelRoot subTree
492testToExpr :: DT.Test -> Generator JS.Expr
493testToExpr test =
494 case test of
495 DT.Constructor (V.Canonical _ tag) ->
496 return $ JS.String tag
498 DT.Literal (L.Chr char) ->
499 return $ JS.String char
501 DT.Literal lit ->
502 Literal.literal lit
506-- work with paths
509pathToTestableExpr :: Text -> DT.Path -> DT.Test -> Generator JS.Expr
510pathToTestableExpr root path exampleTest =
511 do accessExpr <- generateJsExpr (pathToExpr root path)
512 case exampleTest of
513 DT.Constructor _ ->
514 return $ JS.DotRef accessExpr (JS.Id "$")
516 DT.Literal (L.Chr _) ->
517 return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
519 DT.Literal _ ->
520 return accessExpr
523pathToExpr :: Text -> DT.Path -> Opt.Expr
524pathToExpr root fullPath =
525 go (Opt.VarLocal root) fullPath
526 where
527 go expr path =
528 case path of
529 DT.Position index subpath ->
530 go (Opt.CtorAccess expr index) subpath
532 DT.Field field subpath ->
533 go (Opt.Access expr field) subpath
535 DT.Empty ->
536 expr
538 DT.Alias ->
539 expr
543-- BINARY OPERATORS
546generateBinop :: V.Global -> Opt.Expr -> Opt.Expr -> Generator Code
547generateBinop op left right =
548 do jsLeft <- generateJsExpr left
549 jsRight <- generateJsExpr right
550 JsExpr <$> generateBinopHelp op jsLeft jsRight
554-- BINARY OPERATOR HELPERS
557generateBinopHelp :: V.Global -> JS.Expr -> JS.Expr -> Generator JS.Expr
558generateBinopHelp var@(V.Global home op) jsLeft jsRight =
559 let
560 simpleMake left right =
561 do func <- Var.global var
562 return $ JS.Call (ref "A2") [ func, left, right ]
563 in
564 if home == basics then
565 (Map.findWithDefault simpleMake op basicsOps) jsLeft jsRight
567 else if op == "::" && home == list then
568 BuiltIn.cons jsLeft jsRight
570 else
571 simpleMake jsLeft jsRight
574list :: ModuleName.Canonical
575list =
576 ModuleName.inCore "List"
579basicsOps :: Map.Map Text (JS.Expr -> JS.Expr -> Generator JS.Expr)
580basicsOps =
581 Map.fromList (basicsOpsNormal ++ basicsOpsSpecial)
584basicsOpsNormal :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
585basicsOpsNormal =
586 let
587 (=*>) str op =
588 ( str, \left right -> return (JS.Infix op left right) )
589 in
590 [ "+" =*> JS.OpAdd
591 , "-" =*> JS.OpSub
592 , "*" =*> JS.OpMul
593 , "/" =*> JS.OpDiv
594 , "&&" =*> JS.OpLAnd
595 , "||" =*> JS.OpLOr
596 ]
599basicsOpsSpecial :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
600basicsOpsSpecial =
601 let
602 (=*>) = (,)
603 in
604 [ "^" =*> \a b -> return $ JS.Call (obj ["Math","pow"]) [a,b]
605 , "==" =*> BuiltIn.eq
606 , "/=" =*> \a b -> JS.Prefix JS.PrefixLNot <$> BuiltIn.eq a b
607 , "<" =*> cmp JS.OpLT 0
608 , ">" =*> cmp JS.OpGT 0
609 , "<=" =*> cmp JS.OpLT 1
610 , ">=" =*> cmp JS.OpGT (-1)
611 , "//" =*> \a b -> return $ JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
612 ]
615cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> Generator JS.Expr
616cmp op n a b =
617 do ordering <- BuiltIn.cmp a b
618 return $ JS.Infix op ordering (JS.Int n)