git.iko.soy/elk
on 442ac09 help sign in
elk/src/Generate/JavaScript/Expression.hs
629 lines 17 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression (generateDef) where
4import Control.Arrow (second)
5import Control.Monad.State (State, foldM)
6import qualified Data.List as List
7import qualified Data.Map as Map
8import Data.Monoid ((<>))
9import qualified Data.Text as Text
10import Data.Text (Text)
12import qualified AST.Expression.Canonical as Can
13import AST.Expression.Optimized as Opt
14import qualified AST.Literal as L
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Variable as Var
17import Generate.JavaScript.Helpers as Help
18import qualified Generate.JavaScript.Builder as JS
19import qualified Generate.JavaScript.BuiltIn as BuiltIn
20import qualified Generate.JavaScript.Foreign as Foreign
21import qualified Generate.JavaScript.Literal as Literal
22import qualified Generate.JavaScript.Variable as Var
23import qualified Optimize.DecisionTree as DT
27-- CODE CHUNKS
30data Code
31 = JsExpr JS.Expr
32 | JsBlock [JS.Stmt]
35jsExpr :: JS.Expr -> State Int Code
36jsExpr exp =
37 return (JsExpr exp)
40jsBlock :: [JS.Stmt] -> State Int Code
41jsBlock exp =
42 return (JsBlock exp)
45isBlock :: Code -> Bool
46isBlock code =
47 case code of
48 JsBlock _ -> True
49 JsExpr _ -> False
52toStatementList :: Code -> [JS.Stmt]
53toStatementList code =
54 case code of
55 JsExpr expr ->
56 [ JS.Return (Just expr) ]
58 JsBlock stmts ->
59 stmts
62toStatement :: Code -> JS.Stmt
63toStatement code =
64 case code of
65 JsExpr expr ->
66 JS.Return (Just expr)
68 JsBlock [stmt] ->
69 stmt
71 JsBlock stmts ->
72 JS.Block stmts
75toExpr :: Code -> JS.Expr
76toExpr code =
77 case code of
78 JsExpr expr ->
79 expr
81 JsBlock stmts ->
82 JS.Call (function [] stmts) []
86-- DEFINITIONS
89generateDef :: Opt.Def -> State Int [JS.Stmt]
90generateDef def =
91 do (home, name, jsBody) <-
92 case def of
93 Opt.TailDef (Opt.Facts home) name argNames body ->
94 (,,) home name <$> generateTailFunction name argNames body
96 Opt.Def (Opt.Facts home) name body ->
97 (,,) home name <$> generateJsExpr body
99 return (Var.define home name jsBody)
103-- EXPRESSIONS
106generateJsExpr :: Opt.Expr -> State Int JS.Expr
107generateJsExpr optExpr =
108 toExpr <$> generateCode optExpr
111generateCode :: Opt.Expr -> State Int Code
112generateCode expr =
113 case expr of
114 Var var ->
115 jsExpr $ Var.canonical var
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 binop 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 name tempName =
155 JS.ExprStmt $
156 JS.Assign JS.OpAssign (JS.LVar (Var.safe name)) (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 generateDef defs
167 code <- generateCode body
168 jsBlock (concat 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 ctor =
183 "ctor" ==> JS.String tag
185 toEntry entry n =
186 ("_" <> Text.pack (show n)) ==> entry
187 in
188 do jsMembers <- mapM generateJsExpr members
189 jsExpr $ JS.Object (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
191 CtorAccess dataExpr index ->
192 do jsDataExpr <- generateJsExpr dataExpr
193 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))
195 Cmd moduleName ->
196 jsExpr $ BuiltIn.effect moduleName
198 Sub moduleName ->
199 jsExpr $ BuiltIn.effect moduleName
201 OutgoingPort name tipe ->
202 jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
204 IncomingPort name tipe ->
205 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
206 jsExpr $ BuiltIn.incomingPort name jsDecoder
208 Program kind body ->
209 generateProgram kind body
211 GLShader _uid src _tipe ->
212 jsExpr $ JS.Object [(JS.StringProp "src", Literal.literal (L.Str src))]
214 Crash home region maybeBranchProblem ->
215 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
216 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
220-- PROGRAMS
223generateProgram :: Can.Main -> Opt.Expr -> State Int Code
224generateProgram kind body =
225 case kind of
226 Can.VDom ->
227 do html <- generateJsExpr body
228 jsExpr (Var.staticProgram <| html)
230 Can.NoFlags ->
231 do almostProgram <- generateJsExpr body
232 jsExpr (JS.Call almostProgram [])
234 Can.Flags tipe ->
235 do almostProgram <- generateJsExpr body
236 flagDecoder <- generateJsExpr (Foreign.decode tipe)
237 jsExpr (almostProgram <| flagDecoder)
241-- FUNCTIONS
244generateFunction :: [Text] -> Opt.Expr -> State Int Code
245generateFunction args body =
246 do code <- generateCode body
247 jsExpr (generateFunctionWithArity args code)
250generateTailFunction :: Text -> [Text] -> Opt.Expr -> State Int JS.Expr
251generateTailFunction name args body =
252 do code <- generateCode body
253 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
254 JS.Labelled
255 (JS.Id (Var.safe name))
256 (JS.While (JS.Bool True) (toStatement code))
259generateFunctionWithArity :: [Text] -> Code -> JS.Expr
260generateFunctionWithArity rawArgs code =
261 let
262 args = map Var.safe rawArgs
263 arity = length args
264 in
265 if 2 <= arity && arity <= 9 then
266 let
267 fN = "F" <> Text.pack (show arity)
268 in
269 ref fN <| function args (toStatementList code)
270 else
271 let
272 (lastArg:otherArgs) = reverse args
273 innerBody = function [lastArg] (toStatementList code)
274 in
275 foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs
279-- GENERATE CALL
282generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code
283generateCall func args =
284 case (func, args) of
285 (Opt.Var var, [arg]) ->
286 case getUnaryOp var of
287 Just op ->
288 do jsArg <- generateJsExpr arg
289 jsExpr $ JS.Prefix op jsArg
291 Nothing ->
292 generateCallHelp func args
294 (Opt.Var var, [ arg1, arg2 ]) ->
295 case getBinaryOp var arg1 arg2 of
296 Just (op, left, right) ->
297 do jsLeft <- generateJsExpr left
298 jsRight <- generateJsExpr right
299 jsExpr $ JS.Infix op jsLeft jsRight
301 Nothing ->
302 generateCallHelp func args
304 _ ->
305 generateCallHelp func args
308generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code
309generateCallHelp func args =
310 let
311 arity = length args
312 aN = "A" <> Text.pack (show arity)
313 in
314 do jsFunc <- generateJsExpr func
315 jsArgs <- mapM generateJsExpr args
316 jsExpr $
317 if 2 <= arity && arity <= 9 then
318 JS.Call (ref aN) (jsFunc:jsArgs)
319 else
320 foldl1 (<|) (jsFunc:jsArgs)
323getUnaryOp :: Var.Canonical -> Maybe JS.PrefixOp
324getUnaryOp var =
325 if var == bitwiseComplement then
326 Just JS.PrefixBNot
328 else if var == basicsNot then
329 Just JS.PrefixLNot
331 else
332 Nothing
335getBinaryOp :: Var.Canonical -> Opt.Expr -> Opt.Expr -> Maybe (JS.InfixOp, Opt.Expr, Opt.Expr)
336getBinaryOp (Var.Canonical home name) left right =
337 if home /= bitwise then
338 Nothing
340 else
341 case name of
342 "and" -> Just ( JS.OpBAnd, left, right )
343 "or" -> Just ( JS.OpBOr, left, right )
344 "xor" -> Just ( JS.OpBXor, left, right )
345 "shiftLeftBy" -> Just ( JS.OpLShift, right, left )
346 "shiftRightBy" -> Just ( JS.OpSpRShift, right, left )
347 "shiftRightZfBy" -> Just ( JS.OpZfRShift, right, left )
348 _ -> Nothing
351bitwiseComplement :: Var.Canonical
352bitwiseComplement =
353 Var.inCore "Bitwise" "complement"
356basicsNot :: Var.Canonical
357basicsNot =
358 Var.inCore "Basics" "not"
361bitwise :: Var.Home
362bitwise =
363 Var.Module (ModuleName.inCore "Bitwise")
367-- GENERATE IFS
370generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int 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)] -> State Int [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) -> State Int [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 -> State Int [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 return (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) -> State Int JS.Case
490edgeToCase exprName labelRoot (test, subTree) =
491 JS.Case (testToExpr test) <$> generateDecider exprName labelRoot subTree
494testToExpr :: DT.Test -> JS.Expr
495testToExpr test =
496 case test of
497 DT.Constructor (Var.Canonical _ tag) ->
498 JS.String tag
500 DT.Literal (L.Chr char) ->
501 JS.String char
503 DT.Literal lit ->
504 Literal.literal lit
508-- work with paths
511pathToTestableExpr :: Text -> DT.Path -> DT.Test -> State Int JS.Expr
512pathToTestableExpr root path exampleTest =
513 do accessExpr <- generateJsExpr (pathToExpr root path)
514 case exampleTest of
515 DT.Constructor _ ->
516 return $ JS.DotRef accessExpr (JS.Id "ctor")
518 DT.Literal (L.Chr _) ->
519 return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
521 DT.Literal _ ->
522 return accessExpr
525pathToExpr :: Text -> DT.Path -> Opt.Expr
526pathToExpr root fullPath =
527 go (Opt.Var (Var.local root)) fullPath
528 where
529 go expr path =
530 case path of
531 DT.Position index subpath ->
532 go (Opt.CtorAccess expr index) subpath
534 DT.Field field subpath ->
535 go (Opt.Access expr field) subpath
537 DT.Empty ->
538 expr
540 DT.Alias ->
541 expr
545-- BINARY OPERATORS
548binop
549 :: Var.Canonical
550 -> Opt.Expr
551 -> Opt.Expr
552 -> State Int Code
553binop func left right =
554 do jsLeft <- generateJsExpr left
555 jsRight <- generateJsExpr right
556 jsExpr (binopHelp func jsLeft jsRight)
560-- BINARY OPERATOR HELPERS
563binopHelp :: Var.Canonical -> JS.Expr -> JS.Expr -> JS.Expr
564binopHelp qualifiedOp@(Var.Canonical home op) leftExpr rightExpr =
565 let
566 simpleMake left right =
567 JS.Call (ref "A2") [ Var.canonical qualifiedOp, left, right ]
568 in
569 if home == basicsModule then
570 (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr
572 else if op == "::" && (home == listModule || home == listModuleInternals) then
573 BuiltIn.cons leftExpr rightExpr
575 else
576 simpleMake leftExpr rightExpr
579listModule :: Var.Home
580listModule =
581 Var.Module (ModuleName.inCore "List")
584listModuleInternals :: Var.Home
585listModuleInternals =
586 Var.TopLevel (ModuleName.inCore "List")
589basicsModule :: Var.Home
590basicsModule =
591 Var.Module (ModuleName.inCore "Basics")
594basicOps :: Map.Map Text (JS.Expr -> JS.Expr -> JS.Expr)
595basicOps =
596 Map.fromList (infixOps ++ specialOps)
599infixOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
600infixOps =
601 let
602 infixOp str op =
603 (str, JS.Infix op)
604 in
605 [ infixOp "+" JS.OpAdd
606 , infixOp "-" JS.OpSub
607 , infixOp "*" JS.OpMul
608 , infixOp "/" JS.OpDiv
609 , infixOp "&&" JS.OpLAnd
610 , infixOp "||" JS.OpLOr
611 ]
614specialOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
615specialOps =
616 [ (,) "^" $ \a b -> JS.Call (obj ["Math","pow"]) [a,b]
617 , (,) "==" $ \a b -> BuiltIn.eq a b
618 , (,) "/=" $ \a b -> JS.Prefix JS.PrefixLNot (BuiltIn.eq a b)
619 , (,) "<" $ cmp JS.OpLT 0
620 , (,) ">" $ cmp JS.OpGT 0
621 , (,) "<=" $ cmp JS.OpLT 1
622 , (,) ">=" $ cmp JS.OpGT (-1)
623 , (,) "//" $ \a b -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
624 ]
627cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
628cmp op n a b =
629 JS.Infix op (BuiltIn.cmp a b) (JS.Int n)