git.iko.soy/elk
on 4c2e96a help sign in
elk/src/Generate/JavaScript/Expression.hs
624 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 qualified AST.Expression.Canonical as Can
17import AST.Expression.Optimized as Opt
18import qualified AST.Literal as L
19import qualified AST.Module.Name as ModuleName
20import qualified AST.Variable as V
21import Generate.JavaScript.Helpers as Help
22import qualified Generate.JavaScript.Builder as JS
23import qualified Generate.JavaScript.BuiltIn as BuiltIn
24import qualified Generate.JavaScript.Foreign as Foreign
25import qualified Generate.JavaScript.Literal as Literal
26import qualified Generate.JavaScript.Variable as Var
27import Generate.JavaScript.Variable (Generator)
28import qualified Optimize.DecisionTree as DT
32-- GENERATE DECLARATION
35generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> Generator JS.Stmt
36generateDecl home name def =
37 do jsName <- Var.getGlobalName (V.Global home name)
38 jsBody <- generateDef name def
39 return $ JS.VarDeclStmt [ Help.varDecl jsName jsBody ]
43-- CODE CHUNKS
46data Code
47 = JsExpr JS.Expr
48 | JsBlock [JS.Stmt]
51jsExpr :: JS.Expr -> Generator Code
52jsExpr exp =
53 return (JsExpr exp)
56jsBlock :: [JS.Stmt] -> Generator Code
57jsBlock stmts =
58 return (JsBlock stmts)
61isBlock :: Code -> Bool
62isBlock code =
63 case code of
64 JsBlock _ -> True
65 JsExpr _ -> False
68toStatementList :: Code -> [JS.Stmt]
69toStatementList code =
70 case code of
71 JsExpr expr ->
72 [ JS.Return (Just expr) ]
74 JsBlock stmts ->
75 stmts
78toStatement :: Code -> JS.Stmt
79toStatement code =
80 case code of
81 JsExpr expr ->
82 JS.Return (Just expr)
84 JsBlock [stmt] ->
85 stmt
87 JsBlock stmts ->
88 JS.Block stmts
91toExpr :: Code -> JS.Expr
92toExpr code =
93 case code of
94 JsExpr expr ->
95 expr
97 JsBlock stmts ->
98 JS.Call (function [] stmts) []
102-- EXPRESSIONS
105generateJsExpr :: Opt.Expr -> Generator JS.Expr
106generateJsExpr optExpr =
107 toExpr <$> generateCode optExpr
110generateCode :: Opt.Expr -> Generator Code
111generateCode expr =
112 case expr of
113 VarLocal name ->
114 jsExpr $ Var.local name
116 VarGlobal name ->
117 JsExpr <$> Var.global name
119 Literal lit ->
120 JsExpr <$> Literal.literal lit
122 Access record field ->
123 do jsRecord <- generateJsExpr record
124 jsExpr $ JS.DotRef jsRecord (JS.Id (Var.safe field))
126 Update record fields ->
127 let
128 fieldToJs (field, value) =
129 do jsValue <- generateJsExpr value
130 return (Var.safe field, jsValue)
131 in
132 do jsRecord <- generateJsExpr record
133 jsFields <- mapM fieldToJs fields
134 JsExpr <$> BuiltIn.recordUpdate jsRecord jsFields
136 Record fields ->
137 let
138 toField (field, value) =
139 do jsValue <- generateJsExpr value
140 return (Var.safe field ==> jsValue)
141 in
142 do jsFields <- mapM toField fields
143 jsExpr $ JS.Object jsFields
145 Binop op leftExpr rightExpr ->
146 generateBinop op leftExpr rightExpr
148 Function args body ->
149 generateFunction args body
151 Call func args ->
152 generateCall func args
154 TailCall name argNames args ->
155 let
156 reassign argName tempName =
157 JS.ExprStmt $
158 JS.Assign (JS.LVar (Var.safe argName)) (ref tempName)
159 in
160 do args' <- mapM generateJsExpr args
161 tempNames <- mapM (\_ -> Var.fresh) args
162 jsBlock $
163 JS.VarDeclStmt (zipWith varDecl tempNames args')
164 : zipWith reassign argNames tempNames
165 ++ [JS.Continue (Just (JS.Id (Var.safe name)))]
167 Let defs body ->
168 do stmts <- mapM generateLetDef defs
169 code <- generateCode body
170 jsBlock (stmts ++ toStatementList code)
172 If branches finally ->
173 generateIf branches finally
175 Case exprName decider jumps ->
176 JsBlock <$> generateCase exprName decider jumps
178 List elements ->
179 do jsElements <- mapM generateJsExpr elements
180 JsExpr <$> BuiltIn.list jsElements
182 Ctor tag members ->
183 let
184 ctor =
185 "ctor" ==> JS.String tag
187 toEntry entry n =
188 ("_" <> Text.pack (show n)) ==> entry
189 in
190 do jsMembers <- mapM generateJsExpr members
191 jsExpr $ JS.Object (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
193 CtorAccess dataExpr index ->
194 do jsDataExpr <- generateJsExpr dataExpr
195 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))
197 Cmd moduleName _ ->
198 JsExpr <$> BuiltIn.effect moduleName
200 Sub moduleName _ ->
201 JsExpr <$> BuiltIn.effect moduleName
203 OutgoingPort name tipe ->
204 do encoder <- Foreign.encode tipe
205 JsExpr <$> BuiltIn.outgoingPort name encoder
207 IncomingPort name tipe ->
208 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
209 JsExpr <$> BuiltIn.incomingPort name jsDecoder
211 Program kind body ->
212 generateProgram kind body
214 GLShader src ->
215 do string <- Literal.literal (L.Str src)
216 jsExpr $ JS.Object [(JS.StringProp "src", string)]
218 Crash home region maybeBranchProblem ->
219 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
220 JsExpr <$> BuiltIn.crash home region maybeOptBranchProblem
224-- PROGRAMS
227generateProgram :: Can.Main -> Opt.Expr -> Generator Code
228generateProgram kind body =
229 case kind of
230 Can.VDom ->
231 do html <- generateJsExpr body
232 func <- BuiltIn.staticProgram
233 jsExpr (func <| html)
235 Can.NoFlags ->
236 do almostProgram <- generateJsExpr body
237 jsExpr (JS.Call almostProgram [])
239 Can.Flags tipe ->
240 do almostProgram <- generateJsExpr body
241 flagDecoder <- generateJsExpr (Foreign.decode tipe)
242 jsExpr (almostProgram <| flagDecoder)
246-- DEFINITIONS
249generateLetDef :: (Text, Opt.Def) -> Generator JS.Stmt
250generateLetDef (name, def) =
251 do jsBody <- generateDef name def
252 return $ JS.VarDeclStmt [ Help.varDecl name jsBody ]
255generateDef :: Text -> Opt.Def -> Generator JS.Expr
256generateDef name def =
257 case def of
258 Opt.TailDef argNames body ->
259 generateTailFunction name argNames body
261 Opt.Def body ->
262 generateJsExpr body
265generateTailFunction :: Text -> [Text] -> Opt.Expr -> Generator JS.Expr
266generateTailFunction name args body =
267 do code <- generateCode body
268 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
269 JS.Labelled
270 (JS.Id (Var.safe name))
271 (JS.While (JS.Bool True) (toStatement code))
275-- FUNCTIONS
278generateFunction :: [Text] -> Opt.Expr -> Generator Code
279generateFunction args body =
280 do code <- generateCode body
281 jsExpr (generateFunctionWithArity args code)
284generateFunctionWithArity :: [Text] -> Code -> JS.Expr
285generateFunctionWithArity rawArgs code =
286 let
287 args = map Var.safe rawArgs
288 arity = length args
289 in
290 if 2 <= arity && arity <= 9 then
291 let
292 fN = "F" <> Text.pack (show arity)
293 in
294 ref fN <| function args (toStatementList code)
295 else
296 let
297 (lastArg:otherArgs) = reverse args
298 innerBody = function [lastArg] (toStatementList code)
299 in
300 foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs
304-- GENERATE CALL
307generateCall :: Opt.Expr -> [Opt.Expr] -> Generator Code
308generateCall func args =
309 case (func, args) of
310 (Opt.VarGlobal (V.Global home name), [arg]) ->
311 case name of
312 "complement" | home == bitwise -> genPrefix JS.PrefixBNot arg
313 "not" | home == basics -> genPrefix JS.PrefixLNot arg
314 _ -> generateCallHelp func args
316 (Opt.VarGlobal (V.Global home name), [ left, right ]) | home == bitwise ->
317 case name of
318 "and" -> genInfix JS.OpBAnd left right
319 "or" -> genInfix JS.OpBOr left right
320 "xor" -> genInfix JS.OpBXor left right
321 "shiftLeftBy" -> genInfix JS.OpLShift right left
322 "shiftRightBy" -> genInfix JS.OpSpRShift right left
323 "shiftRightZfBy" -> genInfix JS.OpZfRShift right left
324 _ -> generateCallHelp func args
326 _ ->
327 generateCallHelp func args
330genPrefix :: JS.PrefixOp -> Opt.Expr -> Generator Code
331genPrefix op arg =
332 do jsArg <- generateJsExpr arg
333 jsExpr (JS.Prefix op jsArg)
336genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> Generator Code
337genInfix op left right =
338 do jsLeft <- generateJsExpr left
339 jsRight <- generateJsExpr right
340 jsExpr $ JS.Infix op jsLeft jsRight
343basics :: ModuleName.Canonical
344basics =
345 ModuleName.inCore "Basics"
348bitwise :: ModuleName.Canonical
349bitwise =
350 ModuleName.inCore "Bitwise"
353generateCallHelp :: Opt.Expr -> [Opt.Expr] -> Generator Code
354generateCallHelp func args =
355 let
356 arity = length args
357 aN = "A" <> Text.pack (show arity)
358 in
359 do jsFunc <- generateJsExpr func
360 jsArgs <- mapM generateJsExpr args
361 jsExpr $
362 if 2 <= arity && arity <= 9 then
363 JS.Call (ref aN) (jsFunc:jsArgs)
364 else
365 foldl1 (<|) (jsFunc:jsArgs)
369-- GENERATE IFS
372generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Generator Code
373generateIf givenBranches givenFinally =
374 let
375 (branches, finally) =
376 crushIfs givenBranches givenFinally
378 convertBranch (condition, expr) =
379 (,) <$> generateJsExpr condition <*> generateCode expr
381 ifExpression (condition, branch) final =
382 JS.If condition branch final
384 ifStatement (condition, branch) final =
385 JS.IfStmt condition branch final
386 in
387 do jsBranches <- mapM convertBranch branches
388 jsFinally <- generateCode finally
390 if any isBlock (jsFinally : map snd jsBranches)
391 then
392 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
393 else
394 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
397crushIfs
398 :: [(Opt.Expr, Opt.Expr)]
399 -> Opt.Expr
400 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
401crushIfs branches finally =
402 crushIfsHelp [] branches finally
405crushIfsHelp
406 :: [(Opt.Expr, Opt.Expr)]
407 -> [(Opt.Expr, Opt.Expr)]
408 -> Opt.Expr
409 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
410crushIfsHelp visitedBranches unvisitedBranches finally =
411 case unvisitedBranches of
412 [] ->
413 case finally of
414 If subBranches subFinally ->
415 crushIfsHelp visitedBranches subBranches subFinally
417 _ ->
418 (reverse visitedBranches, finally)
420 (Literal (L.Boolean True), branch) : _ ->
421 crushIfsHelp visitedBranches [] branch
423 visiting : unvisited ->
424 crushIfsHelp (visiting : visitedBranches) unvisited finally
428-- CASE EXPRESSIONS
431generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> Generator [JS.Stmt]
432generateCase exprName decider jumps =
433 do labelRoot <- Var.fresh
434 jsDecider <- generateDecider exprName labelRoot decider
435 foldM (goto labelRoot) jsDecider jumps
439-- handle any jumps
442goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> Generator [JS.Stmt]
443goto labelRoot deciderStmts (target, branch) =
444 let
445 labeledDeciderStmt =
446 JS.Labelled
447 (toLabel labelRoot target)
448 (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))
449 in
450 do code <- generateCode branch
451 return (labeledDeciderStmt : toStatementList code)
454toLabel :: Text -> Int -> JS.Id
455toLabel root target =
456 JS.Id (root <> "_" <> Text.pack (show target))
460-- turn deciders into ifs and switches
463generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> Generator [JS.Stmt]
464generateDecider exprName labelRoot decisionTree =
465 case decisionTree of
466 Opt.Leaf (Opt.Inline branch) ->
467 toStatementList <$> generateCode branch
469 Opt.Leaf (Opt.Jump target) ->
470 return [ JS.Break (Just (toLabel labelRoot target)) ]
472 Opt.Chain testChain success failure ->
473 let
474 makeTest (path, test) =
475 do testExpr <- pathToTestableExpr exprName path test
476 JS.Infix JS.OpStrictEq testExpr <$> testToExpr test
477 in
478 do testExprs <- mapM makeTest testChain
479 let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
480 thenBranch <- generateDecider exprName labelRoot success
481 elseBranch <- generateDecider exprName labelRoot failure
482 return [ JS.IfStmt cond (JS.Block thenBranch) (JS.Block elseBranch) ]
484 Opt.FanOut path edges fallback ->
485 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
486 caseClauses <- mapM (edgeToCase exprName labelRoot) edges
487 caseDefault <- JS.Default <$> generateDecider exprName labelRoot fallback
488 return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
491edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> Generator JS.Case
492edgeToCase exprName labelRoot (test, subTree) =
493 JS.Case
494 <$> testToExpr test
495 <*> generateDecider exprName labelRoot subTree
498testToExpr :: DT.Test -> Generator JS.Expr
499testToExpr test =
500 case test of
501 DT.Constructor (V.Canonical _ tag) ->
502 return $ JS.String tag
504 DT.Literal (L.Chr char) ->
505 return $ JS.String char
507 DT.Literal lit ->
508 Literal.literal lit
512-- work with paths
515pathToTestableExpr :: Text -> DT.Path -> DT.Test -> Generator JS.Expr
516pathToTestableExpr root path exampleTest =
517 do accessExpr <- generateJsExpr (pathToExpr root path)
518 case exampleTest of
519 DT.Constructor _ ->
520 return $ JS.DotRef accessExpr (JS.Id "ctor")
522 DT.Literal (L.Chr _) ->
523 return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
525 DT.Literal _ ->
526 return accessExpr
529pathToExpr :: Text -> DT.Path -> Opt.Expr
530pathToExpr root fullPath =
531 go (Opt.VarLocal root) fullPath
532 where
533 go expr path =
534 case path of
535 DT.Position index subpath ->
536 go (Opt.CtorAccess expr index) subpath
538 DT.Field field subpath ->
539 go (Opt.Access expr field) subpath
541 DT.Empty ->
542 expr
544 DT.Alias ->
545 expr
549-- BINARY OPERATORS
552generateBinop :: V.Global -> Opt.Expr -> Opt.Expr -> Generator Code
553generateBinop op left right =
554 do jsLeft <- generateJsExpr left
555 jsRight <- generateJsExpr right
556 JsExpr <$> generateBinopHelp op jsLeft jsRight
560-- BINARY OPERATOR HELPERS
563generateBinopHelp :: V.Global -> JS.Expr -> JS.Expr -> Generator JS.Expr
564generateBinopHelp var@(V.Global home op) jsLeft jsRight =
565 let
566 simpleMake left right =
567 do func <- Var.global var
568 return $ JS.Call (ref "A2") [ func, left, right ]
569 in
570 if home == basics then
571 (Map.findWithDefault simpleMake op basicsOps) jsLeft jsRight
573 else if op == "::" && home == list then
574 BuiltIn.cons jsLeft jsRight
576 else
577 simpleMake jsLeft jsRight
580list :: ModuleName.Canonical
581list =
582 ModuleName.inCore "List"
585basicsOps :: Map.Map Text (JS.Expr -> JS.Expr -> Generator JS.Expr)
586basicsOps =
587 Map.fromList (basicsOpsNormal ++ basicsOpsSpecial)
590basicsOpsNormal :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
591basicsOpsNormal =
592 let
593 (=*>) str op =
594 ( str, \left right -> return (JS.Infix op left right) )
595 in
596 [ "+" =*> JS.OpAdd
597 , "-" =*> JS.OpSub
598 , "*" =*> JS.OpMul
599 , "/" =*> JS.OpDiv
600 , "&&" =*> JS.OpLAnd
601 , "||" =*> JS.OpLOr
602 ]
605basicsOpsSpecial :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
606basicsOpsSpecial =
607 let
608 (=*>) = (,)
609 in
610 [ "^" =*> \a b -> return $ JS.Call (obj ["Math","pow"]) [a,b]
611 , "==" =*> BuiltIn.eq
612 , "/=" =*> \a b -> JS.Prefix JS.PrefixLNot <$> BuiltIn.eq a b
613 , "<" =*> cmp JS.OpLT 0
614 , ">" =*> cmp JS.OpGT 0
615 , "<=" =*> cmp JS.OpLT 1
616 , ">=" =*> cmp JS.OpGT (-1)
617 , "//" =*> \a b -> return $ JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
618 ]
621cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> Generator JS.Expr
622cmp op n a b =
623 do ordering <- BuiltIn.cmp a b
624 return $ JS.Infix op ordering (JS.Int n)