git.iko.soy/elk
on 30261e2 help sign in
elk/src/Generate/JavaScript/Expression.hs
610 lines 16 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
3 ( generateDecl
4 )
5 where
7import Control.Arrow (second)
8import Control.Monad.State (State, 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 qualified Optimize.DecisionTree as DT
30-- GENERATE DECLARATION
33generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> State Int [JS.Stmt]
34generateDecl home name def =
35 Var.defineGlobal home name <$> generateDef name def
39-- CODE CHUNKS
42data Code
43 = JsExpr JS.Expr
44 | JsBlock [JS.Stmt]
47jsExpr :: JS.Expr -> State Int Code
48jsExpr exp =
49 return (JsExpr exp)
52jsBlock :: [JS.Stmt] -> State Int Code
53jsBlock exp =
54 return (JsBlock exp)
57isBlock :: Code -> Bool
58isBlock code =
59 case code of
60 JsBlock _ -> True
61 JsExpr _ -> False
64toStatementList :: Code -> [JS.Stmt]
65toStatementList code =
66 case code of
67 JsExpr expr ->
68 [ JS.Return (Just expr) ]
70 JsBlock stmts ->
71 stmts
74toStatement :: Code -> JS.Stmt
75toStatement code =
76 case code of
77 JsExpr expr ->
78 JS.Return (Just expr)
80 JsBlock [stmt] ->
81 stmt
83 JsBlock stmts ->
84 JS.Block stmts
87toExpr :: Code -> JS.Expr
88toExpr code =
89 case code of
90 JsExpr expr ->
91 expr
93 JsBlock stmts ->
94 JS.Call (function [] stmts) []
98-- EXPRESSIONS
101generateJsExpr :: Opt.Expr -> State Int JS.Expr
102generateJsExpr optExpr =
103 toExpr <$> generateCode optExpr
106generateCode :: Opt.Expr -> State Int Code
107generateCode expr =
108 case expr of
109 VarLocal name ->
110 jsExpr $ Var.local name
112 VarGlobal home name ->
113 jsExpr $ Var.global home name
115 Literal lit ->
116 jsExpr (Literal.literal lit)
118 Access record field ->
119 do jsRecord <- generateJsExpr record
120 jsExpr $ JS.DotRef jsRecord (JS.Id (Var.safe field))
122 Update record fields ->
123 let
124 fieldToJs (field, value) =
125 do jsValue <- generateJsExpr value
126 return (Var.safe field, jsValue)
127 in
128 do jsRecord <- generateJsExpr record
129 jsFields <- mapM fieldToJs fields
130 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
132 Record fields ->
133 let
134 toField (field, value) =
135 do jsValue <- generateJsExpr value
136 return (Var.safe field ==> jsValue)
137 in
138 do jsFields <- mapM toField fields
139 jsExpr $ JS.Object jsFields
141 Binop home op leftExpr rightExpr ->
142 generateBinop home op leftExpr rightExpr
144 Function args body ->
145 generateFunction args body
147 Call func args ->
148 generateCall func args
150 TailCall name argNames args ->
151 let
152 reassign name tempName =
153 JS.ExprStmt $
154 JS.Assign (JS.LVar (Var.safe name)) (ref tempName)
155 in
156 do args' <- mapM generateJsExpr args
157 tempNames <- mapM (\_ -> Var.fresh) args
158 jsBlock $
159 JS.VarDeclStmt (zipWith varDecl tempNames args')
160 : zipWith reassign argNames tempNames
161 ++ [JS.Continue (Just (JS.Id (Var.safe name)))]
163 Let defs body ->
164 do stmts <- mapM generateLetDef defs
165 code <- generateCode body
166 jsBlock (stmts ++ toStatementList code)
168 If branches finally ->
169 generateIf branches finally
171 Case exprName decider jumps ->
172 JsBlock <$> generateCase exprName decider jumps
174 List elements ->
175 do jsElements <- mapM generateJsExpr elements
176 jsExpr $ BuiltIn.list jsElements
178 Ctor tag members ->
179 let
180 ctor =
181 "ctor" ==> JS.String tag
183 toEntry entry n =
184 ("_" <> Text.pack (show n)) ==> entry
185 in
186 do jsMembers <- mapM generateJsExpr members
187 jsExpr $ JS.Object (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
189 CtorAccess dataExpr index ->
190 do jsDataExpr <- generateJsExpr dataExpr
191 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))
193 Cmd moduleName _ ->
194 jsExpr $ BuiltIn.effect moduleName
196 Sub moduleName _ ->
197 jsExpr $ BuiltIn.effect moduleName
199 OutgoingPort name tipe ->
200 jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
202 IncomingPort name tipe ->
203 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
204 jsExpr $ BuiltIn.incomingPort name jsDecoder
206 Program kind body ->
207 generateProgram kind body
209 GLShader _uid src _tipe ->
210 jsExpr $ JS.Object [(JS.StringProp "src", Literal.literal (L.Str src))]
212 Crash home region maybeBranchProblem ->
213 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
214 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
218-- PROGRAMS
221generateProgram :: Can.Main -> Opt.Expr -> State Int Code
222generateProgram kind body =
223 case kind of
224 Can.VDom ->
225 do html <- generateJsExpr body
226 jsExpr (Var.staticProgram <| html)
228 Can.NoFlags ->
229 do almostProgram <- generateJsExpr body
230 jsExpr (JS.Call almostProgram [])
232 Can.Flags tipe ->
233 do almostProgram <- generateJsExpr body
234 flagDecoder <- generateJsExpr (Foreign.decode tipe)
235 jsExpr (almostProgram <| flagDecoder)
239-- DEFINITIONS
242generateLetDef :: (Text, Opt.Def) -> State Int JS.Stmt
243generateLetDef (name, def) =
244 do jsBody <- generateDef name def
245 return $ JS.VarDeclStmt [ Help.varDecl name jsBody ]
248generateDef :: Text -> Opt.Def -> State Int JS.Expr
249generateDef name def =
250 case def of
251 Opt.TailDef argNames body ->
252 generateTailFunction name argNames body
254 Opt.Def body ->
255 generateJsExpr body
258generateTailFunction :: Text -> [Text] -> Opt.Expr -> State Int JS.Expr
259generateTailFunction name args body =
260 do code <- generateCode body
261 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
262 JS.Labelled
263 (JS.Id (Var.safe name))
264 (JS.While (JS.Bool True) (toStatement code))
268-- FUNCTIONS
271generateFunction :: [Text] -> Opt.Expr -> State Int Code
272generateFunction args body =
273 do code <- generateCode body
274 jsExpr (generateFunctionWithArity args code)
277generateFunctionWithArity :: [Text] -> Code -> JS.Expr
278generateFunctionWithArity rawArgs code =
279 let
280 args = map Var.safe rawArgs
281 arity = length args
282 in
283 if 2 <= arity && arity <= 9 then
284 let
285 fN = "F" <> Text.pack (show arity)
286 in
287 ref fN <| function args (toStatementList code)
288 else
289 let
290 (lastArg:otherArgs) = reverse args
291 innerBody = function [lastArg] (toStatementList code)
292 in
293 foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs
297-- GENERATE CALL
300generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code
301generateCall func args =
302 case (func, args) of
303 (Opt.VarGlobal home name, [arg]) ->
304 case name of
305 "complement" | home == bitwise -> genPrefix JS.PrefixBNot arg
306 "not" | home == basics -> genPrefix JS.PrefixLNot arg
307 _ -> generateCallHelp func args
309 (Opt.VarGlobal home name, [ left, right ]) | home == bitwise ->
310 case name of
311 "and" -> genInfix JS.OpBAnd left right
312 "or" -> genInfix JS.OpBOr left right
313 "xor" -> genInfix JS.OpBXor left right
314 "shiftLeftBy" -> genInfix JS.OpLShift right left
315 "shiftRightBy" -> genInfix JS.OpSpRShift right left
316 "shiftRightZfBy" -> genInfix JS.OpZfRShift right left
317 _ -> generateCallHelp func args
319 _ ->
320 generateCallHelp func args
323genPrefix :: JS.PrefixOp -> Opt.Expr -> State Int Code
324genPrefix op arg =
325 do jsArg <- generateJsExpr arg
326 jsExpr (JS.Prefix op jsArg)
329genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> State Int Code
330genInfix op left right =
331 do jsLeft <- generateJsExpr left
332 jsRight <- generateJsExpr right
333 jsExpr $ JS.Infix op jsLeft jsRight
336basics :: ModuleName.Canonical
337basics =
338 ModuleName.inCore "Basics"
341bitwise :: ModuleName.Canonical
342bitwise =
343 ModuleName.inCore "Bitwise"
346generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code
347generateCallHelp func args =
348 let
349 arity = length args
350 aN = "A" <> Text.pack (show arity)
351 in
352 do jsFunc <- generateJsExpr func
353 jsArgs <- mapM generateJsExpr args
354 jsExpr $
355 if 2 <= arity && arity <= 9 then
356 JS.Call (ref aN) (jsFunc:jsArgs)
357 else
358 foldl1 (<|) (jsFunc:jsArgs)
362-- GENERATE IFS
365generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
366generateIf givenBranches givenFinally =
367 let
368 (branches, finally) =
369 crushIfs givenBranches givenFinally
371 convertBranch (condition, expr) =
372 (,) <$> generateJsExpr condition <*> generateCode expr
374 ifExpression (condition, branch) otherwise =
375 JS.If condition branch otherwise
377 ifStatement (condition, branch) otherwise =
378 JS.IfStmt condition branch otherwise
379 in
380 do jsBranches <- mapM convertBranch branches
381 jsFinally <- generateCode finally
383 if any isBlock (jsFinally : map snd jsBranches)
384 then
385 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
386 else
387 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
390crushIfs
391 :: [(Opt.Expr, Opt.Expr)]
392 -> Opt.Expr
393 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
394crushIfs branches finally =
395 crushIfsHelp [] branches finally
398crushIfsHelp
399 :: [(Opt.Expr, Opt.Expr)]
400 -> [(Opt.Expr, Opt.Expr)]
401 -> Opt.Expr
402 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
403crushIfsHelp visitedBranches unvisitedBranches finally =
404 case unvisitedBranches of
405 [] ->
406 case finally of
407 If subBranches subFinally ->
408 crushIfsHelp visitedBranches subBranches subFinally
410 _ ->
411 (reverse visitedBranches, finally)
413 (Literal (L.Boolean True), branch) : _ ->
414 crushIfsHelp visitedBranches [] branch
416 visiting : unvisited ->
417 crushIfsHelp (visiting : visitedBranches) unvisited finally
421-- CASE EXPRESSIONS
424generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> State Int [JS.Stmt]
425generateCase exprName decider jumps =
426 do labelRoot <- Var.fresh
427 decider <- generateDecider exprName labelRoot decider
428 foldM (goto labelRoot) decider jumps
432-- handle any jumps
435goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> State Int [JS.Stmt]
436goto labelRoot deciderStmts (target, branch) =
437 let
438 labeledDeciderStmt =
439 JS.Labelled
440 (toLabel labelRoot target)
441 (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))
442 in
443 do code <- generateCode branch
444 return (labeledDeciderStmt : toStatementList code)
447toLabel :: Text -> Int -> JS.Id
448toLabel root target =
449 JS.Id (root <> "_" <> Text.pack (show target))
453-- turn deciders into ifs and switches
456generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> State Int [JS.Stmt]
457generateDecider exprName labelRoot decisionTree =
458 case decisionTree of
459 Opt.Leaf (Opt.Inline branch) ->
460 toStatementList <$> generateCode branch
462 Opt.Leaf (Opt.Jump target) ->
463 return [ JS.Break (Just (toLabel labelRoot target)) ]
465 Opt.Chain testChain success failure ->
466 let
467 makeTest (path, test) =
468 do testExpr <- pathToTestableExpr exprName path test
469 return (JS.Infix JS.OpStrictEq testExpr (testToExpr test))
470 in
471 do testExprs <- mapM makeTest testChain
472 let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
473 thenBranch <- generateDecider exprName labelRoot success
474 elseBranch <- generateDecider exprName labelRoot failure
475 return [ JS.IfStmt cond (JS.Block thenBranch) (JS.Block elseBranch) ]
477 Opt.FanOut path edges fallback ->
478 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
479 caseClauses <- mapM (edgeToCase exprName labelRoot) edges
480 caseDefault <- JS.Default <$> generateDecider exprName labelRoot fallback
481 return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
484edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> State Int JS.Case
485edgeToCase exprName labelRoot (test, subTree) =
486 JS.Case (testToExpr test) <$> generateDecider exprName labelRoot subTree
489testToExpr :: DT.Test -> JS.Expr
490testToExpr test =
491 case test of
492 DT.Constructor (V.Canonical _ tag) ->
493 JS.String tag
495 DT.Literal (L.Chr char) ->
496 JS.String char
498 DT.Literal lit ->
499 Literal.literal lit
503-- work with paths
506pathToTestableExpr :: Text -> DT.Path -> DT.Test -> State Int JS.Expr
507pathToTestableExpr root path exampleTest =
508 do accessExpr <- generateJsExpr (pathToExpr root path)
509 case exampleTest of
510 DT.Constructor _ ->
511 return $ JS.DotRef accessExpr (JS.Id "ctor")
513 DT.Literal (L.Chr _) ->
514 return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
516 DT.Literal _ ->
517 return accessExpr
520pathToExpr :: Text -> DT.Path -> Opt.Expr
521pathToExpr root fullPath =
522 go (Opt.VarLocal root) fullPath
523 where
524 go expr path =
525 case path of
526 DT.Position index subpath ->
527 go (Opt.CtorAccess expr index) subpath
529 DT.Field field subpath ->
530 go (Opt.Access expr field) subpath
532 DT.Empty ->
533 expr
535 DT.Alias ->
536 expr
540-- BINARY OPERATORS
543generateBinop :: ModuleName.Canonical -> Text -> Opt.Expr -> Opt.Expr -> State Int Code
544generateBinop home op left right =
545 do jsLeft <- generateJsExpr left
546 jsRight <- generateJsExpr right
547 jsExpr (generateBinopHelp home op jsLeft jsRight)
551-- BINARY OPERATOR HELPERS
554generateBinopHelp :: ModuleName.Canonical -> Text -> JS.Expr -> JS.Expr -> JS.Expr
555generateBinopHelp home op leftExpr rightExpr =
556 let
557 simpleMake left right =
558 JS.Call (ref "A2") [ Var.global home op, left, right ]
559 in
560 if home == basics then
561 (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr
563 else if op == "::" && home == list then
564 BuiltIn.cons leftExpr rightExpr
566 else
567 simpleMake leftExpr rightExpr
570list :: ModuleName.Canonical
571list =
572 ModuleName.inCore "List"
575basicOps :: Map.Map Text (JS.Expr -> JS.Expr -> JS.Expr)
576basicOps =
577 Map.fromList (infixOps ++ specialOps)
580infixOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
581infixOps =
582 let
583 infixOp str op =
584 (str, JS.Infix op)
585 in
586 [ infixOp "+" JS.OpAdd
587 , infixOp "-" JS.OpSub
588 , infixOp "*" JS.OpMul
589 , infixOp "/" JS.OpDiv
590 , infixOp "&&" JS.OpLAnd
591 , infixOp "||" JS.OpLOr
592 ]
595specialOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
596specialOps =
597 [ (,) "^" $ \a b -> JS.Call (obj ["Math","pow"]) [a,b]
598 , (,) "==" $ \a b -> BuiltIn.eq a b
599 , (,) "/=" $ \a b -> JS.Prefix JS.PrefixLNot (BuiltIn.eq a b)
600 , (,) "<" $ cmp JS.OpLT 0
601 , (,) ">" $ cmp JS.OpGT 0
602 , (,) "<=" $ cmp JS.OpLT 1
603 , (,) ">=" $ cmp JS.OpGT (-1)
604 , (,) "//" $ \a b -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
605 ]
608cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
609cmp op n a b =
610 JS.Infix op (BuiltIn.cmp a b) (JS.Int n)