git.iko.soy/Idris-dev
on d16d418 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
2624 lines 81 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, 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 Data.Word
21import System.IO
22import System.Directory
25idrNamespace :: String
26idrNamespace = "__IDR__"
27idrRTNamespace = "__IDRRT__"
28idrLTNamespace = "__IDRLT__"
29idrCTRNamespace = "__IDRCTR__"
32data JSTarget = Node | JavaScript deriving Eq
35data JSType = JSIntTy
36 | JSStringTy
37 | JSIntegerTy
38 | JSFloatTy
39 | JSCharTy
40 | JSPtrTy
41 | JSForgotTy
42 deriving Eq
45data JSInteger = JSBigZero
46 | JSBigOne
47 | JSBigInt Integer
48 deriving Eq
51data JSNum = JSInt Int
52 | JSFloat Double
53 | JSInteger JSInteger
54 deriving Eq
57data JSWord = JSWord8 Word8
58 | JSWord16 Word16
59 | JSWord32 Word32
60 | JSWord64 Word64
61 deriving Eq
64data JSAnnotation = JSConstructor deriving Eq
67instance Show JSAnnotation where
68 show JSConstructor = "constructor"
71data JS = JSRaw String
72 | JSIdent String
73 | JSFunction [String] JS
74 | JSType JSType
75 | JSSeq [JS]
76 | JSReturn JS
77 | JSApp JS [JS]
78 | JSNew String [JS]
79 | JSError String
80 | JSBinOp String JS JS
81 | JSPreOp String JS
82 | JSPostOp String JS
83 | JSProj JS String
84 | JSVar LVar
85 | JSNull
86 | JSThis
87 | JSTrue
88 | JSFalse
89 | JSArray [JS]
90 | JSString String
91 | JSNum JSNum
92 | JSWord JSWord
93 | JSAssign JS JS
94 | JSAlloc String (Maybe JS)
95 | JSIndex JS JS
96 | JSCond [(JS, JS)]
97 | JSTernary JS JS JS
98 | JSParens JS
99 | JSWhile JS JS
100 | JSFFI String [JS]
101 | JSAnnotation JSAnnotation JS
102 | JSNoop
103 deriving Eq
106data FFI = FFICode Char | FFIArg Int | FFIError String
109ffi :: String -> [String] -> String
110ffi code args = let parsed = ffiParse code in
111 case ffiError parsed of
112 Just err -> error err
113 Nothing -> renderFFI parsed args
114 where
115 ffiParse :: String -> [FFI]
116 ffiParse "" = []
117 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
118 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
119 ffiParse ('%':s:ss)
120 | isDigit s =
121 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
122 | otherwise =
123 [FFIError $ "FFI - Invalid positional argument"]
124 ffiParse (s:ss) = FFICode s : ffiParse ss
127 ffiError :: [FFI] -> Maybe String
128 ffiError [] = Nothing
129 ffiError ((FFIError s):xs) = Just s
130 ffiError (x:xs) = ffiError xs
133 renderFFI :: [FFI] -> [String] -> String
134 renderFFI [] _ = ""
135 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
136 renderFFI ((FFIArg i) : fs) args
137 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
138 | otherwise = error "FFI - Argument index out of bounds"
141compileJS :: JS -> String
142compileJS JSNoop = ""
144compileJS (JSAnnotation annotation js) =
145 "/** @" ++ show annotation ++ " */\n" ++ compileJS js
147compileJS (JSFFI raw args) =
148 ffi raw (map compileJS args)
150compileJS (JSRaw code) =
151 code
153compileJS (JSIdent ident) =
154 ident
156compileJS (JSFunction args body) =
157 "function("
158 ++ intercalate "," args
159 ++ "){\n"
160 ++ compileJS body
161 ++ "\n}"
163compileJS (JSType ty)
164 | JSIntTy <- ty = idrRTNamespace ++ "Int"
165 | JSStringTy <- ty = idrRTNamespace ++ "String"
166 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
167 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
168 | JSCharTy <- ty = idrRTNamespace ++ "Char"
169 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
170 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
172compileJS (JSSeq seq) =
173 intercalate ";\n" (map compileJS seq)
175compileJS (JSReturn val) =
176 "return " ++ compileJS val
178compileJS (JSApp lhs rhs)
179 | JSFunction {} <- lhs =
180 concat ["(", compileJS lhs, ")(", args, ")"]
181 | otherwise =
182 concat [compileJS lhs, "(", args, ")"]
183 where args :: String
184 args = intercalate "," $ map compileJS rhs
186compileJS (JSNew name args) =
187 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
189compileJS (JSError exc) =
190 "throw new Error(\"" ++ exc ++ "\")"
192compileJS (JSBinOp op lhs rhs) =
193 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
195compileJS (JSPreOp op val) =
196 op ++ compileJS val
198compileJS (JSProj obj field)
199 | JSFunction {} <- obj =
200 concat ["(", compileJS obj, ").", field]
201 | JSAssign {} <- obj =
202 concat ["(", compileJS obj, ").", field]
203 | otherwise =
204 compileJS obj ++ '.' : field
206compileJS (JSVar var) =
207 translateVariableName var
209compileJS JSNull =
210 "null"
212compileJS JSThis =
213 "this"
215compileJS JSTrue =
216 "true"
218compileJS JSFalse =
219 "false"
221compileJS (JSArray elems) =
222 "[" ++ intercalate "," (map compileJS elems) ++ "]"
224compileJS (JSString str) =
225 "\"" ++ str ++ "\""
227compileJS (JSNum num)
228 | JSInt i <- num = show i
229 | JSFloat f <- num = show f
230 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
231 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
232 | JSInteger (JSBigInt i) <- num = show i
234compileJS (JSAssign lhs rhs) =
235 compileJS lhs ++ "=" ++ compileJS rhs
237compileJS (JSAlloc name val) =
238 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
240compileJS (JSIndex lhs rhs) =
241 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
243compileJS (JSCond branches) =
244 intercalate " else " $ map createIfBlock branches
245 where
246 createIfBlock (JSNoop, e) =
247 "{\n"
248 ++ compileJS e
249 ++ ";\n}"
250 createIfBlock (cond, e) =
251 "if (" ++ compileJS cond ++") {\n"
252 ++ compileJS e
253 ++ ";\n}"
255compileJS (JSTernary cond true false) =
256 let c = compileJS cond
257 t = compileJS true
258 f = compileJS false in
259 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
261compileJS (JSParens js) =
262 "(" ++ compileJS js ++ ")"
264compileJS (JSWhile cond body) =
265 "while (" ++ compileJS cond ++ ") {\n"
266 ++ compileJS body
267 ++ "\n}"
269compileJS (JSWord word)
270 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
271 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
272 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
273 | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
276jsTailcall :: JS -> JS
277jsTailcall call =
278 jsCall (idrRTNamespace ++ "tailcall") [
279 JSFunction [] (JSReturn call)
280 ]
283jsCall :: String -> [JS] -> JS
284jsCall fun = JSApp (JSIdent fun)
287jsMeth :: JS -> String -> [JS] -> JS
288jsMeth obj meth =
289 JSApp (JSProj obj meth)
292jsInstanceOf :: JS -> JS -> JS
293jsInstanceOf = JSBinOp "instanceof"
296jsEq :: JS -> JS -> JS
297jsEq = JSBinOp "=="
300jsAnd :: JS -> JS -> JS
301jsAnd = JSBinOp "&&"
304jsOr :: JS -> JS -> JS
305jsOr = JSBinOp "||"
308jsType :: JS
309jsType = JSIdent $ idrRTNamespace ++ "Type"
312jsCon :: JS
313jsCon = JSIdent $ idrRTNamespace ++ "Con"
316jsTag :: JS -> JS
317jsTag obj = JSProj obj "tag"
320jsTypeTag :: JS -> JS
321jsTypeTag obj = JSProj obj "type"
324jsBigInt :: JS -> JS
325jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
326jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
327jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
330jsVar :: Int -> String
331jsVar = ("__var_" ++) . show
334jsLet :: String -> JS -> JS -> JS
335jsLet name value body =
336 JSApp (
337 JSFunction [name] (
338 JSReturn body
339 )
340 ) [value]
343jsError :: String -> JS
344jsError err = JSApp (JSFunction [] (JSError err)) []
346jsUnPackBits :: JS -> JS
347jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
350jsPackUBits8 :: JS -> JS
351jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
353jsPackUBits16 :: JS -> JS
354jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
356jsPackUBits32 :: JS -> JS
357jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
359jsPackSBits8 :: JS -> JS
360jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
362jsPackSBits16 :: JS -> JS
363jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
365jsPackSBits32 :: JS -> JS
366jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
369foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
370foldJS tr add acc js =
371 fold js
372 where
373 fold js
374 | JSFunction args body <- js =
375 add (tr js) (fold body)
376 | JSSeq seq <- js =
377 add (tr js) $ foldl' add acc (map fold seq)
378 | JSReturn ret <- js =
379 add (tr js) (fold ret)
380 | JSApp lhs rhs <- js =
381 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
382 | JSNew _ args <- js =
383 add (tr js) $ foldl' add acc $ map fold args
384 | JSBinOp _ lhs rhs <- js =
385 add (tr js) $ add (fold lhs) (fold rhs)
386 | JSPreOp _ val <- js =
387 add (tr js) $ fold val
388 | JSPostOp _ val <- js =
389 add (tr js) $ fold val
390 | JSProj obj _ <- js =
391 add (tr js) (fold obj)
392 | JSArray vals <- js =
393 add (tr js) $ foldl' add acc $ map fold vals
394 | JSAssign lhs rhs <- js =
395 add (tr js) $ add (fold lhs) (fold rhs)
396 | JSIndex lhs rhs <- js =
397 add (tr js) $ add (fold lhs) (fold rhs)
398 | JSAlloc _ val <- js =
399 add (tr js) $ fromMaybe acc $ fmap fold val
400 | JSTernary c t f <- js =
401 add (tr js) $ add (fold c) (add (fold t) (fold f))
402 | JSParens val <- js =
403 add (tr js) $ fold val
404 | JSCond conds <- js =
405 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
406 | JSWhile cond body <- js =
407 add (tr js) $ add (fold cond) (fold body)
408 | JSFFI raw args <- js =
409 add (tr js) $ foldl' add acc $ map fold args
410 | JSAnnotation a js <- js =
411 add (tr js) $ fold js
412 | otherwise =
413 tr js
416transformJS :: (JS -> JS) -> JS -> JS
417transformJS tr js =
418 transformHelper js
419 where
420 transformHelper :: JS -> JS
421 transformHelper js
422 | JSFunction args body <- js = JSFunction args $ tr body
423 | JSSeq seq <- js = JSSeq $ map tr seq
424 | JSReturn ret <- js = JSReturn $ tr ret
425 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
426 | JSNew con args <- js = JSNew con $ map tr args
427 | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
428 | JSPreOp op val <- js = JSPreOp op (tr val)
429 | JSPostOp op val <- js = JSPostOp op (tr val)
430 | JSProj obj field <- js = JSProj (tr obj) field
431 | JSArray vals <- js = JSArray $ map tr vals
432 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
433 | JSAlloc var val <- js = JSAlloc var $ fmap tr val
434 | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
435 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
436 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
437 | JSParens val <- js = JSParens $ tr val
438 | JSWhile cond body <- js = JSWhile (tr cond) (tr body)
439 | JSFFI raw args <- js = JSFFI raw (map tr args)
440 | JSAnnotation a js <- js = JSAnnotation a (tr js)
441 | otherwise = js
444moveJSDeclToTop :: String -> [JS] -> [JS]
445moveJSDeclToTop decl js = move ([], js)
446 where
447 move :: ([JS], [JS]) -> [JS]
448 move (front, js@(JSAnnotation _ (JSAlloc name _)):back)
449 | name == decl = js : front ++ back
451 move (front, js@(JSAlloc name _):back)
452 | name == decl = js : front ++ back
454 move (front, js:back) =
455 move (front ++ [js], back)
458jsSubst :: JS -> JS -> JS -> JS
459jsSubst var new old
460 | var == old = new
462jsSubst (JSIdent var) new (JSVar old)
463 | var == translateVariableName old = new
464 | otherwise = JSVar old
466jsSubst var new old@(JSIdent _)
467 | var == old = new
468 | otherwise = old
470jsSubst var new (JSArray fields) =
471 JSArray (map (jsSubst var new) fields)
473jsSubst var new (JSNew con vals) =
474 JSNew con $ map (jsSubst var new) vals
476jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
477 | var `notElem` args =
478 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
479 map (jsSubst (JSIdent var) new) vals
480 )
481 | otherwise =
482 JSApp (JSProj (JSFunction args body) "apply") (
483 map (jsSubst (JSIdent var) new) vals
484 )
486jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
487 | var /= arg =
488 JSApp (JSFunction [arg] (
489 jsSubst (JSIdent var) new body
490 )) $ map (jsSubst (JSIdent var) new) vals
491 | otherwise =
492 JSApp (JSFunction [arg] (
493 body
494 )) $ map (jsSubst (JSIdent var) new) vals
496jsSubst var new js = transformJS (jsSubst var new) js
499removeAllocations :: JS -> JS
500removeAllocations (JSSeq body) =
501 let opt = removeHelper (map removeAllocations body) in
502 case opt of
503 [ret] -> ret
504 _ -> JSSeq opt
505 where
506 removeHelper :: [JS] -> [JS]
507 removeHelper [js] = [js]
508 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
509 map (jsSubst (JSIdent name) val) (removeHelper js)
510 removeHelper (j:js) = j : removeHelper js
512removeAllocations js = transformJS removeAllocations js
515isJSConstant :: JS -> Bool
516isJSConstant js
517 | JSString _ <- js = True
518 | JSNum _ <- js = True
519 | JSType _ <- js = True
520 | JSNull <- js = True
521 | JSArray vals <- js = all isJSConstant vals
523 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
525 | otherwise = False
527isJSConstantConstructor :: [String] -> JS -> Bool
528isJSConstantConstructor constants js
529 | isJSConstant js =
530 True
531 | JSArray vals <- js =
532 all (isJSConstantConstructor constants) vals
533 | JSNew "__IDRRT__Con" args <- js =
534 all (isJSConstantConstructor constants) args
535 | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js
536 , name `elem` constants =
537 True
538 | JSIdent name <- js
539 , name `elem` constants =
540 True
541 | otherwise = False
544inlineJS :: JS -> JS
545inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
546 where
547 inlineJSLet :: JS -> JS
548 inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])
549 | opt <- inlineJSLet val =
550 inlineJS $ jsSubst (JSIdent arg) opt ret
552 inlineJSLet js = transformJS inlineJSLet js
555 inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
556 | opt <- inlineCaseMatch val =
557 inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
559 inlineCaseMatch js = transformJS inlineCaseMatch js
562 inlineApply js
563 | JSApp (
564 JSProj (JSFunction args (JSReturn body)) "apply"
565 ) [JSThis, JSProj var "vars"] <- js =
566 inlineApply $ inlineApply' var args body 0
567 | JSReturn (JSApp (
568 JSProj (JSFunction args body@(JSCond _)) "apply"
569 ) [JSThis, JSProj var "vars"]) <- js =
570 inlineApply $ inlineApply' var args body 0
571 where
572 inlineApply' _ [] body _ = body
573 inlineApply' var (a:as) body n =
574 inlineApply' var as (
575 jsSubst (JSIdent a) (
576 JSIndex (JSProj var "vars") (JSNum (JSInt n))
577 ) body
578 ) (n + 1)
580 inlineApply js = transformJS inlineApply js
583 inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
584 inlineError error
586 inlineError js = transformJS inlineError js
589 inlineAssign (JSAssign lhs rhs)
590 | JSVar _ <- lhs
591 , JSVar _ <- rhs
592 , lhs == rhs =
593 lhs
595 inlineAssign (JSAssign lhs rhs)
596 | JSIdent _ <- lhs
597 , JSIdent _ <- rhs
598 , lhs == rhs =
599 lhs
601 inlineAssign js = transformJS inlineAssign js
604removeEval :: [JS] -> [JS]
605removeEval js =
606 let (ret, isReduced) = checkEval js in
607 if isReduced
608 then removeEvalApp ret
609 else ret
610 where
611 removeEvalApp js = catMaybes (map removeEvalApp' js)
612 where
613 removeEvalApp' :: JS -> Maybe JS
614 removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
615 removeEvalApp' js = Just $ transformJS match js
616 where
617 match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val
618 match js = transformJS match js
620 checkEval :: [JS] -> ([JS], Bool)
621 checkEval js = foldr f ([], False) $ map checkEval' js
622 where
623 f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)
624 f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)
625 f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)
628 checkEval' :: JS -> (Maybe JS, Bool)
629 checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
630 JSSeq [ _
631 , JSReturn (JSIdent "t")
632 ]
633 )) []))) = (Nothing, True)
635 checkEval' js = (Just js, False)
638reduceJS :: [JS] -> [JS]
639reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
642funName :: JS -> String
643funName (JSAlloc fun _) = fun
646elimDeadLoop :: [JS] -> [JS]
647elimDeadLoop js
648 | ret <- deadEvalApplyCases js
649 , ret /= js = elimDeadLoop ret
650 | otherwise = js
653deadEvalApplyCases :: [JS] -> [JS]
654deadEvalApplyCases js =
655 let tags = sort $ nub $ concatMap (getTags) js in
656 map (removeHelper tags) js
657 where
658 getTags :: JS -> [Int]
659 getTags = foldJS match (++) []
660 where
661 match js
662 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
663 | otherwise = []
666 removeHelper :: [Int] -> JS -> JS
667 removeHelper tags (JSAlloc fun (Just (
668 JSApp (JSFunction [] (JSSeq seq)) []))
669 ) =
670 (JSAlloc fun (Just (
671 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
672 )
674 removeHelper _ js = js
677 remover :: [Int] -> [JS] -> [JS]
678 remover tags (
679 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
680 )
681 | tag `notElem` tags = remover tags js
683 remover tags (j:js) = j : remover tags js
684 remover _ [] = []
687initConstructors :: [JS] -> [JS]
688initConstructors js =
689 let tags = nub $ sort $ concat (map getTags js) in
690 rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
691 where
692 rearrangePrelude :: [JS] -> [JS]
693 rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
696 getTags :: JS -> [Int]
697 getTags = foldJS match (++) []
698 where
699 match js
700 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
701 | otherwise = []
704 replaceConstructors :: [Int] -> [JS] -> [JS]
705 replaceConstructors tags js = map (replaceHelper tags) js
706 where
707 replaceHelper :: [Int] -> JS -> JS
708 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
709 | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
711 replaceHelper tags js = transformJS (replaceHelper tags) js
714 createConstant :: Int -> JS
715 createConstant tag =
716 JSAlloc (idrCTRNamespace ++ show tag) (Just (
717 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
718 ))
721removeIDs :: [JS] -> [JS]
722removeIDs js =
723 case partition isID js of
724 ([], rest) -> rest
725 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
726 where isID :: JS -> Bool
727 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
728 | JSReturn (JSVar _) <- last body = True
730 isID _ = False
733 idFor :: JS -> (String, Int)
734 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
735 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
738 removeIDCall :: [(String, Int)] -> JS -> JS
739 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
740 JSReturn (JSApp (JSIdent fun) args)
741 )])
742 | Just pos <- lookup fun ids
743 , pos < length args = removeIDCall ids (args !! pos)
745 removeIDCall ids (JSNew _ [JSFunction [] (
746 JSReturn (JSApp (JSIdent fun) args)
747 )])
748 | Just pos <- lookup fun ids
749 , pos < length args = removeIDCall ids (args !! pos)
751 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
752 | Just pos <- lookup fun ids
753 , pos < length args = removeIDCall ids (args !! pos)
755 removeIDCall ids js = transformJS (removeIDCall ids) js
758inlineFunction :: String -> [String] -> JS -> JS -> JS
759inlineFunction fun args body js = inline' js
760 where
761 inline' :: JS -> JS
762 inline' (JSApp (JSIdent name) vals)
763 | name == fun =
764 let (js, phs) = insertPlaceHolders args body in
765 inline' $ foldr (uncurry jsSubst) js (zip phs vals)
767 inline' js = transformJS inline' js
769 insertPlaceHolders :: [String] -> JS -> (JS, [JS])
770 insertPlaceHolders args body = insertPlaceHolders' args body []
771 where
772 insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
773 insertPlaceHolders' (a:as) body ph
774 | (body', ph') <- insertPlaceHolders' as body ph =
775 let phvar = JSIdent $ "__PH_" ++ show (length ph') in
776 (jsSubst (JSIdent a) phvar body', phvar : ph')
778 insertPlaceHolders' [] body ph = (body, ph)
781inlineFunctions :: [JS] -> [JS]
782inlineFunctions js =
783 inlineHelper ([], js)
784 where
785 inlineHelper :: ([JS], [JS]) -> [JS]
786 inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
787 | countAll fun front + countAll fun back == 0 =
788 inlineHelper (front, back)
789 | Just new <- inlineAble (
790 countAll fun front + countAll fun back
791 ) fun args body =
792 let f = map (inlineFunction fun args new) in
793 inlineHelper (f front, f back)
795 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
796 inlineHelper (front, []) = front
799 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
800 inlineAble 1 fun args (JSReturn body)
801 | nonRecur fun body =
802 if all (<= 1) (map ($ body) (map countIDOccurences args))
803 then Just body
804 else Nothing
806 inlineAble _ _ _ _ = Nothing
809 nonRecur :: String -> JS -> Bool
810 nonRecur name body = countInvokations name body == 0
813 countAll :: String -> [JS] -> Int
814 countAll name js = sum $ map (countInvokations name) js
817 countIDOccurences :: String -> JS -> Int
818 countIDOccurences name = foldJS match (+) 0
819 where
820 match :: JS -> Int
821 match js
822 | JSIdent ident <- js
823 , name == ident = 1
824 | otherwise = 0
827 countInvokations :: String -> JS -> Int
828 countInvokations name = foldJS match (+) 0
829 where
830 match :: JS -> Int
831 match js
832 | JSApp (JSIdent ident) _ <- js
833 , name == ident = 1
834 | JSNew con _ <- js
835 , name == con = 1
836 | otherwise = 0
839reduceContinuations :: JS -> JS
840reduceContinuations = inlineTC . reduceJS
841 where
842 reduceJS :: JS -> JS
843 reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
844 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
845 )]) = reduceJS js
847 reduceJS js = transformJS reduceJS js
850 inlineTC :: JS -> JS
851 inlineTC js
852 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
853 JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
854 JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
855 JSReturn (JSNew "__IDRRT__Cont" _)
856 )])
857 )])
858 )] <- js = inlineTC ret
860 inlineTC js = transformJS inlineTC js
865reduceConstant :: JS -> JS
866reduceConstant
867 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
868 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
869 )])
870 | JSNum num <- val = val
871 | JSBinOp op lhs rhs <- val =
872 JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
874 | JSApp (JSProj lhs op) [rhs] <- val
875 , op `elem` [ "subtract"
876 , "add"
877 , "multiply"
878 , "divide"
879 , "mod"
880 , "equals"
881 , "lesser"
882 , "lesserOrEquals"
883 , "greater"
884 , "greaterOrEquals"
885 ] = val
887reduceConstant (JSApp ident [(JSParens js)]) =
888 JSApp ident [reduceConstant js]
890reduceConstant js = transformJS reduceConstant js
893reduceConstants :: JS -> JS
894reduceConstants js
895 | ret <- reduceConstant js
896 , ret /= js = reduceConstants ret
897 | otherwise = js
900elimDuplicateEvals :: JS -> JS
901elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
902 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
903 where
904 elimHelper :: [JS] -> [JS]
905 elimHelper (j@(JSAlloc var (Just val)):js) =
906 j : map (jsSubst val (JSIdent var)) (elimHelper js)
907 elimHelper (j:js) =
908 j : elimHelper js
909 elimHelper [] = []
911elimDuplicateEvals js = js
914optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
915optimizeRuntimeCalls fun tc js =
916 optTC tc : map optHelper js
917 where
918 optHelper :: JS -> JS
919 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
920 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
921 ])
922 | n == fun = JSApp (JSIdent tc) $ map optHelper args
924 optHelper js = transformJS optHelper js
927 optTC :: String -> JS
928 optTC tc@"__IDRRT__EVALTC" =
929 JSAlloc tc (Just $ JSFunction ["arg0"] (
930 JSSeq [ JSAlloc "ret" $ Just (
931 JSTernary (
932 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
933 (hasProp "__IDRLT__EVAL" "arg0")
934 ) (JSApp
935 (JSIndex
936 (JSIdent "__IDRLT__EVAL")
937 (JSProj (JSIdent "arg0") "tag")
938 )
939 [JSIdent "arg0"]
940 ) (JSIdent "arg0")
941 )
942 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
943 JSAssign (JSIdent "ret") (
944 JSApp (JSProj (JSIdent "ret") "k") []
945 )
946 )
947 , JSReturn $ JSIdent "ret"
948 ]
949 ))
951 optTC tc@"__IDRRT__APPLYTC" =
952 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
953 JSSeq [ JSAlloc "ret" $ Just (
954 JSTernary (
955 (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
956 (hasProp "__IDRLT__APPLY" "fn0")
957 ) (JSApp
958 (JSIndex
959 (JSIdent "__IDRLT__APPLY")
960 (JSProj (JSIdent "fn0") "tag")
961 )
962 [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
963 ) JSNull
964 )
965 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
966 JSAssign (JSIdent "ret") (
967 JSApp (JSProj (JSIdent "ret") "k") []
968 )
969 )
970 , JSReturn $ JSIdent "ret"
971 ]
972 ))
975 hasProp :: String -> String -> JS
976 hasProp table var =
977 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
980unfoldLookupTable :: [JS] -> [JS]
981unfoldLookupTable input =
982 let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
983 (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
984 js = applyunfold in
985 adaptRuntime $ expandCons evals applys js
986 where
987 adaptRuntime :: [JS] -> [JS]
988 adaptRuntime =
989 adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
992 adaptApply :: [JS] -> [JS]
993 adaptApply js = adaptApply' [] js
994 where
995 adaptApply' :: [JS] -> [JS] -> [JS]
996 adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
997 front ++ (new:back)
999 adaptApply' front (next:back) =
1000 adaptApply' (front ++ [next]) back
1002 adaptApply' front [] = front
1004 new =
1005 JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
1006 JSTernary (
1007 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1008 (JSProj (JSIdent "mfn0") "app")
1009 ) (JSApp
1010 (JSProj (JSIdent "mfn0") "app")
1011 [JSIdent "mfn0", JSIdent "marg0"]
1012 ) JSNull
1017 adaptApplyTC :: [JS] -> [JS]
1018 adaptApplyTC js = adaptApplyTC' [] js
1019 where
1020 adaptApplyTC' :: [JS] -> [JS] -> [JS]
1021 adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =
1022 front ++ (new:back)
1024 adaptApplyTC' front (next:back) =
1025 adaptApplyTC' (front ++ [next]) back
1027 adaptApplyTC' front [] = front
1029 new =
1030 JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
1031 JSSeq [ JSAlloc "ret" $ Just (
1032 JSTernary (
1033 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1034 (JSProj (JSIdent "mfn0") "app")
1035 ) (JSApp
1036 (JSProj (JSIdent "mfn0") "app")
1037 [JSIdent "mfn0", JSIdent "marg0"]
1038 ) JSNull
1040 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1041 JSAssign (JSIdent "ret") (
1042 JSApp (JSProj (JSIdent "ret") "k") []
1045 , JSReturn $ JSIdent "ret"
1047 ))
1050 adaptEval :: [JS] -> [JS]
1051 adaptEval js = adaptEval' [] js
1052 where
1053 adaptEval' :: [JS] -> [JS] -> [JS]
1054 adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =
1055 front ++ (new:back)
1057 adaptEval' front (next:back) =
1058 adaptEval' (front ++ [next]) back
1060 adaptEval' front [] = front
1062 new =
1063 JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
1064 JSTernary (
1065 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1066 (JSProj (JSIdent "marg0") "eval")
1067 ) (JSApp
1068 (JSProj (JSIdent "marg0") "eval")
1069 [JSIdent "marg0"]
1070 ) (JSIdent "marg0")
1075 adaptEvalTC :: [JS] -> [JS]
1076 adaptEvalTC js = adaptEvalTC' [] js
1077 where
1078 adaptEvalTC' :: [JS] -> [JS] -> [JS]
1079 adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =
1080 front ++ (new:back)
1082 adaptEvalTC' front (next:back) =
1083 adaptEvalTC' (front ++ [next]) back
1085 adaptEvalTC' front [] = front
1087 new =
1088 JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
1089 JSSeq [ JSAlloc "ret" $ Just (
1090 JSTernary (
1091 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1092 (JSProj (JSIdent "marg0") "eval")
1093 ) (JSApp
1094 (JSProj (JSIdent "marg0") "eval")
1095 [JSIdent "marg0"]
1096 ) (JSIdent "marg0")
1098 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1099 JSAssign (JSIdent "ret") (
1100 JSApp (JSProj (JSIdent "ret") "k") []
1103 , JSReturn $ JSIdent "ret"
1105 ))
1108 adaptCon js =
1109 adaptCon' [] js
1110 where
1111 adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =
1112 front ++ (new:back)
1114 adaptCon' front (next:back) =
1115 adaptCon' (front ++ [next]) back
1117 adaptCon' front [] = front
1120 new =
1121 JSAnnotation JSConstructor $
1122 JSAlloc "__IDRRT__Con" (Just $
1123 JSFunction newArgs (
1124 JSSeq (map newVar newArgs)
1127 where
1128 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1129 newArgs = ["tag", "eval", "app", "vars"]
1132 unfoldLT :: String -> [JS] -> ([Int], [JS])
1133 unfoldLT lt js =
1134 let (table, code) = extractLT lt js
1135 expanded = expandLT lt table in
1136 (map fst expanded, map snd expanded ++ code)
1139 expandCons :: [Int] -> [Int] -> [JS] -> [JS]
1140 expandCons evals applys js =
1141 map expandCons' js
1142 where
1143 expandCons' :: JS -> JS
1144 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
1145 | evalid <- getId "__IDRLT__EVAL" tag evals
1146 , applyid <- getId "__IDRLT__APPLY" tag applys =
1147 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
1148 , maybe JSNull JSIdent evalid
1149 , maybe JSNull JSIdent applyid
1150 , JSArray (map expandCons' args)
1153 expandCons' js = transformJS expandCons' js
1156 getId :: String -> Int -> [Int] -> Maybe String
1157 getId lt tag entries
1158 | tag `elem` entries = Just $ ltIdentifier lt tag
1159 | otherwise = Nothing
1162 ltIdentifier :: String -> Int -> String
1163 ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
1164 ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
1167 extractLT :: String -> [JS] -> (JS, [JS])
1168 extractLT lt js =
1169 extractLT' ([], js)
1170 where
1171 extractLT' :: ([JS], [JS]) -> (JS, [JS])
1172 extractLT' (front, js@(JSAlloc fun _):back)
1173 | fun == lt = (js, front ++ back)
1175 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
1176 extractLT' (front, back) = (JSNoop, front ++ back)
1179 expandLT :: String -> JS -> [(Int, JS)]
1180 expandLT lt (
1181 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
1182 ) = catMaybes (map expandEntry seq)
1183 where
1184 expandEntry :: JS -> Maybe (Int, JS)
1185 expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
1186 Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
1188 expandEntry js = Nothing
1190 expandLT lt JSNoop = []
1193removeInstanceChecks :: JS -> JS
1194removeInstanceChecks (JSCond conds) =
1195 removeNoopConds $ JSCond $ eliminateDeadBranches $ map (
1196 removeHelper *** removeInstanceChecks
1197 ) conds
1198 where
1199 removeHelper (
1200 JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
1201 ) = removeHelper check
1202 removeHelper js = js
1205 eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]
1206 eliminateDeadBranches [(_, js)] = [(JSNoop, js)]
1207 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
1208 eliminateDeadBranches [] = []
1211 removeNoopConds :: JS -> JS
1212 removeNoopConds (JSCond [(JSNoop, js)]) = js
1213 removeNoopConds js = js
1215removeInstanceChecks js = transformJS removeInstanceChecks js
1218reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
1219reduceLoop reduced (cons, program) =
1220 case partition findConstructors program of
1221 ([], js) -> cons ++ js
1222 (candidates, rest) ->
1223 let names = reduced ++ map funName candidates in
1224 reduceLoop names (
1225 cons ++ map reduce candidates, map (reduceCall names) rest
1227 where findConstructors :: JS -> Bool
1228 findConstructors js
1229 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
1230 reducable $ last body
1231 | otherwise = False
1232 where reducable :: JS -> Bool
1233 reducable js
1234 | JSReturn ret <- js = reducable ret
1235 | JSNew _ args <- js = and $ map reducable args
1236 | JSArray fields <- js = and $ map reducable fields
1237 | JSNum _ <- js = True
1238 | JSNull <- js = True
1239 | JSIdent _ <- js = True
1240 | otherwise = False
1243 reduce :: JS -> JS
1244 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1245 | JSReturn js <- last body = (JSAlloc fun (Just js))
1247 reduce js = js
1250 reduceCall :: [String] -> JS -> JS
1251 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1252 JSReturn (JSApp id@(JSIdent ret) _)
1253 )])
1254 | ret `elem` funs = id
1256 reduceCall funs js@(JSApp id@(JSIdent fun) _)
1257 | fun `elem` funs = id
1259 reduceCall funs js = transformJS (reduceCall funs) js
1262extractLocalConstructors :: [JS] -> [JS]
1263extractLocalConstructors js =
1264 concatMap extractLocalConstructors' js
1265 where
1266 globalCons :: [String]
1267 globalCons = concatMap (getGlobalCons) js
1270 extractLocalConstructors' :: JS -> [JS]
1271 extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1272 addCons cons [foldr (uncurry jsSubst) js (reverse cons)]
1273 where
1274 cons :: [(JS, JS)]
1275 cons = zipWith genName (foldJS match (++) [] body) [1..]
1276 where
1277 genName :: JS -> Int -> (JS, JS)
1278 genName js id =
1279 (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1281 match :: JS -> [JS]
1282 match js
1283 | JSNew "__IDRRT__Con" args <- js
1284 , all isConstant args = [js]
1285 | otherwise = []
1288 addCons :: [(JS, JS)] -> [JS] -> [JS]
1289 addCons [] js = js
1290 addCons (con@(_, name):cons) js
1291 | sum (map (countOccur name) js) > 0 =
1292 addCons cons ((allocCon con) : js)
1293 | otherwise =
1294 addCons cons js
1297 countOccur :: JS -> JS -> Int
1298 countOccur ident js = foldJS match (+) 0 js
1299 where
1300 match :: JS -> Int
1301 match js
1302 | js == ident = 1
1303 | otherwise = 0
1306 allocCon :: (JS, JS) -> JS
1307 allocCon (js, JSIdent name) =
1308 JSAlloc name (Just js)
1311 isConstant :: JS -> Bool
1312 isConstant js
1313 | JSNew "__IDRRT__Con" args <- js
1314 , all isConstant args =
1315 True
1316 | otherwise =
1317 isJSConstantConstructor globalCons js
1319 extractLocalConstructors' js = [js]
1322 getGlobalCons :: JS -> [String]
1323 getGlobalCons js = foldJS match (++) [] js
1324 where
1325 match :: JS -> [String]
1326 match js
1327 | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1328 [name]
1329 | otherwise =
1330 []
1333evalCons :: [JS] -> [JS]
1334evalCons js =
1335 map (collapseCont . collapseTC . expandProj . evalCons') js
1336 where
1337 cons :: [(String, JS)]
1338 cons = concatMap getGlobalCons js
1340 evalCons' :: JS -> JS
1341 evalCons' js = transformJS match js
1342 where
1343 match :: JS -> JS
1344 match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1345 | JSIdent name <- arg
1346 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1347 arg
1349 match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1350 | JSIdent name <- arg
1351 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1352 arg
1354 match js = transformJS match js
1357 lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1358 lookupConstructor ctr cons
1359 | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1360 | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1361 | otherwise = Nothing
1364 expandProj :: JS -> JS
1365 expandProj js = transformJS match js
1366 where
1367 match :: JS -> JS
1368 match (
1369 JSIndex (
1370 JSProj (JSIdent name) "vars"
1371 ) (
1372 JSNum (JSInt idx)
1375 | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1376 args !! idx
1378 match js = transformJS match js
1381 collapseTC :: JS -> JS
1382 collapseTC js = transformJS match js
1383 where
1384 match :: JS -> JS
1385 match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1386 JSReturn (JSIdent name)
1387 )])
1388 | Just _ <- lookup name cons = (JSIdent name)
1390 match js = transformJS match js
1393 collapseCont :: JS -> JS
1394 collapseCont js = transformJS match js
1395 where
1396 match :: JS -> JS
1397 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1398 JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1399 )]) = collapseCont ret
1402 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1403 JSReturn (JSIdent name)
1404 )]) = JSIdent name
1406 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1407 JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1408 )])
1409 | all collapsable args = ret
1410 where
1411 collapsable :: JS -> Bool
1412 collapsable (JSIdent _) = True
1413 collapsable js = isJSConstantConstructor (map fst cons) js
1416 match js = transformJS match js
1419elimConds :: [JS] -> [JS]
1420elimConds js =
1421 let (conds, rest) = partition isCond js in
1422 foldl' eraseCond rest conds
1423 where
1424 isCond :: JS -> Bool
1425 isCond (JSAlloc
1426 fun (Just (JSFunction args (JSCond
1427 [ (JSBinOp "==" (JSNum (JSInt tag)) (JSProj (JSIdent _) "tag"), JSReturn t)
1428 , (JSNoop, JSReturn f)
1429 ])))
1431 | isJSConstant t && isJSConstant f =
1432 True
1434 | JSIdent _ <- t
1435 , JSIdent _ <- f =
1436 True
1438 isCond (JSAlloc
1439 fun (Just (JSFunction args (JSCond
1440 [ (JSBinOp "==" (JSIdent _) c, JSReturn t)
1441 , (JSNoop, JSReturn f)
1442 ])))
1444 | isJSConstant t && isJSConstant f && isJSConstant c =
1445 True
1447 | JSIdent _ <- t
1448 , JSIdent _ <- f
1449 , isJSConstant c =
1450 True
1452 isCond _ = False
1455 eraseCond :: [JS] -> JS -> [JS]
1456 eraseCond js (JSAlloc
1457 fun (Just (JSFunction args (JSCond
1458 [ (c, JSReturn t)
1459 , (_, JSReturn f)
1460 ])
1462 )) = map (inlineFunction fun args (JSTernary c t f)) js
1465removeUselessCons :: [JS] -> [JS]
1466removeUselessCons js =
1467 let (cons, rest) = partition isUseless js in
1468 foldl' eraseCon rest cons
1469 where
1470 isUseless :: JS -> Bool
1471 isUseless (JSAlloc fun (Just JSNull)) = True
1472 isUseless (JSAlloc fun (Just (JSIdent _))) = True
1473 isUseless _ = False
1476 eraseCon :: [JS] -> JS -> [JS]
1477 eraseCon js (JSAlloc fun (Just val)) = map (jsSubst (JSIdent fun) val) js
1480getGlobalCons :: JS -> [(String, JS)]
1481getGlobalCons js = foldJS match (++) [] js
1482 where
1483 match :: JS -> [(String, JS)]
1484 match js
1485 | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1486 [(name, con)]
1487 | (JSAlloc name (Just con@(JSIdent _))) <- js =
1488 [(name, con)]
1489 | otherwise =
1490 []
1493getIncludes :: [FilePath] -> IO [String]
1494getIncludes = mapM readFile
1496codegenJavaScript :: CodeGenerator
1497codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
1498 (includes ci) (outputFile ci) (outputType ci)
1500codegenNode :: CodeGenerator
1501codegenNode ci = codegenJS_all Node (simpleDecls ci)
1502 (includes ci) (outputFile ci) (outputType ci)
1504codegenJS_all
1505 :: JSTarget
1506 -> [(Name, SDecl)]
1507 -> [FilePath]
1508 -> FilePath
1509 -> OutputType
1510 -> IO ()
1511codegenJS_all target definitions includes filename outputType = do
1512 let (header, rt) = case target of
1513 Node ->
1514 ("#!/usr/bin/env node\n", "-node")
1515 JavaScript ->
1516 ("", "-browser")
1517 included <- getIncludes includes
1518 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1519 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1520 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
1521 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1522 writeFile filename $ header ++ (
1523 intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions
1526 setPermissions filename (emptyPermissions { readable = True
1527 , executable = target == Node
1528 , writable = True
1529 })
1530 where
1531 def :: [(String, SDecl)]
1532 def = map (first translateNamespace) definitions
1535 checkForBigInt :: [JS] -> Bool
1536 checkForBigInt js = occur
1537 where
1538 occur :: Bool
1539 occur = or $ map (foldJS match (||) False) js
1541 match :: JS -> Bool
1542 match (JSIdent "__IDRRT__bigInt") = True
1543 match (JSWord (JSWord64 _)) = True
1544 match (JSNum (JSInteger _)) = True
1545 match js = False
1548 runtime :: String -> String -> String -> [String]
1549 runtime jsbn idrRuntime tgtRuntime =
1550 if checkForBigInt optimized
1551 then [jsbn, idrRuntime, tgtRuntime]
1552 else [idrRuntime, tgtRuntime]
1555 optimized :: [JS]
1556 optimized = translate >>> optimize $ def
1557 where
1558 translate p =
1559 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1560 optimize p =
1561 foldl' (flip ($)) p opt
1563 opt =
1564 [ removeEval
1565 , map inlineJS
1566 , removeIDs
1567 , reduceJS
1568 , map reduceConstants
1569 , initConstructors
1570 , map removeAllocations
1571 , elimDeadLoop
1572 , map elimDuplicateEvals
1573 , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1574 , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1575 , map removeInstanceChecks
1576 , inlineFunctions
1577 , map reduceContinuations
1578 , extractLocalConstructors
1579 , unfoldLookupTable
1580 , evalCons
1581 , elimConds
1582 , removeUselessCons
1585 functions :: [String]
1586 functions = map compileJS optimized
1588 prelude :: [JS]
1589 prelude =
1590 [ JSAnnotation JSConstructor $
1591 JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1592 JSAssign (JSProj JSThis "k") (JSIdent "k")
1593 ))
1594 , JSAnnotation JSConstructor $
1595 JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1596 JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1597 , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1599 ))
1602 mainLoop :: JS
1603 mainLoop =
1604 JSAlloc "main" $ Just $ JSFunction [] (
1605 case target of
1606 Node -> mainFun
1607 JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [
1608 JSString "DOMContentLoaded", JSFunction [] (
1609 mainFun
1610 ), JSFalse
1611 ])]
1613 where
1614 mainFun :: JS
1615 mainFun = jsTailcall $ jsCall runMain []
1618 isReady :: JS
1619 isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
1622 readyState :: JS
1623 readyState = JSProj (JSIdent "document") "readyState"
1626 runMain :: String
1627 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1630 invokeLoop :: JS
1631 invokeLoop = jsCall "main" []
1634translateIdentifier :: String -> String
1635translateIdentifier =
1636 replaceReserved . concatMap replaceBadChars
1637 where replaceBadChars :: Char -> String
1638 replaceBadChars c
1639 | ' ' <- c = "_"
1640 | '_' <- c = "__"
1641 | isDigit c = '_' : show (ord c)
1642 | not (isLetter c && isAscii c) = '_' : show (ord c)
1643 | otherwise = [c]
1644 replaceReserved s
1645 | s `elem` reserved = '_' : s
1646 | otherwise = s
1649 reserved = [ "break"
1650 , "case"
1651 , "catch"
1652 , "continue"
1653 , "debugger"
1654 , "default"
1655 , "delete"
1656 , "do"
1657 , "else"
1658 , "finally"
1659 , "for"
1660 , "function"
1661 , "if"
1662 , "in"
1663 , "instanceof"
1664 , "new"
1665 , "return"
1666 , "switch"
1667 , "this"
1668 , "throw"
1669 , "try"
1670 , "typeof"
1671 , "var"
1672 , "void"
1673 , "while"
1674 , "with"
1676 , "class"
1677 , "enum"
1678 , "export"
1679 , "extends"
1680 , "import"
1681 , "super"
1683 , "implements"
1684 , "interface"
1685 , "let"
1686 , "package"
1687 , "private"
1688 , "protected"
1689 , "public"
1690 , "static"
1691 , "yield"
1695translateNamespace :: Name -> String
1696translateNamespace (UN _) = idrNamespace
1697translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1698translateNamespace (MN _ _) = idrNamespace
1699translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1700translateNamespace NErased = idrNamespace
1703translateName :: Name -> String
1704translateName (UN name) = 'u' : translateIdentifier (str name)
1705translateName (NS name _) = 'n' : translateName name
1706translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1707translateName (SN name) = 's' : translateSpecialName name
1708translateName NErased = "e"
1711translateSpecialName :: SpecialName -> String
1712translateSpecialName name
1713 | WhereN i m n <- name =
1714 'w' : translateName m ++ translateName n ++ show i
1715 | InstanceN n s <- name =
1716 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1717 | ParentN n s <- name =
1718 'p' : translateName n ++ translateIdentifier (str s)
1719 | MethodN n <- name =
1720 'm' : translateName n
1721 | CaseN n <- name =
1722 'c' : translateName n
1725translateConstant :: Const -> JS
1726translateConstant (I i) = JSNum (JSInt i)
1727translateConstant (Fl f) = JSNum (JSFloat f)
1728translateConstant (Ch c) = JSString $ translateChar c
1729translateConstant (Str s) = JSString $ concatMap translateChar s
1730translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1731translateConstant StrType = JSType JSStringTy
1732translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1733translateConstant (AType ATFloat) = JSType JSFloatTy
1734translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1735translateConstant PtrType = JSType JSPtrTy
1736translateConstant Forgot = JSType JSForgotTy
1737translateConstant (BI i) = jsBigInt $ JSString (show i)
1738translateConstant (B8 b) = JSWord (JSWord8 b)
1739translateConstant (B16 b) = JSWord (JSWord16 b)
1740translateConstant (B32 b) = JSWord (JSWord32 b)
1741translateConstant (B64 b) = JSWord (JSWord64 b)
1742translateConstant c =
1743 jsError $ "Unimplemented Constant: " ++ show c
1746translateChar :: Char -> String
1747translateChar ch
1748 | '\a' <- ch = "\\u0007"
1749 | '\b' <- ch = "\\b"
1750 | '\f' <- ch = "\\f"
1751 | '\n' <- ch = "\\n"
1752 | '\r' <- ch = "\\r"
1753 | '\t' <- ch = "\\t"
1754 | '\v' <- ch = "\\v"
1755 | '\SO' <- ch = "\\u000E"
1756 | '\DEL' <- ch = "\\u007F"
1757 | '\\' <- ch = "\\\\"
1758 | '\"' <- ch = "\\\""
1759 | '\'' <- ch = "\\\'"
1760 | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
1761 | otherwise = [ch]
1762 where
1763 fill :: String -> String
1764 fill s = if length s == 1
1765 then '0' : s
1766 else s
1768 asciiTab =
1769 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
1770 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
1771 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
1772 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1775translateDeclaration :: (String, SDecl) -> [JS]
1776translateDeclaration (path, SFun name params stackSize body)
1777 | (MN _ ap) <- name
1778 , (SChkCase var cases) <- body
1779 , ap == txt "APPLY" =
1780 [ lookupTable "APPLY" [] var cases
1781 , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1782 JSTernary (
1783 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1784 (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1785 ) (JSApp
1786 (JSIndex
1787 (JSIdent (idrLTNamespace ++ "APPLY"))
1788 (JSProj (JSIdent "mfn0") "tag")
1790 [JSIdent "mfn0", JSIdent "marg0"]
1791 ) JSNull
1795 | (MN _ ev) <- name
1796 , (SChkCase var cases) <- body
1797 , ev == txt "EVAL" =
1798 [ lookupTable "EVAL" [] var cases
1799 , jsDecl $ JSFunction ["marg0"] (JSReturn $
1800 JSTernary (
1801 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1802 (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1803 ) (JSApp
1804 (JSIndex
1805 (JSIdent (idrLTNamespace ++ "EVAL"))
1806 (JSProj (JSIdent "marg0") "tag")
1808 [JSIdent "marg0"]
1809 ) (JSIdent "marg0")
1812 | otherwise =
1813 let fun = translateExpression body in
1814 [jsDecl $ jsFun fun]
1816 where
1817 hasProp :: String -> String -> JS
1818 hasProp table var =
1819 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1822 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1823 caseFun aux var cse =
1824 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1825 jsFunAux aux c
1828 getTag :: SAlt -> Maybe Int
1829 getTag (SConCase _ tag _ _ _) = Just tag
1830 getTag _ = Nothing
1833 lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1834 lookupTable table aux var cases =
1835 JSAlloc (idrLTNamespace ++ table) $ Just (
1836 JSApp (JSFunction [] (
1837 JSSeq $ [
1838 JSAlloc "t" $ Just (JSArray [])
1839 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1840 JSReturn (JSIdent "t")
1842 )) []
1844 where
1845 assignEntries :: [(Int, JS)] -> [JS]
1846 assignEntries entries =
1847 map (\(tag, fun) ->
1848 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1849 ) entries
1852 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1853 lookupEntry aux var alt = do
1854 tag <- getTag alt
1855 return (tag, caseFun aux var alt)
1858 jsDecl :: JS -> JS
1859 jsDecl = JSAlloc (path ++ translateName name) . Just
1862 jsFun body = jsFunAux [] body
1865 jsFunAux :: [(LVar, String)] -> JS -> JS
1866 jsFunAux aux body =
1867 JSFunction (p ++ map snd aux) (
1868 JSSeq $
1869 zipWith assignVar [0..] p ++
1870 map assignAux aux ++
1871 [JSReturn body]
1873 where
1874 assignVar :: Int -> String -> JS
1875 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1878 assignAux :: (LVar, String) -> JS
1879 assignAux (Loc var, val) =
1880 JSAlloc (jsVar var) (Just $ JSIdent val)
1883 p :: [String]
1884 p = map translateName params
1887translateVariableName :: LVar -> String
1888translateVariableName (Loc i) =
1889 jsVar i
1892translateExpression :: SExp -> JS
1893translateExpression (SLet name value body) =
1894 jsLet (translateVariableName name) (
1895 translateExpression value
1896 ) (translateExpression body)
1898translateExpression (SConst cst) =
1899 translateConstant cst
1901translateExpression (SV var) =
1902 JSVar var
1904translateExpression (SApp tc name vars)
1905 | False <- tc =
1906 jsTailcall $ translateFunctionCall name vars
1907 | True <- tc =
1908 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1909 JSReturn $ translateFunctionCall name vars
1910 )]
1911 where
1912 translateFunctionCall name vars =
1913 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1915translateExpression (SOp op vars)
1916 | LNoOp <- op = JSVar (last vars)
1918 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1919 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1920 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1922 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1923 | (LPlus (ATInt ITBig)) <- op
1924 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1925 | (LMinus (ATInt ITBig)) <- op
1926 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1927 | (LTimes (ATInt ITBig)) <- op
1928 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1929 | (LSDiv (ATInt ITBig)) <- op
1930 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1931 | (LSRem (ATInt ITBig)) <- op
1932 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1933 | (LEq (ATInt ITBig)) <- op
1934 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1935 | (LSLt (ATInt ITBig)) <- op
1936 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1937 | (LSLe (ATInt ITBig)) <- op
1938 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1939 | (LSGt (ATInt ITBig)) <- op
1940 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1941 | (LSGe (ATInt ITBig)) <- op
1942 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1944 | (LPlus ATFloat) <- op
1945 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1946 | (LMinus ATFloat) <- op
1947 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1948 | (LTimes ATFloat) <- op
1949 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1950 | (LSDiv ATFloat) <- op
1951 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1952 | (LEq ATFloat) <- op
1953 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1954 | (LSLt ATFloat) <- op
1955 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1956 | (LSLe ATFloat) <- op
1957 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1958 | (LSGt ATFloat) <- op
1959 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1960 | (LSGe ATFloat) <- op
1961 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1963 | (LPlus (ATInt ITChar)) <- op
1964 , (lhs:rhs:_) <- vars =
1965 jsCall "__IDRRT__fromCharCode" [
1966 JSBinOp "+" (
1967 jsCall "__IDRRT__charCode" [JSVar lhs]
1968 ) (
1969 jsCall "__IDRRT__charCode" [JSVar rhs]
1973 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
1974 , (arg:_) <- vars =
1975 jsPackUBits8 (
1976 JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFF))
1979 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
1980 , (arg:_) <- vars =
1981 jsPackUBits16 (
1982 JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFFFF))
1985 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
1986 , (arg:_) <- vars =
1987 jsPackUBits32 (
1988 jsMeth (jsMeth (JSVar arg) "and" [
1989 jsBigInt (JSString $ show 0xFFFFFFFF)
1990 ]) "intValue" []
1993 | (LTrunc ITBig (ITFixed IT64)) <- op
1994 , (arg:_) <- vars =
1995 jsMeth (JSVar arg) "and" [
1996 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1999 | (LLSHR (ITFixed IT8)) <- op
2000 , (lhs:rhs:_) <- vars =
2001 jsPackUBits8 (
2002 JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2005 | (LLSHR (ITFixed IT16)) <- op
2006 , (lhs:rhs:_) <- vars =
2007 jsPackUBits16 (
2008 JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2011 | (LLSHR (ITFixed IT32)) <- op
2012 , (lhs:rhs:_) <- vars =
2013 jsPackUBits32 (
2014 JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2017 | (LLSHR (ITFixed IT64)) <- op
2018 , (lhs:rhs:_) <- vars =
2019 jsMeth (JSVar lhs) "shiftRight" [JSVar rhs]
2021 | (LSHL (ITFixed IT8)) <- op
2022 , (lhs:rhs:_) <- vars =
2023 jsPackUBits8 (
2024 JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2027 | (LSHL (ITFixed IT16)) <- op
2028 , (lhs:rhs:_) <- vars =
2029 jsPackUBits16 (
2030 JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2033 | (LSHL (ITFixed IT32)) <- op
2034 , (lhs:rhs:_) <- vars =
2035 jsPackUBits32 (
2036 JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2039 | (LSHL (ITFixed IT64)) <- op
2040 , (lhs:rhs:_) <- vars =
2041 jsMeth (jsMeth (JSVar lhs) "shiftLeft" [JSVar rhs]) "and" [
2042 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2045 | (LAnd (ITFixed IT8)) <- op
2046 , (lhs:rhs:_) <- vars =
2047 jsPackUBits8 (
2048 JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2051 | (LAnd (ITFixed IT16)) <- op
2052 , (lhs:rhs:_) <- vars =
2053 jsPackUBits16 (
2054 JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2057 | (LAnd (ITFixed IT32)) <- op
2058 , (lhs:rhs:_) <- vars =
2059 jsPackUBits32 (
2060 JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2063 | (LAnd (ITFixed IT64)) <- op
2064 , (lhs:rhs:_) <- vars =
2065 jsMeth (JSVar lhs) "and" [JSVar rhs]
2067 | (LOr (ITFixed IT8)) <- op
2068 , (lhs:rhs:_) <- vars =
2069 jsPackUBits8 (
2070 JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2073 | (LOr (ITFixed IT16)) <- op
2074 , (lhs:rhs:_) <- vars =
2075 jsPackUBits16 (
2076 JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2079 | (LOr (ITFixed IT32)) <- op
2080 , (lhs:rhs:_) <- vars =
2081 jsPackUBits32 (
2082 JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2085 | (LOr (ITFixed IT64)) <- op
2086 , (lhs:rhs:_) <- vars =
2087 jsMeth (JSVar lhs) "or" [JSVar rhs]
2089 | (LXOr (ITFixed IT8)) <- op
2090 , (lhs:rhs:_) <- vars =
2091 jsPackUBits8 (
2092 JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2095 | (LXOr (ITFixed IT16)) <- op
2096 , (lhs:rhs:_) <- vars =
2097 jsPackUBits16 (
2098 JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2101 | (LXOr (ITFixed IT32)) <- op
2102 , (lhs:rhs:_) <- vars =
2103 jsPackUBits32 (
2104 JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2107 | (LXOr (ITFixed IT64)) <- op
2108 , (lhs:rhs:_) <- vars =
2109 jsMeth (JSVar lhs) "xor" [JSVar rhs]
2111 | (LPlus (ATInt (ITFixed IT8))) <- op
2112 , (lhs:rhs:_) <- vars =
2113 jsPackUBits8 (
2114 JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2117 | (LPlus (ATInt (ITFixed IT16))) <- op
2118 , (lhs:rhs:_) <- vars =
2119 jsPackUBits16 (
2120 JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2123 | (LPlus (ATInt (ITFixed IT32))) <- op
2124 , (lhs:rhs:_) <- vars =
2125 jsPackUBits32 (
2126 JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2129 | (LPlus (ATInt (ITFixed IT64))) <- op
2130 , (lhs:rhs:_) <- vars =
2131 jsMeth (jsMeth (JSVar lhs) "add" [JSVar rhs]) "and" [
2132 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2135 | (LMinus (ATInt (ITFixed IT8))) <- op
2136 , (lhs:rhs:_) <- vars =
2137 jsPackUBits8 (
2138 JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2141 | (LMinus (ATInt (ITFixed IT16))) <- op
2142 , (lhs:rhs:_) <- vars =
2143 jsPackUBits16 (
2144 JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2147 | (LMinus (ATInt (ITFixed IT32))) <- op
2148 , (lhs:rhs:_) <- vars =
2149 jsPackUBits32 (
2150 JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2153 | (LMinus (ATInt (ITFixed IT64))) <- op
2154 , (lhs:rhs:_) <- vars =
2155 jsMeth (jsMeth (JSVar lhs) "subtract" [JSVar rhs]) "and" [
2156 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2159 | (LTimes (ATInt (ITFixed IT8))) <- op
2160 , (lhs:rhs:_) <- vars =
2161 jsPackUBits8 (
2162 JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2165 | (LTimes (ATInt (ITFixed IT16))) <- op
2166 , (lhs:rhs:_) <- vars =
2167 jsPackUBits16 (
2168 JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2171 | (LTimes (ATInt (ITFixed IT32))) <- op
2172 , (lhs:rhs:_) <- vars =
2173 jsPackUBits32 (
2174 JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2177 | (LTimes (ATInt (ITFixed IT64))) <- op
2178 , (lhs:rhs:_) <- vars =
2179 jsMeth (jsMeth (JSVar lhs) "multiply" [JSVar rhs]) "and" [
2180 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2183 | (LEq (ATInt (ITFixed IT8))) <- op
2184 , (lhs:rhs:_) <- vars =
2185 jsPackUBits8 (
2186 JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2189 | (LEq (ATInt (ITFixed IT16))) <- op
2190 , (lhs:rhs:_) <- vars =
2191 jsPackUBits16 (
2192 JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2195 | (LEq (ATInt (ITFixed IT32))) <- op
2196 , (lhs:rhs:_) <- vars =
2197 jsPackUBits32 (
2198 JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2201 | (LEq (ATInt (ITFixed IT64))) <- op
2202 , (lhs:rhs:_) <- vars =
2203 jsMeth (jsMeth (JSVar lhs) "equals" [JSVar rhs]) "and" [
2204 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2207 | (LLt (ITFixed IT8)) <- op
2208 , (lhs:rhs:_) <- vars =
2209 jsPackUBits8 (
2210 JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2213 | (LLt (ITFixed IT16)) <- op
2214 , (lhs:rhs:_) <- vars =
2215 jsPackUBits16 (
2216 JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2219 | (LLt (ITFixed IT32)) <- op
2220 , (lhs:rhs:_) <- vars =
2221 jsPackUBits32 (
2222 JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2225 | (LLt (ITFixed IT64)) <- op
2226 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
2228 | (LLe (ITFixed IT8)) <- op
2229 , (lhs:rhs:_) <- vars =
2230 jsPackUBits8 (
2231 JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2234 | (LLe (ITFixed IT16)) <- op
2235 , (lhs:rhs:_) <- vars =
2236 jsPackUBits16 (
2237 JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2240 | (LLe (ITFixed IT32)) <- op
2241 , (lhs:rhs:_) <- vars =
2242 jsPackUBits32 (
2243 JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2246 | (LLe (ITFixed IT64)) <- op
2247 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
2249 | (LGt (ITFixed IT8)) <- op
2250 , (lhs:rhs:_) <- vars =
2251 jsPackUBits8 (
2252 JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2255 | (LGt (ITFixed IT16)) <- op
2256 , (lhs:rhs:_) <- vars =
2257 jsPackUBits16 (
2258 JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2260 | (LGt (ITFixed IT32)) <- op
2261 , (lhs:rhs:_) <- vars =
2262 jsPackUBits32 (
2263 JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2266 | (LGt (ITFixed IT64)) <- op
2267 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
2269 | (LGe (ITFixed IT8)) <- op
2270 , (lhs:rhs:_) <- vars =
2271 jsPackUBits8 (
2272 JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2275 | (LGe (ITFixed IT16)) <- op
2276 , (lhs:rhs:_) <- vars =
2277 jsPackUBits16 (
2278 JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2280 | (LGe (ITFixed IT32)) <- op
2281 , (lhs:rhs:_) <- vars =
2282 jsPackUBits32 (
2283 JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2286 | (LGe (ITFixed IT64)) <- op
2287 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
2289 | (LUDiv (ITFixed IT8)) <- op
2290 , (lhs:rhs:_) <- vars =
2291 jsPackUBits8 (
2292 JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2295 | (LUDiv (ITFixed IT16)) <- op
2296 , (lhs:rhs:_) <- vars =
2297 jsPackUBits16 (
2298 JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2301 | (LUDiv (ITFixed IT32)) <- op
2302 , (lhs:rhs:_) <- vars =
2303 jsPackUBits32 (
2304 JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2307 | (LUDiv (ITFixed IT64)) <- op
2308 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
2310 | (LSDiv (ATInt (ITFixed IT8))) <- op
2311 , (lhs:rhs:_) <- vars =
2312 jsPackSBits8 (
2313 JSBinOp "/" (
2314 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)
2315 ) (
2316 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)
2320 | (LSDiv (ATInt (ITFixed IT16))) <- op
2321 , (lhs:rhs:_) <- vars =
2322 jsPackSBits16 (
2323 JSBinOp "/" (
2324 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)
2325 ) (
2326 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)
2330 | (LSDiv (ATInt (ITFixed IT32))) <- op
2331 , (lhs:rhs:_) <- vars =
2332 jsPackSBits32 (
2333 JSBinOp "/" (
2334 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)
2335 ) (
2336 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)
2340 | (LSDiv (ATInt (ITFixed IT64))) <- op
2341 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
2343 | (LSRem (ATInt (ITFixed IT8))) <- op
2344 , (lhs:rhs:_) <- vars =
2345 jsPackSBits8 (
2346 JSBinOp "%" (
2347 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)
2348 ) (
2349 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)
2353 | (LSRem (ATInt (ITFixed IT16))) <- op
2354 , (lhs:rhs:_) <- vars =
2355 jsPackSBits16 (
2356 JSBinOp "%" (
2357 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)
2358 ) (
2359 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)
2363 | (LSRem (ATInt (ITFixed IT32))) <- op
2364 , (lhs:rhs:_) <- vars =
2365 jsPackSBits32 (
2366 JSBinOp "%" (
2367 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)
2368 ) (
2369 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)
2373 | (LSRem (ATInt (ITFixed IT64))) <- op
2374 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
2376 | (LCompl (ITFixed IT8)) <- op
2377 , (arg:_) <- vars =
2378 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
2380 | (LCompl (ITFixed IT16)) <- op
2381 , (arg:_) <- vars =
2382 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
2384 | (LCompl (ITFixed IT32)) <- op
2385 , (arg:_) <- vars =
2386 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
2388 | (LCompl (ITFixed IT64)) <- op
2389 , (arg:_) <- vars =
2390 invokeMeth arg "not" []
2392 | (LPlus _) <- op
2393 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
2394 | (LMinus _) <- op
2395 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
2396 | (LTimes _) <- op
2397 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
2398 | (LSDiv _) <- op
2399 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
2400 | (LSRem _) <- op
2401 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
2402 | (LEq _) <- op
2403 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
2404 | (LSLt _) <- op
2405 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
2406 | (LSLe _) <- op
2407 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
2408 | (LSGt _) <- op
2409 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
2410 | (LSGe _) <- op
2411 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
2412 | (LAnd _) <- op
2413 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
2414 | (LOr _) <- op
2415 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
2416 | (LXOr _) <- op
2417 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
2418 | (LSHL _) <- op
2419 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
2420 | (LASHR _) <- op
2421 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
2422 | (LCompl _) <- op
2423 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
2425 | LStrConcat <- op
2426 , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2427 | LStrEq <- op
2428 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
2429 | LStrLt <- op
2430 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
2431 | LStrLen <- op
2432 , (arg:_) <- vars = JSProj (JSVar arg) "length"
2434 | (LStrInt ITNative) <- op
2435 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
2436 | (LIntStr ITNative) <- op
2437 , (arg:_) <- vars = jsCall "String" [JSVar arg]
2438 | (LSExt ITNative ITBig) <- op
2439 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
2440 | (LTrunc ITBig ITNative) <- op
2441 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
2442 | (LIntStr ITBig) <- op
2443 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
2444 | (LStrInt ITBig) <- op
2445 , (arg:_) <- vars = jsBigInt $ JSVar arg
2446 | LFloatStr <- op
2447 , (arg:_) <- vars = jsCall "String" [JSVar arg]
2448 | LStrFloat <- op
2449 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
2450 | (LIntFloat ITNative) <- op
2451 , (arg:_) <- vars = JSVar arg
2452 | (LFloatInt ITNative) <- op
2453 , (arg:_) <- vars = JSVar arg
2454 | (LChInt ITNative) <- op
2455 , (arg:_) <- vars = jsCall "__IDRRT__charCode" [JSVar arg]
2456 | (LIntCh ITNative) <- op
2457 , (arg:_) <- vars = jsCall "__IDRRT__fromCharCode" [JSVar arg]
2459 | LFExp <- op
2460 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
2461 | LFLog <- op
2462 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
2463 | LFSin <- op
2464 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
2465 | LFCos <- op
2466 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
2467 | LFTan <- op
2468 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
2469 | LFASin <- op
2470 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
2471 | LFACos <- op
2472 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
2473 | LFATan <- op
2474 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
2475 | LFSqrt <- op
2476 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
2477 | LFFloor <- op
2478 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
2479 | LFCeil <- op
2480 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
2482 | LStrCons <- op
2483 , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2484 | LStrHead <- op
2485 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
2486 | LStrRev <- op
2487 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
2488 | LStrIndex <- op
2489 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
2490 | LStrTail <- op
2491 , (arg:_) <- vars = let v = translateVariableName arg in
2492 JSApp (JSProj (JSIdent v) "substr") [
2493 JSNum (JSInt 1),
2494 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
2496 | LNullPtr <- op
2497 , (_) <- vars = JSNull
2499 where
2500 translateBinaryOp :: String -> LVar -> LVar -> JS
2501 translateBinaryOp f lhs rhs = JSParens $ JSBinOp f (JSVar lhs) (JSVar rhs)
2504 invokeMeth :: LVar -> String -> [LVar] -> JS
2505 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
2507translateExpression (SError msg) =
2508 jsError msg
2510translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
2511 jsCall (idrRTNamespace ++ "print") [JSVar var]
2513translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
2514 JSBinOp "==" (JSVar var) JSNull
2516translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
2517 JSBinOp "==" (JSVar lhs) (JSVar rhs)
2519translateExpression (SForeign _ _ "idris_time" []) =
2520 JSRaw "(new Date()).getTime()"
2522translateExpression (SForeign _ _ fun args) =
2523 JSFFI fun (map generateWrapper args)
2524 where
2525 generateWrapper (ffunc, name)
2526 | FFunction <- ffunc =
2527 JSApp (
2528 JSIdent $ idrRTNamespace ++ "ffiWrap"
2529 ) [JSIdent $ translateVariableName name]
2530 | FFunctionIO <- ffunc =
2531 JSApp (
2532 JSIdent $ idrRTNamespace ++ "ffiWrap"
2533 ) [JSIdent $ translateVariableName name]
2535 generateWrapper (_, name) =
2536 JSIdent $ translateVariableName name
2538translateExpression patterncase
2539 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
2540 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
2541 where
2542 caseHelper var cases param =
2543 JSApp (JSFunction [param] (
2544 JSCond $ map (expandCase param . translateCaseCond param) cases
2545 )) [JSVar var]
2548 expandCase :: String -> (Cond, JS) -> (JS, JS)
2549 expandCase _ (RawCond cond, branch) = (cond, branch)
2550 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
2551 expandCase var (CaseCond caseTy, branch)
2552 | ConCase tag <- caseTy =
2553 let checkCon = JSIdent var `jsInstanceOf` jsCon
2554 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
2555 (checkCon `jsAnd` checkTag, branch)
2557 | TypeCase ty <- caseTy =
2558 let checkTy = JSIdent var `jsInstanceOf` jsType
2559 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
2560 (checkTy `jsAnd` checkTag, branch)
2562translateExpression (SCon i name vars) =
2563 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
2564 , JSArray $ map JSVar vars
2567translateExpression (SUpdate var@(Loc i) e) =
2568 JSAssign (JSVar var) (translateExpression e)
2570translateExpression (SProj var i) =
2571 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
2573translateExpression SNothing = JSNull
2575translateExpression e =
2576 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
2579data CaseType = ConCase Int
2580 | TypeCase JSType
2581 | DefaultCase
2582 deriving Eq
2585data Cond = CaseCond CaseType
2586 | RawCond JS
2589translateCaseCond :: String -> SAlt -> (Cond, JS)
2590translateCaseCond _ cse@(SDefaultCase _) =
2591 (CaseCond DefaultCase, translateCase Nothing cse)
2593translateCaseCond var cse@(SConstCase ty _)
2594 | StrType <- ty = matchHelper JSStringTy
2595 | PtrType <- ty = matchHelper JSPtrTy
2596 | Forgot <- ty = matchHelper JSForgotTy
2597 | (AType ATFloat) <- ty = matchHelper JSFloatTy
2598 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
2599 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
2600 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
2601 where
2602 matchHelper :: JSType -> (Cond, JS)
2603 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
2605translateCaseCond var cse@(SConstCase cst@(BI _) _) =
2606 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
2607 (RawCond cond, translateCase Nothing cse)
2609translateCaseCond var cse@(SConstCase cst _) =
2610 let cond = JSIdent var `jsEq` translateConstant cst in
2611 (RawCond cond, translateCase Nothing cse)
2613translateCaseCond var cse@(SConCase _ tag _ _ _) =
2614 (CaseCond $ ConCase tag, translateCase (Just var) cse)
2617translateCase :: Maybe String -> SAlt -> JS
2618translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
2619translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
2620translateCase (Just var) (SConCase a _ _ vars e) =
2621 let params = map jsVar [a .. (a + length vars)] in
2622 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
2623 JSThis, JSProj (JSIdent var) "vars"