git.iko.soy/elk
on f232da4 help sign in
elk/src/Generate/JavaScript/Expression.hs
630 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 :: Maybe ModuleName.Canonical -> Text -> Opt.Def -> State Int [JS.Stmt]
90generateDef home name def =
91 do jsBody <-
92 case def of
93 Opt.TailDef argNames body ->
94 generateTailFunction name argNames body
96 Opt.Def body ->
97 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.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 let genDef (name, def) = generateDef Nothing name def
167 stmts <- mapM genDef defs
168 code <- generateCode body
169 jsBlock (concat stmts ++ toStatementList code)
171 If branches finally ->
172 generateIf branches finally
174 Case exprName decider jumps ->
175 JsBlock <$> generateCase exprName decider jumps
177 List elements ->
178 do jsElements <- mapM generateJsExpr elements
179 jsExpr $ BuiltIn.list jsElements
181 Ctor tag members ->
182 let
183 ctor =
184 "ctor" ==> JS.String tag
186 toEntry entry n =
187 ("_" <> Text.pack (show n)) ==> entry
188 in
189 do jsMembers <- mapM generateJsExpr members
190 jsExpr $ JS.Object (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
192 CtorAccess dataExpr index ->
193 do jsDataExpr <- generateJsExpr dataExpr
194 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))
196 Cmd moduleName _ ->
197 jsExpr $ BuiltIn.effect moduleName
199 Sub moduleName _ ->
200 jsExpr $ BuiltIn.effect moduleName
202 OutgoingPort name tipe ->
203 jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
205 IncomingPort name tipe ->
206 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
207 jsExpr $ BuiltIn.incomingPort name jsDecoder
209 Program kind body ->
210 generateProgram kind body
212 GLShader _uid src _tipe ->
213 jsExpr $ JS.Object [(JS.StringProp "src", Literal.literal (L.Str src))]
215 Crash home region maybeBranchProblem ->
216 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
217 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
221-- PROGRAMS
224generateProgram :: Can.Main -> Opt.Expr -> State Int Code
225generateProgram kind body =
226 case kind of
227 Can.VDom ->
228 do html <- generateJsExpr body
229 jsExpr (Var.staticProgram <| html)
231 Can.NoFlags ->
232 do almostProgram <- generateJsExpr body
233 jsExpr (JS.Call almostProgram [])
235 Can.Flags tipe ->
236 do almostProgram <- generateJsExpr body
237 flagDecoder <- generateJsExpr (Foreign.decode tipe)
238 jsExpr (almostProgram <| flagDecoder)
242-- FUNCTIONS
245generateFunction :: [Text] -> Opt.Expr -> State Int Code
246generateFunction args body =
247 do code <- generateCode body
248 jsExpr (generateFunctionWithArity args code)
251generateTailFunction :: Text -> [Text] -> Opt.Expr -> State Int JS.Expr
252generateTailFunction name args body =
253 do code <- generateCode body
254 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
255 JS.Labelled
256 (JS.Id (Var.safe name))
257 (JS.While (JS.Bool True) (toStatement code))
260generateFunctionWithArity :: [Text] -> Code -> JS.Expr
261generateFunctionWithArity rawArgs code =
262 let
263 args = map Var.safe rawArgs
264 arity = length args
265 in
266 if 2 <= arity && arity <= 9 then
267 let
268 fN = "F" <> Text.pack (show arity)
269 in
270 ref fN <| function args (toStatementList code)
271 else
272 let
273 (lastArg:otherArgs) = reverse args
274 innerBody = function [lastArg] (toStatementList code)
275 in
276 foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs
280-- GENERATE CALL
283generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code
284generateCall func args =
285 case (func, args) of
286 (Opt.Var var, [arg]) ->
287 case getUnaryOp var of
288 Just op ->
289 do jsArg <- generateJsExpr arg
290 jsExpr $ JS.Prefix op jsArg
292 Nothing ->
293 generateCallHelp func args
295 (Opt.Var var, [ arg1, arg2 ]) ->
296 case getBinaryOp var arg1 arg2 of
297 Just (op, left, right) ->
298 do jsLeft <- generateJsExpr left
299 jsRight <- generateJsExpr right
300 jsExpr $ JS.Infix op jsLeft jsRight
302 Nothing ->
303 generateCallHelp func args
305 _ ->
306 generateCallHelp func args
309generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code
310generateCallHelp func args =
311 let
312 arity = length args
313 aN = "A" <> Text.pack (show arity)
314 in
315 do jsFunc <- generateJsExpr func
316 jsArgs <- mapM generateJsExpr args
317 jsExpr $
318 if 2 <= arity && arity <= 9 then
319 JS.Call (ref aN) (jsFunc:jsArgs)
320 else
321 foldl1 (<|) (jsFunc:jsArgs)
324getUnaryOp :: Var.Canonical -> Maybe JS.PrefixOp
325getUnaryOp var =
326 if var == bitwiseComplement then
327 Just JS.PrefixBNot
329 else if var == basicsNot then
330 Just JS.PrefixLNot
332 else
333 Nothing
336getBinaryOp :: Var.Canonical -> Opt.Expr -> Opt.Expr -> Maybe (JS.InfixOp, Opt.Expr, Opt.Expr)
337getBinaryOp (Var.Canonical home name) left right =
338 if home /= bitwise then
339 Nothing
341 else
342 case name of
343 "and" -> Just ( JS.OpBAnd, left, right )
344 "or" -> Just ( JS.OpBOr, left, right )
345 "xor" -> Just ( JS.OpBXor, left, right )
346 "shiftLeftBy" -> Just ( JS.OpLShift, right, left )
347 "shiftRightBy" -> Just ( JS.OpSpRShift, right, left )
348 "shiftRightZfBy" -> Just ( JS.OpZfRShift, right, left )
349 _ -> Nothing
352bitwiseComplement :: Var.Canonical
353bitwiseComplement =
354 Var.inCore "Bitwise" "complement"
357basicsNot :: Var.Canonical
358basicsNot =
359 Var.inCore "Basics" "not"
362bitwise :: Var.Home
363bitwise =
364 Var.Module (ModuleName.inCore "Bitwise")
368-- GENERATE IFS
371generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
372generateIf givenBranches givenFinally =
373 let
374 (branches, finally) =
375 crushIfs givenBranches givenFinally
377 convertBranch (condition, expr) =
378 (,) <$> generateJsExpr condition <*> generateCode expr
380 ifExpression (condition, branch) otherwise =
381 JS.If condition branch otherwise
383 ifStatement (condition, branch) otherwise =
384 JS.IfStmt condition branch otherwise
385 in
386 do jsBranches <- mapM convertBranch branches
387 jsFinally <- generateCode finally
389 if any isBlock (jsFinally : map snd jsBranches)
390 then
391 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
392 else
393 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
396crushIfs
397 :: [(Opt.Expr, Opt.Expr)]
398 -> Opt.Expr
399 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
400crushIfs branches finally =
401 crushIfsHelp [] branches finally
404crushIfsHelp
405 :: [(Opt.Expr, Opt.Expr)]
406 -> [(Opt.Expr, Opt.Expr)]
407 -> Opt.Expr
408 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
409crushIfsHelp visitedBranches unvisitedBranches finally =
410 case unvisitedBranches of
411 [] ->
412 case finally of
413 If subBranches subFinally ->
414 crushIfsHelp visitedBranches subBranches subFinally
416 _ ->
417 (reverse visitedBranches, finally)
419 (Literal (L.Boolean True), branch) : _ ->
420 crushIfsHelp visitedBranches [] branch
422 visiting : unvisited ->
423 crushIfsHelp (visiting : visitedBranches) unvisited finally
427-- CASE EXPRESSIONS
430generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> State Int [JS.Stmt]
431generateCase exprName decider jumps =
432 do labelRoot <- Var.fresh
433 decider <- generateDecider exprName labelRoot decider
434 foldM (goto labelRoot) decider jumps
438-- handle any jumps
441goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> State Int [JS.Stmt]
442goto labelRoot deciderStmts (target, branch) =
443 let
444 labeledDeciderStmt =
445 JS.Labelled
446 (toLabel labelRoot target)
447 (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))
448 in
449 do code <- generateCode branch
450 return (labeledDeciderStmt : toStatementList code)
453toLabel :: Text -> Int -> JS.Id
454toLabel root target =
455 JS.Id (root <> "_" <> Text.pack (show target))
459-- turn deciders into ifs and switches
462generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> State Int [JS.Stmt]
463generateDecider exprName labelRoot decisionTree =
464 case decisionTree of
465 Opt.Leaf (Opt.Inline branch) ->
466 toStatementList <$> generateCode branch
468 Opt.Leaf (Opt.Jump target) ->
469 return [ JS.Break (Just (toLabel labelRoot target)) ]
471 Opt.Chain testChain success failure ->
472 let
473 makeTest (path, test) =
474 do testExpr <- pathToTestableExpr exprName path test
475 return (JS.Infix JS.OpStrictEq testExpr (testToExpr test))
476 in
477 do testExprs <- mapM makeTest testChain
478 let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
479 thenBranch <- generateDecider exprName labelRoot success
480 elseBranch <- generateDecider exprName labelRoot failure
481 return [ JS.IfStmt cond (JS.Block thenBranch) (JS.Block elseBranch) ]
483 Opt.FanOut path edges fallback ->
484 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
485 caseClauses <- mapM (edgeToCase exprName labelRoot) edges
486 caseDefault <- JS.Default <$> generateDecider exprName labelRoot fallback
487 return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
490edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> State Int JS.Case
491edgeToCase exprName labelRoot (test, subTree) =
492 JS.Case (testToExpr test) <$> generateDecider exprName labelRoot subTree
495testToExpr :: DT.Test -> JS.Expr
496testToExpr test =
497 case test of
498 DT.Constructor (Var.Canonical _ tag) ->
499 JS.String tag
501 DT.Literal (L.Chr char) ->
502 JS.String char
504 DT.Literal lit ->
505 Literal.literal lit
509-- work with paths
512pathToTestableExpr :: Text -> DT.Path -> DT.Test -> State Int JS.Expr
513pathToTestableExpr root path exampleTest =
514 do accessExpr <- generateJsExpr (pathToExpr root path)
515 case exampleTest of
516 DT.Constructor _ ->
517 return $ JS.DotRef accessExpr (JS.Id "ctor")
519 DT.Literal (L.Chr _) ->
520 return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
522 DT.Literal _ ->
523 return accessExpr
526pathToExpr :: Text -> DT.Path -> Opt.Expr
527pathToExpr root fullPath =
528 go (Opt.Var (Var.local root)) fullPath
529 where
530 go expr path =
531 case path of
532 DT.Position index subpath ->
533 go (Opt.CtorAccess expr index) subpath
535 DT.Field field subpath ->
536 go (Opt.Access expr field) subpath
538 DT.Empty ->
539 expr
541 DT.Alias ->
542 expr
546-- BINARY OPERATORS
549binop
550 :: Var.Canonical
551 -> Opt.Expr
552 -> Opt.Expr
553 -> State Int Code
554binop func left right =
555 do jsLeft <- generateJsExpr left
556 jsRight <- generateJsExpr right
557 jsExpr (binopHelp func jsLeft jsRight)
561-- BINARY OPERATOR HELPERS
564binopHelp :: Var.Canonical -> JS.Expr -> JS.Expr -> JS.Expr
565binopHelp qualifiedOp@(Var.Canonical home op) leftExpr rightExpr =
566 let
567 simpleMake left right =
568 JS.Call (ref "A2") [ Var.canonical qualifiedOp, left, right ]
569 in
570 if home == basicsModule then
571 (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr
573 else if op == "::" && (home == listModule || home == listModuleInternals) then
574 BuiltIn.cons leftExpr rightExpr
576 else
577 simpleMake leftExpr rightExpr
580listModule :: Var.Home
581listModule =
582 Var.Module (ModuleName.inCore "List")
585listModuleInternals :: Var.Home
586listModuleInternals =
587 Var.TopLevel (ModuleName.inCore "List")
590basicsModule :: Var.Home
591basicsModule =
592 Var.Module (ModuleName.inCore "Basics")
595basicOps :: Map.Map Text (JS.Expr -> JS.Expr -> JS.Expr)
596basicOps =
597 Map.fromList (infixOps ++ specialOps)
600infixOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
601infixOps =
602 let
603 infixOp str op =
604 (str, JS.Infix op)
605 in
606 [ infixOp "+" JS.OpAdd
607 , infixOp "-" JS.OpSub
608 , infixOp "*" JS.OpMul
609 , infixOp "/" JS.OpDiv
610 , infixOp "&&" JS.OpLAnd
611 , infixOp "||" JS.OpLOr
612 ]
615specialOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
616specialOps =
617 [ (,) "^" $ \a b -> JS.Call (obj ["Math","pow"]) [a,b]
618 , (,) "==" $ \a b -> BuiltIn.eq a b
619 , (,) "/=" $ \a b -> JS.Prefix JS.PrefixLNot (BuiltIn.eq a b)
620 , (,) "<" $ cmp JS.OpLT 0
621 , (,) ">" $ cmp JS.OpGT 0
622 , (,) "<=" $ cmp JS.OpLT 1
623 , (,) ">=" $ cmp JS.OpGT (-1)
624 , (,) "//" $ \a b -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
625 ]
628cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
629cmp op n a b =
630 JS.Infix op (BuiltIn.cmp a b) (JS.Int n)