git.iko.soy/Idris-dev
on ffdb074 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
2022 lines 63 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where
5import Idris.AbsSyntax hiding (TypeCase)
6import IRTS.Bytecode
7import IRTS.Lang
8import IRTS.Simplified
9import IRTS.CodegenCommon
10import Idris.Core.TT
11import Paths_idris
12import Util.System
14import Control.Arrow
15import Control.Applicative ((<$>), (<*>), pure)
16import Data.Char
17import Numeric
18import Data.List
19import Data.Maybe
20import System.IO
21import System.Directory
23idrNamespace :: String
24idrNamespace = "__IDR__"
25idrRTNamespace = "__IDRRT__"
26idrLTNamespace = "__IDRLT__"
27idrCTRNamespace = "__IDRCTR__"
30data JSTarget = Node | JavaScript deriving Eq
33data JSType = JSIntTy
34 | JSStringTy
35 | JSIntegerTy
36 | JSFloatTy
37 | JSCharTy
38 | JSPtrTy
39 | JSForgotTy
40 deriving Eq
43data JSInteger = JSBigZero
44 | JSBigOne
45 | JSBigInt Integer
46 deriving Eq
49data JSNum = JSInt Int
50 | JSFloat Double
51 | JSInteger JSInteger
52 deriving Eq
55data JS = JSRaw String
56 | JSIdent String
57 | JSFunction [String] JS
58 | JSType JSType
59 | JSSeq [JS]
60 | JSReturn JS
61 | JSApp JS [JS]
62 | JSNew String [JS]
63 | JSError String
64 | JSBinOp String JS JS
65 | JSPreOp String JS
66 | JSPostOp String JS
67 | JSProj JS String
68 | JSVar LVar
69 | JSNull
70 | JSThis
71 | JSTrue
72 | JSFalse
73 | JSArray [JS]
74 | JSString String
75 | JSNum JSNum
76 | JSAssign JS JS
77 | JSAlloc String (Maybe JS)
78 | JSIndex JS JS
79 | JSCond [(JS, JS)]
80 | JSTernary JS JS JS
81 | JSParens JS
82 | JSWhile JS JS
83 | JSNoop
84 deriving Eq
87compileJS :: JS -> String
88compileJS JSNoop = ""
90compileJS (JSRaw code) =
91 code
93compileJS (JSIdent ident) =
94 ident
96compileJS (JSFunction args body) =
97 "function("
98 ++ intercalate "," args
99 ++ "){\n"
100 ++ compileJS body
101 ++ "\n}"
103compileJS (JSType ty)
104 | JSIntTy <- ty = idrRTNamespace ++ "Int"
105 | JSStringTy <- ty = idrRTNamespace ++ "String"
106 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
107 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
108 | JSCharTy <- ty = idrRTNamespace ++ "Char"
109 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
110 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
112compileJS (JSSeq seq) =
113 intercalate ";\n" (map compileJS seq)
115compileJS (JSReturn val) =
116 "return " ++ compileJS val
118compileJS (JSApp lhs rhs)
119 | JSFunction {} <- lhs =
120 concat ["(", compileJS lhs, ")(", args, ")"]
121 | otherwise =
122 concat [compileJS lhs, "(", args, ")"]
123 where args :: String
124 args = intercalate "," $ map compileJS rhs
126compileJS (JSNew name args) =
127 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
129compileJS (JSError exc) =
130 "throw new Error(\"" ++ exc ++ "\")"
132compileJS (JSBinOp op lhs rhs) =
133 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
135compileJS (JSPreOp op val) =
136 op ++ compileJS val
138compileJS (JSProj obj field)
139 | JSFunction {} <- obj =
140 concat ["(", compileJS obj, ").", field]
141 | JSAssign {} <- obj =
142 concat ["(", compileJS obj, ").", field]
143 | otherwise =
144 compileJS obj ++ '.' : field
146compileJS (JSVar var) =
147 translateVariableName var
149compileJS JSNull =
150 "null"
152compileJS JSThis =
153 "this"
155compileJS JSTrue =
156 "true"
158compileJS JSFalse =
159 "false"
161compileJS (JSArray elems) =
162 "[" ++ intercalate "," (map compileJS elems) ++ "]"
164compileJS (JSString str) =
165 "\"" ++ str ++ "\""
167compileJS (JSNum num)
168 | JSInt i <- num = show i
169 | JSFloat f <- num = show f
170 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
171 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
172 | JSInteger (JSBigInt i) <- num = show i
174compileJS (JSAssign lhs rhs) =
175 compileJS lhs ++ "=" ++ compileJS rhs
177compileJS (JSAlloc name val) =
178 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
180compileJS (JSIndex lhs rhs) =
181 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
183compileJS (JSCond branches) =
184 intercalate " else " $ map createIfBlock branches
185 where
186 createIfBlock (JSNoop, e) =
187 "{\n"
188 ++ compileJS e
189 ++ ";\n}"
190 createIfBlock (cond, e) =
191 "if (" ++ compileJS cond ++") {\n"
192 ++ compileJS e
193 ++ ";\n}"
195compileJS (JSTernary cond true false) =
196 let c = compileJS cond
197 t = compileJS true
198 f = compileJS false in
199 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
201compileJS (JSParens js) =
202 "(" ++ compileJS js ++ ")"
204compileJS (JSWhile cond body) =
205 "while (" ++ compileJS cond ++ ") {\n"
206 ++ compileJS body
207 ++ "\n}"
209jsTailcall :: JS -> JS
210jsTailcall call =
211 jsCall (idrRTNamespace ++ "tailcall") [
212 JSFunction [] (JSReturn call)
213 ]
216jsCall :: String -> [JS] -> JS
217jsCall fun = JSApp (JSIdent fun)
220jsMeth :: JS -> String -> [JS] -> JS
221jsMeth obj meth =
222 JSApp (JSProj obj meth)
225jsInstanceOf :: JS -> JS -> JS
226jsInstanceOf = JSBinOp "instanceof"
229jsEq :: JS -> JS -> JS
230jsEq = JSBinOp "=="
233jsAnd :: JS -> JS -> JS
234jsAnd = JSBinOp "&&"
237jsOr :: JS -> JS -> JS
238jsOr = JSBinOp "||"
241jsType :: JS
242jsType = JSIdent $ idrRTNamespace ++ "Type"
245jsCon :: JS
246jsCon = JSIdent $ idrRTNamespace ++ "Con"
249jsTag :: JS -> JS
250jsTag obj = JSProj obj "tag"
253jsTypeTag :: JS -> JS
254jsTypeTag obj = JSProj obj "type"
257jsBigInt :: JS -> JS
258jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
259jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
260jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
263jsVar :: Int -> String
264jsVar = ("__var_" ++) . show
267jsLet :: String -> JS -> JS -> JS
268jsLet name value body =
269 JSApp (
270 JSFunction [name] (
271 JSReturn body
272 )
273 ) [value]
276jsError :: String -> JS
277jsError err = JSApp (JSFunction [] (JSError err)) []
280foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
281foldJS tr add acc js =
282 fold js
283 where
284 fold js
285 | JSFunction args body <- js =
286 add (tr js) (fold body)
287 | JSSeq seq <- js =
288 add (tr js) $ foldl' add acc (map fold seq)
289 | JSReturn ret <- js =
290 add (tr js) (fold ret)
291 | JSApp lhs rhs <- js =
292 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
293 | JSNew _ args <- js =
294 add (tr js) $ foldl' add acc $ map fold args
295 | JSBinOp _ lhs rhs <- js =
296 add (tr js) $ add (fold lhs) (fold rhs)
297 | JSPreOp _ val <- js =
298 add (tr js) $ fold val
299 | JSPostOp _ val <- js =
300 add (tr js) $ fold val
301 | JSProj obj _ <- js =
302 add (tr js) (fold obj)
303 | JSArray vals <- js =
304 add (tr js) $ foldl' add acc $ map fold vals
305 | JSAssign lhs rhs <- js =
306 add (tr js) $ add (fold lhs) (fold rhs)
307 | JSIndex lhs rhs <- js =
308 add (tr js) $ add (fold lhs) (fold rhs)
309 | JSAlloc _ val <- js =
310 add (tr js) $ fromMaybe acc $ fmap fold val
311 | JSTernary c t f <- js =
312 add (tr js) $ add (fold c) (add (fold t) (fold f))
313 | JSParens val <- js =
314 add (tr js) $ fold val
315 | JSCond conds <- js =
316 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
317 | JSWhile cond body <- js =
318 add (tr js) $ add (fold cond) (fold body)
319 | otherwise =
320 tr js
323transformJS :: (JS -> JS) -> JS -> JS
324transformJS tr js =
325 transformHelper js
326 where
327 transformHelper :: JS -> JS
328 transformHelper js
329 | JSFunction args body <- js = JSFunction args $ tr body
330 | JSSeq seq <- js = JSSeq $ map tr seq
331 | JSReturn ret <- js = JSReturn $ tr ret
332 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
333 | JSNew con args <- js = JSNew con $ map tr args
334 | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
335 | JSPreOp op val <- js = JSPreOp op (tr val)
336 | JSPostOp op val <- js = JSPostOp op (tr val)
337 | JSProj obj field <- js = JSProj (tr obj) field
338 | JSArray vals <- js = JSArray $ map tr vals
339 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
340 | JSAlloc var val <- js = JSAlloc var $ fmap tr val
341 | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
342 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
343 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
344 | JSParens val <- js = JSParens $ tr val
345 | JSWhile cond body <- js = JSWhile(tr cond) (tr body)
346 | otherwise = js
349moveJSDeclToTop :: String -> [JS] -> [JS]
350moveJSDeclToTop decl js = move ([], js)
351 where
352 move :: ([JS], [JS]) -> [JS]
353 move (front, js@(JSAlloc name _):back)
354 | name == decl = js : front ++ back
356 move (front, js:back) =
357 move (front ++ [js], back)
360jsSubst :: JS -> JS -> JS -> JS
361jsSubst var new old
362 | var == old = new
364jsSubst (JSIdent var) new (JSVar old)
365 | var == translateVariableName old = new
366 | otherwise = JSVar old
368jsSubst var new old@(JSIdent _)
369 | var == old = new
370 | otherwise = old
372jsSubst var new (JSArray fields) =
373 JSArray (map (jsSubst var new) fields)
375jsSubst var new (JSNew con vals) =
376 JSNew con $ map (jsSubst var new) vals
378jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
379 | var `notElem` args =
380 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
381 map (jsSubst (JSIdent var) new) vals
382 )
383 | otherwise =
384 JSApp (JSProj (JSFunction args body) "apply") (
385 map (jsSubst (JSIdent var) new) vals
386 )
388jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
389 | var /= arg =
390 JSApp (JSFunction [arg] (
391 jsSubst (JSIdent var) new body
392 )) $ map (jsSubst (JSIdent var) new) vals
393 | otherwise =
394 JSApp (JSFunction [arg] (
395 body
396 )) $ map (jsSubst (JSIdent var) new) vals
398jsSubst var new js = transformJS (jsSubst var new) js
401removeAllocations :: JS -> JS
402removeAllocations (JSSeq body) =
403 let opt = removeHelper (map removeAllocations body) in
404 case opt of
405 [ret] -> ret
406 _ -> JSSeq opt
407 where
408 removeHelper :: [JS] -> [JS]
409 removeHelper [js] = [js]
410 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
411 map (jsSubst (JSIdent name) val) (removeHelper js)
412 removeHelper (j:js) = j : removeHelper js
414removeAllocations js = transformJS removeAllocations js
417isJSConstant :: JS -> Bool
418isJSConstant js
419 | JSString _ <- js = True
420 | JSNum _ <- js = True
421 | JSType _ <- js = True
422 | JSNull <- js = True
423 | JSArray vals <- js = all isJSConstant vals
425 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
427 | otherwise = False
429isJSConstantConstructor :: [String] -> JS -> Bool
430isJSConstantConstructor constants js
431 | isJSConstant js =
432 True
433 | JSArray vals <- js =
434 all (isJSConstantConstructor constants) vals
435 | JSNew "__IDRRT__Con" args <- js =
436 all (isJSConstantConstructor constants) args
437 | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js
438 , name `elem` constants =
439 True
440 | JSIdent name <- js
441 , name `elem` constants =
442 True
443 | otherwise = False
446inlineJS :: JS -> JS
447inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
448 where
449 inlineJSLet :: JS -> JS
450 inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])
451 | opt <- inlineJSLet val =
452 inlineJS $ jsSubst (JSIdent arg) opt ret
454 inlineJSLet js = transformJS inlineJSLet js
457 inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
458 | opt <- inlineCaseMatch val =
459 inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
461 inlineCaseMatch js = transformJS inlineCaseMatch js
464 inlineApply js
465 | JSApp (
466 JSProj (JSFunction args (JSReturn body)) "apply"
467 ) [JSThis, JSProj var "vars"] <- js =
468 inlineApply $ inlineApply' var args body 0
469 | JSReturn (JSApp (
470 JSProj (JSFunction args body@(JSCond _)) "apply"
471 ) [JSThis, JSProj var "vars"]) <- js =
472 inlineApply $ inlineApply' var args body 0
473 where
474 inlineApply' _ [] body _ = body
475 inlineApply' var (a:as) body n =
476 inlineApply' var as (
477 jsSubst (JSIdent a) (
478 JSIndex (JSProj var "vars") (JSNum (JSInt n))
479 ) body
480 ) (n + 1)
482 inlineApply js = transformJS inlineApply js
485 inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
486 inlineError error
488 inlineError js = transformJS inlineError js
491 inlineAssign (JSAssign lhs rhs)
492 | JSVar _ <- lhs
493 , JSVar _ <- rhs
494 , lhs == rhs =
495 lhs
497 inlineAssign (JSAssign lhs rhs)
498 | JSIdent _ <- lhs
499 , JSIdent _ <- rhs
500 , lhs == rhs =
501 lhs
503 inlineAssign js = transformJS inlineAssign js
506removeEval :: [JS] -> [JS]
507removeEval js =
508 let (ret, isReduced) = checkEval js in
509 if isReduced
510 then removeEvalApp ret
511 else ret
512 where
513 removeEvalApp js = catMaybes (map removeEvalApp' js)
514 where
515 removeEvalApp' :: JS -> Maybe JS
516 removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
517 removeEvalApp' js = Just $ transformJS match js
518 where
519 match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val
520 match js = transformJS match js
522 removeEvalApp js = js
524 checkEval :: [JS] -> ([JS], Bool)
525 checkEval js = foldr f ([], False) $ map checkEval' js
526 where
527 f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)
528 f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)
529 f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)
532 checkEval' :: JS -> (Maybe JS, Bool)
533 checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
534 JSSeq [ _
535 , JSReturn (JSIdent "t")
536 ]
537 )) []))) = (Nothing, True)
539 checkEval' js = (Just js, False)
542reduceJS :: [JS] -> [JS]
543reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
546funName :: JS -> String
547funName (JSAlloc fun _) = fun
550elimDeadLoop :: [JS] -> [JS]
551elimDeadLoop js
552 | ret <- deadEvalApplyCases js
553 , ret /= js = elimDeadLoop ret
554 | otherwise = js
557deadEvalApplyCases :: [JS] -> [JS]
558deadEvalApplyCases js =
559 let tags = sort $ nub $ concatMap (getTags) js in
560 map (removeHelper tags) js
561 where
562 getTags :: JS -> [Int]
563 getTags = foldJS match (++) []
564 where
565 match js
566 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
567 | otherwise = []
570 removeHelper :: [Int] -> JS -> JS
571 removeHelper tags (JSAlloc fun (Just (
572 JSApp (JSFunction [] (JSSeq seq)) []))
573 ) =
574 (JSAlloc fun (Just (
575 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
576 )
578 removeHelper _ js = js
581 remover :: [Int] -> [JS] -> [JS]
582 remover tags (
583 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
584 )
585 | tag `notElem` tags = remover tags js
587 remover tags (j:js) = j : remover tags js
588 remover _ [] = []
591initConstructors :: [JS] -> [JS]
592initConstructors js =
593 let tags = nub $ sort $ concat (map getTags js) in
594 rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
595 where
596 rearrangePrelude :: [JS] -> [JS]
597 rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
600 getTags :: JS -> [Int]
601 getTags = foldJS match (++) []
602 where
603 match js
604 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
605 | otherwise = []
608 replaceConstructors :: [Int] -> [JS] -> [JS]
609 replaceConstructors tags js = map (replaceHelper tags) js
610 where
611 replaceHelper :: [Int] -> JS -> JS
612 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
613 | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
615 replaceHelper tags js = transformJS (replaceHelper tags) js
618 createConstant :: Int -> JS
619 createConstant tag =
620 JSAlloc (idrCTRNamespace ++ show tag) (Just (
621 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
622 ))
625removeIDs :: [JS] -> [JS]
626removeIDs js =
627 case partition isID js of
628 ([], rest) -> rest
629 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
630 where isID :: JS -> Bool
631 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
632 | JSReturn (JSVar _) <- last body = True
634 isID _ = False
637 idFor :: JS -> (String, Int)
638 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
639 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
642 removeIDCall :: [(String, Int)] -> JS -> JS
643 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
644 JSReturn (JSApp (JSIdent fun) args)
645 )])
646 | Just pos <- lookup fun ids
647 , pos < length args = args !! pos
649 removeIDCall ids (JSNew _ [JSFunction [] (
650 JSReturn (JSApp (JSIdent fun) args)
651 )])
652 | Just pos <- lookup fun ids
653 , pos < length args = args !! pos
655 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
656 | Just pos <- lookup fun ids
657 , pos < length args = args !! pos
659 removeIDCall ids js = transformJS (removeIDCall ids) js
662inlineFunctions :: [JS] -> [JS]
663inlineFunctions js =
664 inlineHelper ([], js)
665 where
666 inlineHelper :: ([JS], [JS]) -> [JS]
667 inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
668 | countAll fun front + countAll fun back == 0 =
669 inlineHelper (front, back)
670 | Just new <- inlineAble (
671 countAll fun front + countAll fun back
672 ) fun args body =
673 let f = map (inline fun args new) in
674 inlineHelper (f front, f back)
676 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
677 inlineHelper (front, []) = front
680 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
681 inlineAble 1 fun args (JSReturn body)
682 | nonRecur fun body =
683 if all (<= 1) (map ($ body) (map countIDOccurences args))
684 then Just body
685 else Nothing
687 inlineAble _ _ _ _ = Nothing
690 inline :: String -> [String] -> JS -> JS -> JS
691 inline fun args body js = inline' js
692 where
693 inline' :: JS -> JS
694 inline' (JSApp (JSIdent name) vals)
695 | name == fun =
696 let (js, phs) = insertPlaceHolders args body in
697 inline' $ foldr (uncurry jsSubst) js (zip phs vals)
699 inline' js = transformJS inline' js
701 insertPlaceHolders :: [String] -> JS -> (JS, [JS])
702 insertPlaceHolders args body = insertPlaceHolders' args body []
703 where
704 insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
705 insertPlaceHolders' (a:as) body ph
706 | (body', ph') <- insertPlaceHolders' as body ph =
707 let phvar = JSIdent $ "__PH_" ++ show (length ph') in
708 (jsSubst (JSIdent a) phvar body', phvar : ph')
710 insertPlaceHolders' [] body ph = (body, ph)
713 nonRecur :: String -> JS -> Bool
714 nonRecur name body = countInvokations name body == 0
717 countAll :: String -> [JS] -> Int
718 countAll name js = sum $ map (countInvokations name) js
721 countIDOccurences :: String -> JS -> Int
722 countIDOccurences name = foldJS match (+) 0
723 where
724 match :: JS -> Int
725 match js
726 | JSIdent ident <- js
727 , name == ident = 1
728 | otherwise = 0
731 countInvokations :: String -> JS -> Int
732 countInvokations name = foldJS match (+) 0
733 where
734 match :: JS -> Int
735 match js
736 | JSApp (JSIdent ident) _ <- js
737 , name == ident = 1
738 | JSNew con _ <- js
739 , name == con = 1
740 | otherwise = 0
743reduceContinuations :: JS -> JS
744reduceContinuations = inlineTC . reduceJS
745 where
746 reduceJS :: JS -> JS
747 reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
748 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
749 )]) = reduceJS js
751 reduceJS js = transformJS reduceJS js
754 inlineTC :: JS -> JS
755 inlineTC js
756 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
757 JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
758 JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
759 JSReturn (JSNew "__IDRRT__Cont" _)
760 )])
761 )])
762 )] <- js = inlineTC ret
764 inlineTC js = transformJS inlineTC js
769reduceConstant :: JS -> JS
770reduceConstant
771 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
772 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
773 )])
774 | JSNum num <- val = val
775 | JSBinOp op lhs rhs <- val =
776 JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
778 | JSApp (JSProj lhs op) [rhs] <- val
779 , op `elem` [ "subtract"
780 , "add"
781 , "multiply"
782 , "divide"
783 , "mod"
784 , "equals"
785 , "lesser"
786 , "lesserOrEquals"
787 , "greater"
788 , "greaterOrEquals"
789 ] = val
791reduceConstant (JSApp ident [(JSParens js)]) =
792 JSApp ident [reduceConstant js]
794reduceConstant js = transformJS reduceConstant js
797reduceConstants :: JS -> JS
798reduceConstants js
799 | ret <- reduceConstant js
800 , ret /= js = reduceConstants ret
801 | otherwise = js
804elimDuplicateEvals :: JS -> JS
805elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
806 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
807 where
808 elimHelper :: [JS] -> [JS]
809 elimHelper (j@(JSAlloc var (Just val)):js) =
810 j : map (jsSubst val (JSIdent var)) (elimHelper js)
811 elimHelper (j:js) =
812 j : elimHelper js
813 elimHelper [] = []
815elimDuplicateEvals js = js
818optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
819optimizeRuntimeCalls fun tc js =
820 optTC tc : map optHelper js
821 where
822 optHelper :: JS -> JS
823 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
824 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
825 ])
826 | n == fun = JSApp (JSIdent tc) $ map optHelper args
828 optHelper js = transformJS optHelper js
831 optTC :: String -> JS
832 optTC tc@"__IDRRT__EVALTC" =
833 JSAlloc tc (Just $ JSFunction ["arg0"] (
834 JSSeq [ JSAlloc "ret" $ Just (
835 JSTernary (
836 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
837 (hasProp "__IDRLT__EVAL" "arg0")
838 ) (JSApp
839 (JSIndex
840 (JSIdent "__IDRLT__EVAL")
841 (JSProj (JSIdent "arg0") "tag")
842 )
843 [JSIdent "arg0"]
844 ) (JSIdent "arg0")
845 )
846 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
847 JSAssign (JSIdent "ret") (
848 JSApp (JSProj (JSIdent "ret") "k") []
849 )
850 )
851 , JSReturn $ JSIdent "ret"
852 ]
853 ))
855 optTC tc@"__IDRRT__APPLYTC" =
856 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
857 JSSeq [ JSAlloc "ret" $ Just (
858 JSTernary (
859 (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
860 (hasProp "__IDRLT__APPLY" "fn0")
861 ) (JSApp
862 (JSIndex
863 (JSIdent "__IDRLT__APPLY")
864 (JSProj (JSIdent "fn0") "tag")
865 )
866 [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
867 ) JSNull
868 )
869 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
870 JSAssign (JSIdent "ret") (
871 JSApp (JSProj (JSIdent "ret") "k") []
872 )
873 )
874 , JSReturn $ JSIdent "ret"
875 ]
876 ))
879 hasProp :: String -> String -> JS
880 hasProp table var =
881 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
884unfoldLookupTable :: [JS] -> [JS]
885unfoldLookupTable input =
886 let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
887 (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
888 js = applyunfold in
889 adaptRuntime $ expandCons evals applys js
890 where
891 adaptRuntime :: [JS] -> [JS]
892 adaptRuntime =
893 adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
896 adaptApply :: [JS] -> [JS]
897 adaptApply js = adaptApply' [] js
898 where
899 adaptApply' :: [JS] -> [JS] -> [JS]
900 adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
901 front ++ (new:back)
903 adaptApply' front (next:back) =
904 adaptApply' (front ++ [next]) back
906 adaptApply' front [] = front
908 new =
909 JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
910 JSTernary (
911 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
912 (JSProj (JSIdent "mfn0") "app")
913 ) (JSApp
914 (JSProj (JSIdent "mfn0") "app")
915 [JSIdent "mfn0", JSIdent "marg0"]
916 ) JSNull
917 )
918 )
921 adaptApplyTC :: [JS] -> [JS]
922 adaptApplyTC js = adaptApplyTC' [] js
923 where
924 adaptApplyTC' :: [JS] -> [JS] -> [JS]
925 adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =
926 front ++ (new:back)
928 adaptApplyTC' front (next:back) =
929 adaptApplyTC' (front ++ [next]) back
931 adaptApplyTC' front [] = front
933 new =
934 JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
935 JSSeq [ JSAlloc "ret" $ Just (
936 JSTernary (
937 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
938 (JSProj (JSIdent "mfn0") "app")
939 ) (JSApp
940 (JSProj (JSIdent "mfn0") "app")
941 [JSIdent "mfn0", JSIdent "marg0"]
942 ) JSNull
943 )
944 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
945 JSAssign (JSIdent "ret") (
946 JSApp (JSProj (JSIdent "ret") "k") []
947 )
948 )
949 , JSReturn $ JSIdent "ret"
950 ]
951 ))
954 adaptEval :: [JS] -> [JS]
955 adaptEval js = adaptEval' [] js
956 where
957 adaptEval' :: [JS] -> [JS] -> [JS]
958 adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =
959 front ++ (new:back)
961 adaptEval' front (next:back) =
962 adaptEval' (front ++ [next]) back
964 adaptEval' front [] = front
966 new =
967 JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
968 JSTernary (
969 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
970 (JSProj (JSIdent "marg0") "eval")
971 ) (JSApp
972 (JSProj (JSIdent "marg0") "eval")
973 [JSIdent "marg0"]
974 ) (JSIdent "marg0")
975 )
976 )
979 adaptEvalTC :: [JS] -> [JS]
980 adaptEvalTC js = adaptEvalTC' [] js
981 where
982 adaptEvalTC' :: [JS] -> [JS] -> [JS]
983 adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =
984 front ++ (new:back)
986 adaptEvalTC' front (next:back) =
987 adaptEvalTC' (front ++ [next]) back
989 adaptEvalTC' front [] = front
991 new =
992 JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
993 JSSeq [ JSAlloc "ret" $ Just (
994 JSTernary (
995 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
996 (JSProj (JSIdent "marg0") "eval")
997 ) (JSApp
998 (JSProj (JSIdent "marg0") "eval")
999 [JSIdent "marg0"]
1000 ) (JSIdent "marg0")
1002 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1003 JSAssign (JSIdent "ret") (
1004 JSApp (JSProj (JSIdent "ret") "k") []
1007 , JSReturn $ JSIdent "ret"
1009 ))
1012 adaptCon js =
1013 adaptCon' [] js
1014 where
1015 adaptCon' front ((JSAlloc "__IDRRT__Con" (Just _)):back) =
1016 front ++ (new:back)
1018 adaptCon' front (next:back) =
1019 adaptCon' (front ++ [next]) back
1021 adaptCon' front [] = front
1024 new =
1025 JSAlloc "__IDRRT__Con" (Just $
1026 JSFunction newArgs (
1027 JSSeq (map newVar newArgs)
1030 where
1031 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1032 newArgs = ["tag", "eval", "app", "vars"]
1035 unfoldLT :: String -> [JS] -> ([Int], [JS])
1036 unfoldLT lt js =
1037 let (table, code) = extractLT lt js
1038 expanded = expandLT lt table in
1039 (map fst expanded, map snd expanded ++ code)
1042 expandCons :: [Int] -> [Int] -> [JS] -> [JS]
1043 expandCons evals applys js =
1044 map expandCons' js
1045 where
1046 expandCons' :: JS -> JS
1047 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
1048 | evalid <- getId "__IDRLT__EVAL" tag evals
1049 , applyid <- getId "__IDRLT__APPLY" tag applys =
1050 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
1051 , maybe JSNull JSIdent evalid
1052 , maybe JSNull JSIdent applyid
1053 , JSArray (map expandCons' args)
1056 expandCons' js = transformJS expandCons' js
1059 getId :: String -> Int -> [Int] -> Maybe String
1060 getId lt tag entries
1061 | tag `elem` entries = Just $ ltIdentifier lt tag
1062 | otherwise = Nothing
1065 ltIdentifier :: String -> Int -> String
1066 ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
1067 ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
1070 extractLT :: String -> [JS] -> (JS, [JS])
1071 extractLT lt js =
1072 extractLT' ([], js)
1073 where
1074 extractLT' :: ([JS], [JS]) -> (JS, [JS])
1075 extractLT' (front, js@(JSAlloc fun _):back)
1076 | fun == lt = (js, front ++ back)
1078 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
1079 extractLT' (front, back) = (JSNoop, front ++ back)
1082 expandLT :: String -> JS -> [(Int, JS)]
1083 expandLT lt (
1084 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
1085 ) = catMaybes (map expandEntry seq)
1086 where
1087 expandEntry :: JS -> Maybe (Int, JS)
1088 expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
1089 Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
1091 expandEntry js = Nothing
1093 expandLT lt JSNoop = []
1096removeInstanceChecks :: JS -> JS
1097removeInstanceChecks (JSCond conds) =
1098 JSCond $ eliminateDeadBranches $ map (
1099 removeHelper *** removeInstanceChecks
1100 ) conds
1101 where
1102 removeHelper (
1103 JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
1104 ) = removeHelper check
1105 removeHelper js = js
1108 eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]
1109 eliminateDeadBranches [(_, js)] = [(JSNoop, js)]
1110 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
1111 eliminateDeadBranches [] = []
1113removeInstanceChecks js = transformJS removeInstanceChecks js
1116reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
1117reduceLoop reduced (cons, program) =
1118 case partition findConstructors program of
1119 ([], js) -> cons ++ js
1120 (candidates, rest) ->
1121 let names = reduced ++ map funName candidates in
1122 reduceLoop names (
1123 cons ++ map reduce candidates, map (reduceCall names) rest
1125 where findConstructors :: JS -> Bool
1126 findConstructors js
1127 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
1128 reducable $ last body
1129 | otherwise = False
1130 where reducable :: JS -> Bool
1131 reducable js
1132 | JSReturn ret <- js = reducable ret
1133 | JSNew _ args <- js = and $ map reducable args
1134 | JSArray fields <- js = and $ map reducable fields
1135 | JSNum _ <- js = True
1136 | JSNull <- js = True
1137 | JSIdent _ <- js = True
1138 | otherwise = False
1141 reduce :: JS -> JS
1142 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1143 | JSReturn js <- last body = (JSAlloc fun (Just js))
1145 reduce js = js
1148 reduceCall :: [String] -> JS -> JS
1149 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1150 JSReturn (JSApp id@(JSIdent ret) _)
1151 )])
1152 | ret `elem` funs = id
1154 reduceCall funs js@(JSApp id@(JSIdent fun) _)
1155 | fun `elem` funs = id
1157 reduceCall funs js = transformJS (reduceCall funs) js
1160extractLocalConstructors :: [JS] -> [JS]
1161extractLocalConstructors js =
1162 concatMap extractLocalConstructors' js
1163 where
1164 globalCons :: [String]
1165 globalCons = concatMap (getGlobalCons) js
1168 extractLocalConstructors' :: JS -> [JS]
1169 extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1170 addCons cons [foldr (uncurry jsSubst) js (reverse cons)]
1171 where
1172 cons :: [(JS, JS)]
1173 cons = zipWith genName (foldJS match (++) [] body) [1..]
1174 where
1175 genName :: JS -> Int -> (JS, JS)
1176 genName js id =
1177 (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1179 match :: JS -> [JS]
1180 match js
1181 | JSNew "__IDRRT__Con" args <- js
1182 , all isConstant args = [js]
1183 | otherwise = []
1186 addCons :: [(JS, JS)] -> [JS] -> [JS]
1187 addCons [] js = js
1188 addCons (con@(_, name):cons) js
1189 | sum (map (countOccur name) js) > 0 =
1190 addCons cons ((allocCon con) : js)
1191 | otherwise =
1192 addCons cons js
1195 countOccur :: JS -> JS -> Int
1196 countOccur ident js = foldJS match (+) 0 js
1197 where
1198 match :: JS -> Int
1199 match js
1200 | js == ident = 1
1201 | otherwise = 0
1204 allocCon :: (JS, JS) -> JS
1205 allocCon (js, JSIdent name) =
1206 JSAlloc name (Just js)
1209 isConstant :: JS -> Bool
1210 isConstant js
1211 | JSNew "__IDRRT__Con" args <- js
1212 , all isConstant args =
1213 True
1214 | otherwise =
1215 isJSConstantConstructor globalCons js
1217 extractLocalConstructors' js = [js]
1220 getGlobalCons :: JS -> [String]
1221 getGlobalCons js = foldJS match (++) [] js
1222 where
1223 match :: JS -> [String]
1224 match js
1225 | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1226 [name]
1227 | otherwise =
1228 []
1231evalCons :: [JS] -> [JS]
1232evalCons js =
1233 map (collapseCont . collapseTC . expandProj . evalCons') js
1234 where
1235 cons :: [(String, JS)]
1236 cons = concatMap getGlobalCons js
1238 evalCons' :: JS -> JS
1239 evalCons' js = transformJS match js
1240 where
1241 match :: JS -> JS
1242 match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1243 | JSIdent name <- arg
1244 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1245 arg
1247 match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1248 | JSIdent name <- arg
1249 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1250 arg
1252 match js = transformJS match js
1255 lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1256 lookupConstructor ctr cons
1257 | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1258 | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1259 | otherwise = Nothing
1262 expandProj :: JS -> JS
1263 expandProj js = transformJS match js
1264 where
1265 match :: JS -> JS
1266 match (
1267 JSIndex (
1268 JSProj (JSIdent name) "vars"
1269 ) (
1270 JSNum (JSInt idx)
1273 | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1274 args !! idx
1276 match js = transformJS match js
1279 collapseTC :: JS -> JS
1280 collapseTC js = transformJS match js
1281 where
1282 match :: JS -> JS
1283 match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1284 JSReturn (JSIdent name)
1285 )])
1286 | Just _ <- lookup name cons = (JSIdent name)
1288 match js = transformJS match js
1291 collapseCont :: JS -> JS
1292 collapseCont js = transformJS match js
1293 where
1294 match :: JS -> JS
1295 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1296 JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1297 )]) = collapseCont ret
1300 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1301 JSReturn (JSIdent name)
1302 )]) = JSIdent name
1304 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1305 JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1306 )])
1307 | all collapsable args = ret
1308 where
1309 collapsable :: JS -> Bool
1310 collapsable (JSIdent _) = True
1311 collapsable js = isJSConstantConstructor (map fst cons) js
1314 match js = transformJS match js
1317getGlobalCons :: JS -> [(String, JS)]
1318getGlobalCons js = foldJS match (++) [] js
1319 where
1320 match :: JS -> [(String, JS)]
1321 match js
1322 | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1323 [(name, con)]
1324 | (JSAlloc name (Just con@(JSIdent _))) <- js =
1325 [(name, con)]
1326 | otherwise =
1327 []
1330getIncludes :: [FilePath] -> IO [String]
1331getIncludes = mapM readFile
1333codegenJavaScript
1334 :: JSTarget
1335 -> [(Name, SDecl)]
1336 -> [FilePath]
1337 -> FilePath
1338 -> OutputType
1339 -> IO ()
1340codegenJavaScript target definitions includes filename outputType = do
1341 let (header, runtime) = case target of
1342 Node ->
1343 ("#!/usr/bin/env node\n", "-node")
1344 JavaScript ->
1345 ("", "-browser")
1346 included <- getIncludes includes
1347 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1348 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1349 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
1350 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1351 writeFile filename $ header ++ (
1352 intercalate "\n" $ included ++ [ jsbn
1353 , idrRuntime
1354 , tgtRuntime
1355 ] ++ functions
1358 setPermissions filename (emptyPermissions { readable = True
1359 , executable = target == Node
1360 , writable = True
1361 })
1362 where
1363 def :: [(String, SDecl)]
1364 def = map (first translateNamespace) definitions
1367 functions :: [String]
1368 functions = translate >>> optimize >>> compile $ def
1369 where
1370 translate p =
1371 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1372 optimize p =
1373 foldl' (flip ($)) p opt
1374 compile =
1375 map compileJS
1377 opt =
1378 [ removeEval
1379 , map inlineJS
1380 , removeIDs
1381 , reduceJS
1382 , map reduceConstants
1383 , initConstructors
1384 , map removeAllocations
1385 , elimDeadLoop
1386 , map elimDuplicateEvals
1387 , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1388 , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1389 , map removeInstanceChecks
1390 , inlineFunctions
1391 , map reduceContinuations
1392 , extractLocalConstructors
1393 , unfoldLookupTable
1394 , evalCons
1397 prelude :: [JS]
1398 prelude =
1399 [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1400 JSAssign (JSProj JSThis "k") (JSIdent "k")
1401 ))
1402 , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1403 JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1404 , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1406 ))
1409 mainLoop :: JS
1410 mainLoop =
1411 JSAlloc "main" $ Just $ JSFunction [] (
1412 case target of
1413 Node -> mainFun
1414 JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [
1415 JSString "DOMContentLoaded", JSFunction [] (
1416 mainFun
1417 ), JSFalse
1418 ])]
1420 where
1421 mainFun :: JS
1422 mainFun = jsTailcall $ jsCall runMain []
1425 isReady :: JS
1426 isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
1429 readyState :: JS
1430 readyState = JSProj (JSIdent "document") "readyState"
1433 runMain :: String
1434 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1437 invokeLoop :: JS
1438 invokeLoop = jsCall "main" []
1441translateIdentifier :: String -> String
1442translateIdentifier =
1443 replaceReserved . concatMap replaceBadChars
1444 where replaceBadChars :: Char -> String
1445 replaceBadChars c
1446 | ' ' <- c = "_"
1447 | '_' <- c = "__"
1448 | isDigit c = '_' : show (ord c)
1449 | not (isLetter c && isAscii c) = '_' : show (ord c)
1450 | otherwise = [c]
1451 replaceReserved s
1452 | s `elem` reserved = '_' : s
1453 | otherwise = s
1456 reserved = [ "break"
1457 , "case"
1458 , "catch"
1459 , "continue"
1460 , "debugger"
1461 , "default"
1462 , "delete"
1463 , "do"
1464 , "else"
1465 , "finally"
1466 , "for"
1467 , "function"
1468 , "if"
1469 , "in"
1470 , "instanceof"
1471 , "new"
1472 , "return"
1473 , "switch"
1474 , "this"
1475 , "throw"
1476 , "try"
1477 , "typeof"
1478 , "var"
1479 , "void"
1480 , "while"
1481 , "with"
1483 , "class"
1484 , "enum"
1485 , "export"
1486 , "extends"
1487 , "import"
1488 , "super"
1490 , "implements"
1491 , "interface"
1492 , "let"
1493 , "package"
1494 , "private"
1495 , "protected"
1496 , "public"
1497 , "static"
1498 , "yield"
1502translateNamespace :: Name -> String
1503translateNamespace (UN _) = idrNamespace
1504translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1505translateNamespace (MN _ _) = idrNamespace
1506translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1507translateNamespace NErased = idrNamespace
1510translateName :: Name -> String
1511translateName (UN name) = 'u' : translateIdentifier (str name)
1512translateName (NS name _) = 'n' : translateName name
1513translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1514translateName (SN name) = 's' : translateSpecialName name
1515translateName NErased = "e"
1518translateSpecialName :: SpecialName -> String
1519translateSpecialName name
1520 | WhereN i m n <- name =
1521 'w' : translateName m ++ translateName n ++ show i
1522 | InstanceN n s <- name =
1523 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1524 | ParentN n s <- name =
1525 'p' : translateName n ++ translateIdentifier (str s)
1526 | MethodN n <- name =
1527 'm' : translateName n
1528 | CaseN n <- name =
1529 'c' : translateName n
1532translateConstant :: Const -> JS
1533translateConstant (I i) = JSNum (JSInt i)
1534translateConstant (Fl f) = JSNum (JSFloat f)
1535translateConstant (Ch c) = JSString $ translateChar c
1536translateConstant (Str s) = JSString $ concatMap translateChar s
1537translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1538translateConstant StrType = JSType JSStringTy
1539translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1540translateConstant (AType ATFloat) = JSType JSFloatTy
1541translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1542translateConstant PtrType = JSType JSPtrTy
1543translateConstant Forgot = JSType JSForgotTy
1544translateConstant (BI i) = jsBigInt $ JSString (show i)
1545translateConstant c =
1546 jsError $ "Unimplemented Constant: " ++ show c
1549translateChar :: Char -> String
1550translateChar ch
1551 | '\a' <- ch = "\\u0007"
1552 | '\b' <- ch = "\\b"
1553 | '\f' <- ch = "\\f"
1554 | '\n' <- ch = "\\n"
1555 | '\r' <- ch = "\\r"
1556 | '\t' <- ch = "\\t"
1557 | '\v' <- ch = "\\v"
1558 | '\SO' <- ch = "\\u000E"
1559 | '\DEL' <- ch = "\\u007F"
1560 | '\\' <- ch = "\\\\"
1561 | '\"' <- ch = "\\\""
1562 | '\'' <- ch = "\\\'"
1563 | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
1564 | otherwise = [ch]
1565 where
1566 fill :: String -> String
1567 fill s = if length s == 1
1568 then '0' : s
1569 else s
1571 asciiTab =
1572 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
1573 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
1574 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
1575 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1578translateDeclaration :: (String, SDecl) -> [JS]
1579translateDeclaration (path, SFun name params stackSize body)
1580 | (MN _ ap) <- name
1581 , (SChkCase var cases) <- body
1582 , ap == txt "APPLY" =
1583 [ lookupTable "APPLY" [] var cases
1584 , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1585 JSTernary (
1586 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1587 (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1588 ) (JSApp
1589 (JSIndex
1590 (JSIdent (idrLTNamespace ++ "APPLY"))
1591 (JSProj (JSIdent "mfn0") "tag")
1593 [JSIdent "mfn0", JSIdent "marg0"]
1594 ) JSNull
1598 | (MN _ ev) <- name
1599 , (SChkCase var cases) <- body
1600 , ev == txt "EVAL" =
1601 [ lookupTable "EVAL" [] var cases
1602 , jsDecl $ JSFunction ["marg0"] (JSReturn $
1603 JSTernary (
1604 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1605 (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1606 ) (JSApp
1607 (JSIndex
1608 (JSIdent (idrLTNamespace ++ "EVAL"))
1609 (JSProj (JSIdent "marg0") "tag")
1611 [JSIdent "marg0"]
1612 ) (JSIdent "marg0")
1615 | otherwise =
1616 let fun = translateExpression body in
1617 [jsDecl $ jsFun fun]
1619 where
1620 hasProp :: String -> String -> JS
1621 hasProp table var =
1622 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1625 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1626 caseFun aux var cse =
1627 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1628 jsFunAux aux c
1631 getTag :: SAlt -> Maybe Int
1632 getTag (SConCase _ tag _ _ _) = Just tag
1633 getTag _ = Nothing
1636 lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1637 lookupTable table aux var cases =
1638 JSAlloc (idrLTNamespace ++ table) $ Just (
1639 JSApp (JSFunction [] (
1640 JSSeq $ [
1641 JSAlloc "t" $ Just (JSArray [])
1642 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1643 JSReturn (JSIdent "t")
1645 )) []
1647 where
1648 assignEntries :: [(Int, JS)] -> [JS]
1649 assignEntries entries =
1650 map (\(tag, fun) ->
1651 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1652 ) entries
1655 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1656 lookupEntry aux var alt = do
1657 tag <- getTag alt
1658 return (tag, caseFun aux var alt)
1661 jsDecl :: JS -> JS
1662 jsDecl = JSAlloc (path ++ translateName name) . Just
1665 jsFun body = jsFunAux [] body
1668 jsFunAux :: [(LVar, String)] -> JS -> JS
1669 jsFunAux aux body =
1670 JSFunction (p ++ map snd aux) (
1671 JSSeq $
1672 zipWith assignVar [0..] p ++
1673 map assignAux aux ++
1674 [JSReturn body]
1676 where
1677 assignVar :: Int -> String -> JS
1678 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1681 assignAux :: (LVar, String) -> JS
1682 assignAux (Loc var, val) =
1683 JSAlloc (jsVar var) (Just $ JSIdent val)
1686 p :: [String]
1687 p = map translateName params
1690translateVariableName :: LVar -> String
1691translateVariableName (Loc i) =
1692 jsVar i
1695translateExpression :: SExp -> JS
1696translateExpression (SLet name value body) =
1697 jsLet (translateVariableName name) (
1698 translateExpression value
1699 ) (translateExpression body)
1701translateExpression (SConst cst) =
1702 translateConstant cst
1704translateExpression (SV var) =
1705 JSVar var
1707translateExpression (SApp tc name vars)
1708 | False <- tc =
1709 jsTailcall $ translateFunctionCall name vars
1710 | True <- tc =
1711 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1712 JSReturn $ translateFunctionCall name vars
1713 )]
1714 where
1715 translateFunctionCall name vars =
1716 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1718translateExpression (SOp op vars)
1719 | LNoOp <- op = JSVar (last vars)
1721 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1722 | (LPlus (ATInt ITBig)) <- op
1723 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1724 | (LMinus (ATInt ITBig)) <- op
1725 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1726 | (LTimes (ATInt ITBig)) <- op
1727 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1728 | (LSDiv (ATInt ITBig)) <- op
1729 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1730 | (LSRem (ATInt ITBig)) <- op
1731 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1732 | (LEq (ATInt ITBig)) <- op
1733 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1734 | (LSLt (ATInt ITBig)) <- op
1735 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1736 | (LSLe (ATInt ITBig)) <- op
1737 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1738 | (LSGt (ATInt ITBig)) <- op
1739 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1740 | (LSGe (ATInt ITBig)) <- op
1741 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1743 | (LPlus ATFloat) <- op
1744 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1745 | (LMinus ATFloat) <- op
1746 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1747 | (LTimes ATFloat) <- op
1748 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1749 | (LSDiv ATFloat) <- op
1750 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1751 | (LEq ATFloat) <- op
1752 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1753 | (LSLt ATFloat) <- op
1754 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1755 | (LSLe ATFloat) <- op
1756 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1757 | (LSGt ATFloat) <- op
1758 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1759 | (LSGe ATFloat) <- op
1760 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1762 | (LPlus _) <- op
1763 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1764 | (LMinus _) <- op
1765 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1766 | (LTimes _) <- op
1767 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1768 | (LSDiv _) <- op
1769 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1770 | (LSRem _) <- op
1771 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1772 | (LEq _) <- op
1773 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1774 | (LSLt _) <- op
1775 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1776 | (LSLe _) <- op
1777 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1778 | (LSGt _) <- op
1779 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1780 | (LSGe _) <- op
1781 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1782 | (LAnd _) <- op
1783 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1784 | (LOr _) <- op
1785 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1786 | (LXOr _) <- op
1787 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1788 | (LSHL _) <- op
1789 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1790 | (LASHR _) <- op
1791 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1792 | (LCompl _) <- op
1793 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
1795 | LStrConcat <- op
1796 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1797 | LStrEq <- op
1798 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1799 | LStrLt <- op
1800 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1801 | LStrLen <- op
1802 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1804 | (LStrInt ITNative) <- op
1805 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1806 | (LIntStr ITNative) <- op
1807 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1808 | (LSExt ITNative ITBig) <- op
1809 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1810 | (LTrunc ITBig ITNative) <- op
1811 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1812 | (LIntStr ITBig) <- op
1813 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1814 | (LStrInt ITBig) <- op
1815 , (arg:_) <- vars = jsBigInt $ JSVar arg
1816 | LFloatStr <- op
1817 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1818 | LStrFloat <- op
1819 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1820 | (LIntFloat ITNative) <- op
1821 , (arg:_) <- vars = JSVar arg
1822 | (LFloatInt ITNative) <- op
1823 , (arg:_) <- vars = JSVar arg
1824 | (LChInt ITNative) <- op
1825 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1826 | (LIntCh ITNative) <- op
1827 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1829 | LFExp <- op
1830 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1831 | LFLog <- op
1832 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1833 | LFSin <- op
1834 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1835 | LFCos <- op
1836 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1837 | LFTan <- op
1838 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1839 | LFASin <- op
1840 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1841 | LFACos <- op
1842 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1843 | LFATan <- op
1844 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1845 | LFSqrt <- op
1846 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1847 | LFFloor <- op
1848 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1849 | LFCeil <- op
1850 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1852 | LStrCons <- op
1853 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1854 | LStrHead <- op
1855 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1856 | LStrRev <- op
1857 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1858 | LStrIndex <- op
1859 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1860 | LStrTail <- op
1861 , (arg:_) <- vars = let v = translateVariableName arg in
1862 JSApp (JSProj (JSIdent v) "substr") [
1863 JSNum (JSInt 1),
1864 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
1866 | LNullPtr <- op
1867 , (_) <- vars = JSNull
1869 where
1870 translateBinaryOp :: String -> LVar -> LVar -> JS
1871 translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)
1874 invokeMeth :: LVar -> String -> [LVar] -> JS
1875 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1877translateExpression (SError msg) =
1878 jsError msg
1880translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1881 jsCall (idrRTNamespace ++ "print") [JSVar var]
1883translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
1884 JSBinOp "==" (JSVar var) JSNull
1886translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
1887 JSBinOp "==" (JSVar lhs) (JSVar rhs)
1889translateExpression (SForeign _ _ fun args) =
1890 ffi fun (map generateWrapper args)
1891 where
1892 generateWrapper (ffunc, name)
1893 | FFunction <- ffunc =
1894 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1895 | FFunctionIO <- ffunc =
1896 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1898 generateWrapper (_, name) =
1899 translateVariableName name
1901translateExpression patterncase
1902 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1903 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1904 where
1905 caseHelper var cases param =
1906 JSApp (JSFunction [param] (
1907 JSCond $ map (expandCase param . translateCaseCond param) cases
1908 )) [JSVar var]
1911 expandCase :: String -> (Cond, JS) -> (JS, JS)
1912 expandCase _ (RawCond cond, branch) = (cond, branch)
1913 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1914 expandCase var (CaseCond caseTy, branch)
1915 | ConCase tag <- caseTy =
1916 let checkCon = JSIdent var `jsInstanceOf` jsCon
1917 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1918 (checkCon `jsAnd` checkTag, branch)
1920 | TypeCase ty <- caseTy =
1921 let checkTy = JSIdent var `jsInstanceOf` jsType
1922 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1923 (checkTy `jsAnd` checkTag, branch)
1925translateExpression (SCon i name vars) =
1926 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1927 , JSArray $ map JSVar vars
1930translateExpression (SUpdate var@(Loc i) e) =
1931 JSAssign (JSVar var) (translateExpression e)
1933translateExpression (SProj var i) =
1934 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1936translateExpression SNothing = JSNull
1938translateExpression e =
1939 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1942data FFI = FFICode Char | FFIArg Int | FFIError String
1945ffi :: String -> [String] -> JS
1946ffi code args = let parsed = ffiParse code in
1947 case ffiError parsed of
1948 Just err -> jsError err
1949 Nothing -> JSRaw $ renderFFI parsed args
1950 where
1951 ffiParse :: String -> [FFI]
1952 ffiParse "" = []
1953 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1954 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1955 ffiParse ('%':s:ss)
1956 | isDigit s =
1957 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1958 | otherwise =
1959 [FFIError "Invalid positional argument"]
1960 ffiParse (s:ss) = FFICode s : ffiParse ss
1963 ffiError :: [FFI] -> Maybe String
1964 ffiError [] = Nothing
1965 ffiError ((FFIError s):xs) = Just s
1966 ffiError (x:xs) = ffiError xs
1969 renderFFI :: [FFI] -> [String] -> String
1970 renderFFI [] _ = ""
1971 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1972 renderFFI ((FFIArg i) : fs) args
1973 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1974 | otherwise = "Argument index out of bounds"
1977data CaseType = ConCase Int
1978 | TypeCase JSType
1979 | DefaultCase
1980 deriving Eq
1983data Cond = CaseCond CaseType
1984 | RawCond JS
1987translateCaseCond :: String -> SAlt -> (Cond, JS)
1988translateCaseCond _ cse@(SDefaultCase _) =
1989 (CaseCond DefaultCase, translateCase Nothing cse)
1991translateCaseCond var cse@(SConstCase ty _)
1992 | StrType <- ty = matchHelper JSStringTy
1993 | PtrType <- ty = matchHelper JSPtrTy
1994 | Forgot <- ty = matchHelper JSForgotTy
1995 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1996 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1997 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1998 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1999 where
2000 matchHelper :: JSType -> (Cond, JS)
2001 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
2003translateCaseCond var cse@(SConstCase cst@(BI _) _) =
2004 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
2005 (RawCond cond, translateCase Nothing cse)
2007translateCaseCond var cse@(SConstCase cst _) =
2008 let cond = JSIdent var `jsEq` translateConstant cst in
2009 (RawCond cond, translateCase Nothing cse)
2011translateCaseCond var cse@(SConCase _ tag _ _ _) =
2012 (CaseCond $ ConCase tag, translateCase (Just var) cse)
2015translateCase :: Maybe String -> SAlt -> JS
2016translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
2017translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
2018translateCase (Just var) (SConCase a _ _ vars e) =
2019 let params = map jsVar [a .. (a + length vars)] in
2020 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
2021 JSThis, JSProj (JSIdent var) "vars"