git.iko.soy/elk
on 101709f 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 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 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 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.VDom ->
229 do html <- generateJsExpr body
230 func <- BuiltIn.staticProgram
231 jsExpr (func <| html)
233 Opt.NoFlags ->
234 do almostProgram <- generateJsExpr body
235 jsExpr (JS.Call almostProgram [])
237 Opt.Flags decoder ->
238 do almostProgram <- generateJsExpr body
239 flagDecoder <- generateJsExpr decoder
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) final =
380 JS.If condition branch final
382 ifStatement (condition, branch) final =
383 JS.IfStmt condition branch final
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 jsDecider <- generateDecider exprName labelRoot decider
433 foldM (goto labelRoot) jsDecider 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)