git.iko.soy/Idris-dev
on 7fd806a help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
2085 lines 65 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 System.IO
21import System.Directory
24idrNamespace :: String
25idrNamespace = "__IDR__"
26idrRTNamespace = "__IDRRT__"
27idrLTNamespace = "__IDRLT__"
28idrCTRNamespace = "__IDRCTR__"
31data JSTarget = Node | JavaScript deriving Eq
34data JSType = JSIntTy
35 | JSStringTy
36 | JSIntegerTy
37 | JSFloatTy
38 | JSCharTy
39 | JSPtrTy
40 | JSForgotTy
41 deriving Eq
44data JSInteger = JSBigZero
45 | JSBigOne
46 | JSBigInt Integer
47 deriving Eq
50data JSNum = JSInt Int
51 | JSFloat Double
52 | JSInteger JSInteger
53 deriving Eq
56data JSAnnotation = JSConstructor deriving Eq
59instance Show JSAnnotation where
60 show JSConstructor = "constructor"
63data JS = JSRaw String
64 | JSIdent String
65 | JSFunction [String] JS
66 | JSType JSType
67 | JSSeq [JS]
68 | JSReturn JS
69 | JSApp JS [JS]
70 | JSNew String [JS]
71 | JSError String
72 | JSBinOp String JS JS
73 | JSPreOp String JS
74 | JSPostOp String JS
75 | JSProj JS String
76 | JSVar LVar
77 | JSNull
78 | JSThis
79 | JSTrue
80 | JSFalse
81 | JSArray [JS]
82 | JSString String
83 | JSNum JSNum
84 | JSAssign JS JS
85 | JSAlloc String (Maybe JS)
86 | JSIndex JS JS
87 | JSCond [(JS, JS)]
88 | JSTernary JS JS JS
89 | JSParens JS
90 | JSWhile JS JS
91 | JSFFI String [JS]
92 | JSAnnotation JSAnnotation JS
93 | JSNoop
94 deriving Eq
97data FFI = FFICode Char | FFIArg Int | FFIError String
100ffi :: String -> [String] -> String
101ffi code args = let parsed = ffiParse code in
102 case ffiError parsed of
103 Just err -> error err
104 Nothing -> renderFFI parsed args
105 where
106 ffiParse :: String -> [FFI]
107 ffiParse "" = []
108 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
109 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
110 ffiParse ('%':s:ss)
111 | isDigit s =
112 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
113 | otherwise =
114 [FFIError $ "FFI - Invalid positional argument"]
115 ffiParse (s:ss) = FFICode s : ffiParse ss
118 ffiError :: [FFI] -> Maybe String
119 ffiError [] = Nothing
120 ffiError ((FFIError s):xs) = Just s
121 ffiError (x:xs) = ffiError xs
124 renderFFI :: [FFI] -> [String] -> String
125 renderFFI [] _ = ""
126 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
127 renderFFI ((FFIArg i) : fs) args
128 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
129 | otherwise = error "FFI - Argument index out of bounds"
132compileJS :: JS -> String
133compileJS JSNoop = ""
135compileJS (JSAnnotation annotation js) =
136 "/** @" ++ show annotation ++ " */\n" ++ compileJS js
138compileJS (JSFFI raw args) =
139 ffi raw (map compileJS args)
141compileJS (JSRaw code) =
142 code
144compileJS (JSIdent ident) =
145 ident
147compileJS (JSFunction args body) =
148 "function("
149 ++ intercalate "," args
150 ++ "){\n"
151 ++ compileJS body
152 ++ "\n}"
154compileJS (JSType ty)
155 | JSIntTy <- ty = idrRTNamespace ++ "Int"
156 | JSStringTy <- ty = idrRTNamespace ++ "String"
157 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
158 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
159 | JSCharTy <- ty = idrRTNamespace ++ "Char"
160 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
161 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
163compileJS (JSSeq seq) =
164 intercalate ";\n" (map compileJS seq)
166compileJS (JSReturn val) =
167 "return " ++ compileJS val
169compileJS (JSApp lhs rhs)
170 | JSFunction {} <- lhs =
171 concat ["(", compileJS lhs, ")(", args, ")"]
172 | otherwise =
173 concat [compileJS lhs, "(", args, ")"]
174 where args :: String
175 args = intercalate "," $ map compileJS rhs
177compileJS (JSNew name args) =
178 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
180compileJS (JSError exc) =
181 "throw new Error(\"" ++ exc ++ "\")"
183compileJS (JSBinOp op lhs rhs) =
184 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
186compileJS (JSPreOp op val) =
187 op ++ compileJS val
189compileJS (JSProj obj field)
190 | JSFunction {} <- obj =
191 concat ["(", compileJS obj, ").", field]
192 | JSAssign {} <- obj =
193 concat ["(", compileJS obj, ").", field]
194 | otherwise =
195 compileJS obj ++ '.' : field
197compileJS (JSVar var) =
198 translateVariableName var
200compileJS JSNull =
201 "null"
203compileJS JSThis =
204 "this"
206compileJS JSTrue =
207 "true"
209compileJS JSFalse =
210 "false"
212compileJS (JSArray elems) =
213 "[" ++ intercalate "," (map compileJS elems) ++ "]"
215compileJS (JSString str) =
216 "\"" ++ str ++ "\""
218compileJS (JSNum num)
219 | JSInt i <- num = show i
220 | JSFloat f <- num = show f
221 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
222 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
223 | JSInteger (JSBigInt i) <- num = show i
225compileJS (JSAssign lhs rhs) =
226 compileJS lhs ++ "=" ++ compileJS rhs
228compileJS (JSAlloc name val) =
229 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
231compileJS (JSIndex lhs rhs) =
232 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
234compileJS (JSCond branches) =
235 intercalate " else " $ map createIfBlock branches
236 where
237 createIfBlock (JSNoop, e) =
238 "{\n"
239 ++ compileJS e
240 ++ ";\n}"
241 createIfBlock (cond, e) =
242 "if (" ++ compileJS cond ++") {\n"
243 ++ compileJS e
244 ++ ";\n}"
246compileJS (JSTernary cond true false) =
247 let c = compileJS cond
248 t = compileJS true
249 f = compileJS false in
250 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
252compileJS (JSParens js) =
253 "(" ++ compileJS js ++ ")"
255compileJS (JSWhile cond body) =
256 "while (" ++ compileJS cond ++ ") {\n"
257 ++ compileJS body
258 ++ "\n}"
260jsTailcall :: JS -> JS
261jsTailcall call =
262 jsCall (idrRTNamespace ++ "tailcall") [
263 JSFunction [] (JSReturn call)
264 ]
267jsCall :: String -> [JS] -> JS
268jsCall fun = JSApp (JSIdent fun)
271jsMeth :: JS -> String -> [JS] -> JS
272jsMeth obj meth =
273 JSApp (JSProj obj meth)
276jsInstanceOf :: JS -> JS -> JS
277jsInstanceOf = JSBinOp "instanceof"
280jsEq :: JS -> JS -> JS
281jsEq = JSBinOp "=="
284jsAnd :: JS -> JS -> JS
285jsAnd = JSBinOp "&&"
288jsOr :: JS -> JS -> JS
289jsOr = JSBinOp "||"
292jsType :: JS
293jsType = JSIdent $ idrRTNamespace ++ "Type"
296jsCon :: JS
297jsCon = JSIdent $ idrRTNamespace ++ "Con"
300jsTag :: JS -> JS
301jsTag obj = JSProj obj "tag"
304jsTypeTag :: JS -> JS
305jsTypeTag obj = JSProj obj "type"
308jsBigInt :: JS -> JS
309jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
310jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
311jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
314jsVar :: Int -> String
315jsVar = ("__var_" ++) . show
318jsLet :: String -> JS -> JS -> JS
319jsLet name value body =
320 JSApp (
321 JSFunction [name] (
322 JSReturn body
323 )
324 ) [value]
327jsError :: String -> JS
328jsError err = JSApp (JSFunction [] (JSError err)) []
331foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
332foldJS tr add acc js =
333 fold js
334 where
335 fold js
336 | JSFunction args body <- js =
337 add (tr js) (fold body)
338 | JSSeq seq <- js =
339 add (tr js) $ foldl' add acc (map fold seq)
340 | JSReturn ret <- js =
341 add (tr js) (fold ret)
342 | JSApp lhs rhs <- js =
343 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
344 | JSNew _ args <- js =
345 add (tr js) $ foldl' add acc $ map fold args
346 | JSBinOp _ lhs rhs <- js =
347 add (tr js) $ add (fold lhs) (fold rhs)
348 | JSPreOp _ val <- js =
349 add (tr js) $ fold val
350 | JSPostOp _ val <- js =
351 add (tr js) $ fold val
352 | JSProj obj _ <- js =
353 add (tr js) (fold obj)
354 | JSArray vals <- js =
355 add (tr js) $ foldl' add acc $ map fold vals
356 | JSAssign lhs rhs <- js =
357 add (tr js) $ add (fold lhs) (fold rhs)
358 | JSIndex lhs rhs <- js =
359 add (tr js) $ add (fold lhs) (fold rhs)
360 | JSAlloc _ val <- js =
361 add (tr js) $ fromMaybe acc $ fmap fold val
362 | JSTernary c t f <- js =
363 add (tr js) $ add (fold c) (add (fold t) (fold f))
364 | JSParens val <- js =
365 add (tr js) $ fold val
366 | JSCond conds <- js =
367 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
368 | JSWhile cond body <- js =
369 add (tr js) $ add (fold cond) (fold body)
370 | JSFFI raw args <- js =
371 add (tr js) $ foldl' add acc $ map fold args
372 | JSAnnotation a js <- js =
373 add (tr js) $ fold js
374 | otherwise =
375 tr js
378transformJS :: (JS -> JS) -> JS -> JS
379transformJS tr js =
380 transformHelper js
381 where
382 transformHelper :: JS -> JS
383 transformHelper js
384 | JSFunction args body <- js = JSFunction args $ tr body
385 | JSSeq seq <- js = JSSeq $ map tr seq
386 | JSReturn ret <- js = JSReturn $ tr ret
387 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
388 | JSNew con args <- js = JSNew con $ map tr args
389 | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
390 | JSPreOp op val <- js = JSPreOp op (tr val)
391 | JSPostOp op val <- js = JSPostOp op (tr val)
392 | JSProj obj field <- js = JSProj (tr obj) field
393 | JSArray vals <- js = JSArray $ map tr vals
394 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
395 | JSAlloc var val <- js = JSAlloc var $ fmap tr val
396 | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
397 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
398 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
399 | JSParens val <- js = JSParens $ tr val
400 | JSWhile cond body <- js = JSWhile (tr cond) (tr body)
401 | JSFFI raw args <- js = JSFFI raw (map tr args)
402 | JSAnnotation a js <- js = JSAnnotation a (tr js)
403 | otherwise = js
406moveJSDeclToTop :: String -> [JS] -> [JS]
407moveJSDeclToTop decl js = move ([], js)
408 where
409 move :: ([JS], [JS]) -> [JS]
410 move (front, js@(JSAnnotation _ (JSAlloc name _)):back)
411 | name == decl = js : front ++ back
413 move (front, js@(JSAlloc name _):back)
414 | name == decl = js : front ++ back
416 move (front, js:back) =
417 move (front ++ [js], back)
420jsSubst :: JS -> JS -> JS -> JS
421jsSubst var new old
422 | var == old = new
424jsSubst (JSIdent var) new (JSVar old)
425 | var == translateVariableName old = new
426 | otherwise = JSVar old
428jsSubst var new old@(JSIdent _)
429 | var == old = new
430 | otherwise = old
432jsSubst var new (JSArray fields) =
433 JSArray (map (jsSubst var new) fields)
435jsSubst var new (JSNew con vals) =
436 JSNew con $ map (jsSubst var new) vals
438jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
439 | var `notElem` args =
440 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
441 map (jsSubst (JSIdent var) new) vals
442 )
443 | otherwise =
444 JSApp (JSProj (JSFunction args body) "apply") (
445 map (jsSubst (JSIdent var) new) vals
446 )
448jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
449 | var /= arg =
450 JSApp (JSFunction [arg] (
451 jsSubst (JSIdent var) new body
452 )) $ map (jsSubst (JSIdent var) new) vals
453 | otherwise =
454 JSApp (JSFunction [arg] (
455 body
456 )) $ map (jsSubst (JSIdent var) new) vals
458jsSubst var new js = transformJS (jsSubst var new) js
461removeAllocations :: JS -> JS
462removeAllocations (JSSeq body) =
463 let opt = removeHelper (map removeAllocations body) in
464 case opt of
465 [ret] -> ret
466 _ -> JSSeq opt
467 where
468 removeHelper :: [JS] -> [JS]
469 removeHelper [js] = [js]
470 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
471 map (jsSubst (JSIdent name) val) (removeHelper js)
472 removeHelper (j:js) = j : removeHelper js
474removeAllocations js = transformJS removeAllocations js
477isJSConstant :: JS -> Bool
478isJSConstant js
479 | JSString _ <- js = True
480 | JSNum _ <- js = True
481 | JSType _ <- js = True
482 | JSNull <- js = True
483 | JSArray vals <- js = all isJSConstant vals
485 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
487 | otherwise = False
489isJSConstantConstructor :: [String] -> JS -> Bool
490isJSConstantConstructor constants js
491 | isJSConstant js =
492 True
493 | JSArray vals <- js =
494 all (isJSConstantConstructor constants) vals
495 | JSNew "__IDRRT__Con" args <- js =
496 all (isJSConstantConstructor constants) args
497 | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js
498 , name `elem` constants =
499 True
500 | JSIdent name <- js
501 , name `elem` constants =
502 True
503 | otherwise = False
506inlineJS :: JS -> JS
507inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
508 where
509 inlineJSLet :: JS -> JS
510 inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])
511 | opt <- inlineJSLet val =
512 inlineJS $ jsSubst (JSIdent arg) opt ret
514 inlineJSLet js = transformJS inlineJSLet js
517 inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
518 | opt <- inlineCaseMatch val =
519 inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
521 inlineCaseMatch js = transformJS inlineCaseMatch js
524 inlineApply js
525 | JSApp (
526 JSProj (JSFunction args (JSReturn body)) "apply"
527 ) [JSThis, JSProj var "vars"] <- js =
528 inlineApply $ inlineApply' var args body 0
529 | JSReturn (JSApp (
530 JSProj (JSFunction args body@(JSCond _)) "apply"
531 ) [JSThis, JSProj var "vars"]) <- js =
532 inlineApply $ inlineApply' var args body 0
533 where
534 inlineApply' _ [] body _ = body
535 inlineApply' var (a:as) body n =
536 inlineApply' var as (
537 jsSubst (JSIdent a) (
538 JSIndex (JSProj var "vars") (JSNum (JSInt n))
539 ) body
540 ) (n + 1)
542 inlineApply js = transformJS inlineApply js
545 inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
546 inlineError error
548 inlineError js = transformJS inlineError js
551 inlineAssign (JSAssign lhs rhs)
552 | JSVar _ <- lhs
553 , JSVar _ <- rhs
554 , lhs == rhs =
555 lhs
557 inlineAssign (JSAssign lhs rhs)
558 | JSIdent _ <- lhs
559 , JSIdent _ <- rhs
560 , lhs == rhs =
561 lhs
563 inlineAssign js = transformJS inlineAssign js
566removeEval :: [JS] -> [JS]
567removeEval js =
568 let (ret, isReduced) = checkEval js in
569 if isReduced
570 then removeEvalApp ret
571 else ret
572 where
573 removeEvalApp js = catMaybes (map removeEvalApp' js)
574 where
575 removeEvalApp' :: JS -> Maybe JS
576 removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
577 removeEvalApp' js = Just $ transformJS match js
578 where
579 match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val
580 match js = transformJS match js
582 checkEval :: [JS] -> ([JS], Bool)
583 checkEval js = foldr f ([], False) $ map checkEval' js
584 where
585 f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)
586 f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)
587 f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)
590 checkEval' :: JS -> (Maybe JS, Bool)
591 checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
592 JSSeq [ _
593 , JSReturn (JSIdent "t")
594 ]
595 )) []))) = (Nothing, True)
597 checkEval' js = (Just js, False)
600reduceJS :: [JS] -> [JS]
601reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
604funName :: JS -> String
605funName (JSAlloc fun _) = fun
608elimDeadLoop :: [JS] -> [JS]
609elimDeadLoop js
610 | ret <- deadEvalApplyCases js
611 , ret /= js = elimDeadLoop ret
612 | otherwise = js
615deadEvalApplyCases :: [JS] -> [JS]
616deadEvalApplyCases js =
617 let tags = sort $ nub $ concatMap (getTags) js in
618 map (removeHelper tags) js
619 where
620 getTags :: JS -> [Int]
621 getTags = foldJS match (++) []
622 where
623 match js
624 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
625 | otherwise = []
628 removeHelper :: [Int] -> JS -> JS
629 removeHelper tags (JSAlloc fun (Just (
630 JSApp (JSFunction [] (JSSeq seq)) []))
631 ) =
632 (JSAlloc fun (Just (
633 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
634 )
636 removeHelper _ js = js
639 remover :: [Int] -> [JS] -> [JS]
640 remover tags (
641 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
642 )
643 | tag `notElem` tags = remover tags js
645 remover tags (j:js) = j : remover tags js
646 remover _ [] = []
649initConstructors :: [JS] -> [JS]
650initConstructors js =
651 let tags = nub $ sort $ concat (map getTags js) in
652 rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
653 where
654 rearrangePrelude :: [JS] -> [JS]
655 rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
658 getTags :: JS -> [Int]
659 getTags = foldJS match (++) []
660 where
661 match js
662 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
663 | otherwise = []
666 replaceConstructors :: [Int] -> [JS] -> [JS]
667 replaceConstructors tags js = map (replaceHelper tags) js
668 where
669 replaceHelper :: [Int] -> JS -> JS
670 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
671 | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
673 replaceHelper tags js = transformJS (replaceHelper tags) js
676 createConstant :: Int -> JS
677 createConstant tag =
678 JSAlloc (idrCTRNamespace ++ show tag) (Just (
679 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
680 ))
683removeIDs :: [JS] -> [JS]
684removeIDs js =
685 case partition isID js of
686 ([], rest) -> rest
687 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
688 where isID :: JS -> Bool
689 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
690 | JSReturn (JSVar _) <- last body = True
692 isID _ = False
695 idFor :: JS -> (String, Int)
696 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
697 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
700 removeIDCall :: [(String, Int)] -> JS -> JS
701 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
702 JSReturn (JSApp (JSIdent fun) args)
703 )])
704 | Just pos <- lookup fun ids
705 , pos < length args = args !! pos
707 removeIDCall ids (JSNew _ [JSFunction [] (
708 JSReturn (JSApp (JSIdent fun) args)
709 )])
710 | Just pos <- lookup fun ids
711 , pos < length args = args !! pos
713 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
714 | Just pos <- lookup fun ids
715 , pos < length args = args !! pos
717 removeIDCall ids js = transformJS (removeIDCall ids) js
720inlineFunctions :: [JS] -> [JS]
721inlineFunctions js =
722 inlineHelper ([], js)
723 where
724 inlineHelper :: ([JS], [JS]) -> [JS]
725 inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
726 | countAll fun front + countAll fun back == 0 =
727 inlineHelper (front, back)
728 | Just new <- inlineAble (
729 countAll fun front + countAll fun back
730 ) fun args body =
731 let f = map (inline fun args new) in
732 inlineHelper (f front, f back)
734 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
735 inlineHelper (front, []) = front
738 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
739 inlineAble 1 fun args (JSReturn body)
740 | nonRecur fun body =
741 if all (<= 1) (map ($ body) (map countIDOccurences args))
742 then Just body
743 else Nothing
745 inlineAble _ _ _ _ = Nothing
748 inline :: String -> [String] -> JS -> JS -> JS
749 inline fun args body js = inline' js
750 where
751 inline' :: JS -> JS
752 inline' (JSApp (JSIdent name) vals)
753 | name == fun =
754 let (js, phs) = insertPlaceHolders args body in
755 inline' $ foldr (uncurry jsSubst) js (zip phs vals)
757 inline' js = transformJS inline' js
759 insertPlaceHolders :: [String] -> JS -> (JS, [JS])
760 insertPlaceHolders args body = insertPlaceHolders' args body []
761 where
762 insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
763 insertPlaceHolders' (a:as) body ph
764 | (body', ph') <- insertPlaceHolders' as body ph =
765 let phvar = JSIdent $ "__PH_" ++ show (length ph') in
766 (jsSubst (JSIdent a) phvar body', phvar : ph')
768 insertPlaceHolders' [] body ph = (body, ph)
771 nonRecur :: String -> JS -> Bool
772 nonRecur name body = countInvokations name body == 0
775 countAll :: String -> [JS] -> Int
776 countAll name js = sum $ map (countInvokations name) js
779 countIDOccurences :: String -> JS -> Int
780 countIDOccurences name = foldJS match (+) 0
781 where
782 match :: JS -> Int
783 match js
784 | JSIdent ident <- js
785 , name == ident = 1
786 | otherwise = 0
789 countInvokations :: String -> JS -> Int
790 countInvokations name = foldJS match (+) 0
791 where
792 match :: JS -> Int
793 match js
794 | JSApp (JSIdent ident) _ <- js
795 , name == ident = 1
796 | JSNew con _ <- js
797 , name == con = 1
798 | otherwise = 0
801reduceContinuations :: JS -> JS
802reduceContinuations = inlineTC . reduceJS
803 where
804 reduceJS :: JS -> JS
805 reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
806 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
807 )]) = reduceJS js
809 reduceJS js = transformJS reduceJS js
812 inlineTC :: JS -> JS
813 inlineTC js
814 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
815 JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
816 JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
817 JSReturn (JSNew "__IDRRT__Cont" _)
818 )])
819 )])
820 )] <- js = inlineTC ret
822 inlineTC js = transformJS inlineTC js
827reduceConstant :: JS -> JS
828reduceConstant
829 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
830 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
831 )])
832 | JSNum num <- val = val
833 | JSBinOp op lhs rhs <- val =
834 JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
836 | JSApp (JSProj lhs op) [rhs] <- val
837 , op `elem` [ "subtract"
838 , "add"
839 , "multiply"
840 , "divide"
841 , "mod"
842 , "equals"
843 , "lesser"
844 , "lesserOrEquals"
845 , "greater"
846 , "greaterOrEquals"
847 ] = val
849reduceConstant (JSApp ident [(JSParens js)]) =
850 JSApp ident [reduceConstant js]
852reduceConstant js = transformJS reduceConstant js
855reduceConstants :: JS -> JS
856reduceConstants js
857 | ret <- reduceConstant js
858 , ret /= js = reduceConstants ret
859 | otherwise = js
862elimDuplicateEvals :: JS -> JS
863elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
864 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
865 where
866 elimHelper :: [JS] -> [JS]
867 elimHelper (j@(JSAlloc var (Just val)):js) =
868 j : map (jsSubst val (JSIdent var)) (elimHelper js)
869 elimHelper (j:js) =
870 j : elimHelper js
871 elimHelper [] = []
873elimDuplicateEvals js = js
876optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
877optimizeRuntimeCalls fun tc js =
878 optTC tc : map optHelper js
879 where
880 optHelper :: JS -> JS
881 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
882 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
883 ])
884 | n == fun = JSApp (JSIdent tc) $ map optHelper args
886 optHelper js = transformJS optHelper js
889 optTC :: String -> JS
890 optTC tc@"__IDRRT__EVALTC" =
891 JSAlloc tc (Just $ JSFunction ["arg0"] (
892 JSSeq [ JSAlloc "ret" $ Just (
893 JSTernary (
894 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
895 (hasProp "__IDRLT__EVAL" "arg0")
896 ) (JSApp
897 (JSIndex
898 (JSIdent "__IDRLT__EVAL")
899 (JSProj (JSIdent "arg0") "tag")
900 )
901 [JSIdent "arg0"]
902 ) (JSIdent "arg0")
903 )
904 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
905 JSAssign (JSIdent "ret") (
906 JSApp (JSProj (JSIdent "ret") "k") []
907 )
908 )
909 , JSReturn $ JSIdent "ret"
910 ]
911 ))
913 optTC tc@"__IDRRT__APPLYTC" =
914 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
915 JSSeq [ JSAlloc "ret" $ Just (
916 JSTernary (
917 (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
918 (hasProp "__IDRLT__APPLY" "fn0")
919 ) (JSApp
920 (JSIndex
921 (JSIdent "__IDRLT__APPLY")
922 (JSProj (JSIdent "fn0") "tag")
923 )
924 [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
925 ) JSNull
926 )
927 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
928 JSAssign (JSIdent "ret") (
929 JSApp (JSProj (JSIdent "ret") "k") []
930 )
931 )
932 , JSReturn $ JSIdent "ret"
933 ]
934 ))
937 hasProp :: String -> String -> JS
938 hasProp table var =
939 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
942unfoldLookupTable :: [JS] -> [JS]
943unfoldLookupTable input =
944 let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
945 (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
946 js = applyunfold in
947 adaptRuntime $ expandCons evals applys js
948 where
949 adaptRuntime :: [JS] -> [JS]
950 adaptRuntime =
951 adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
954 adaptApply :: [JS] -> [JS]
955 adaptApply js = adaptApply' [] js
956 where
957 adaptApply' :: [JS] -> [JS] -> [JS]
958 adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
959 front ++ (new:back)
961 adaptApply' front (next:back) =
962 adaptApply' (front ++ [next]) back
964 adaptApply' front [] = front
966 new =
967 JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
968 JSTernary (
969 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
970 (JSProj (JSIdent "mfn0") "app")
971 ) (JSApp
972 (JSProj (JSIdent "mfn0") "app")
973 [JSIdent "mfn0", JSIdent "marg0"]
974 ) JSNull
975 )
976 )
979 adaptApplyTC :: [JS] -> [JS]
980 adaptApplyTC js = adaptApplyTC' [] js
981 where
982 adaptApplyTC' :: [JS] -> [JS] -> [JS]
983 adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =
984 front ++ (new:back)
986 adaptApplyTC' front (next:back) =
987 adaptApplyTC' (front ++ [next]) back
989 adaptApplyTC' front [] = front
991 new =
992 JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
993 JSSeq [ JSAlloc "ret" $ Just (
994 JSTernary (
995 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
996 (JSProj (JSIdent "mfn0") "app")
997 ) (JSApp
998 (JSProj (JSIdent "mfn0") "app")
999 [JSIdent "mfn0", JSIdent "marg0"]
1000 ) JSNull
1002 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1003 JSAssign (JSIdent "ret") (
1004 JSApp (JSProj (JSIdent "ret") "k") []
1007 , JSReturn $ JSIdent "ret"
1009 ))
1012 adaptEval :: [JS] -> [JS]
1013 adaptEval js = adaptEval' [] js
1014 where
1015 adaptEval' :: [JS] -> [JS] -> [JS]
1016 adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =
1017 front ++ (new:back)
1019 adaptEval' front (next:back) =
1020 adaptEval' (front ++ [next]) back
1022 adaptEval' front [] = front
1024 new =
1025 JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
1026 JSTernary (
1027 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1028 (JSProj (JSIdent "marg0") "eval")
1029 ) (JSApp
1030 (JSProj (JSIdent "marg0") "eval")
1031 [JSIdent "marg0"]
1032 ) (JSIdent "marg0")
1037 adaptEvalTC :: [JS] -> [JS]
1038 adaptEvalTC js = adaptEvalTC' [] js
1039 where
1040 adaptEvalTC' :: [JS] -> [JS] -> [JS]
1041 adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =
1042 front ++ (new:back)
1044 adaptEvalTC' front (next:back) =
1045 adaptEvalTC' (front ++ [next]) back
1047 adaptEvalTC' front [] = front
1049 new =
1050 JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
1051 JSSeq [ JSAlloc "ret" $ Just (
1052 JSTernary (
1053 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1054 (JSProj (JSIdent "marg0") "eval")
1055 ) (JSApp
1056 (JSProj (JSIdent "marg0") "eval")
1057 [JSIdent "marg0"]
1058 ) (JSIdent "marg0")
1060 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1061 JSAssign (JSIdent "ret") (
1062 JSApp (JSProj (JSIdent "ret") "k") []
1065 , JSReturn $ JSIdent "ret"
1067 ))
1070 adaptCon js =
1071 adaptCon' [] js
1072 where
1073 adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =
1074 front ++ (new:back)
1076 adaptCon' front (next:back) =
1077 adaptCon' (front ++ [next]) back
1079 adaptCon' front [] = front
1082 new =
1083 JSAnnotation JSConstructor $
1084 JSAlloc "__IDRRT__Con" (Just $
1085 JSFunction newArgs (
1086 JSSeq (map newVar newArgs)
1089 where
1090 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1091 newArgs = ["tag", "eval", "app", "vars"]
1094 unfoldLT :: String -> [JS] -> ([Int], [JS])
1095 unfoldLT lt js =
1096 let (table, code) = extractLT lt js
1097 expanded = expandLT lt table in
1098 (map fst expanded, map snd expanded ++ code)
1101 expandCons :: [Int] -> [Int] -> [JS] -> [JS]
1102 expandCons evals applys js =
1103 map expandCons' js
1104 where
1105 expandCons' :: JS -> JS
1106 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
1107 | evalid <- getId "__IDRLT__EVAL" tag evals
1108 , applyid <- getId "__IDRLT__APPLY" tag applys =
1109 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
1110 , maybe JSNull JSIdent evalid
1111 , maybe JSNull JSIdent applyid
1112 , JSArray (map expandCons' args)
1115 expandCons' js = transformJS expandCons' js
1118 getId :: String -> Int -> [Int] -> Maybe String
1119 getId lt tag entries
1120 | tag `elem` entries = Just $ ltIdentifier lt tag
1121 | otherwise = Nothing
1124 ltIdentifier :: String -> Int -> String
1125 ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
1126 ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
1129 extractLT :: String -> [JS] -> (JS, [JS])
1130 extractLT lt js =
1131 extractLT' ([], js)
1132 where
1133 extractLT' :: ([JS], [JS]) -> (JS, [JS])
1134 extractLT' (front, js@(JSAlloc fun _):back)
1135 | fun == lt = (js, front ++ back)
1137 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
1138 extractLT' (front, back) = (JSNoop, front ++ back)
1141 expandLT :: String -> JS -> [(Int, JS)]
1142 expandLT lt (
1143 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
1144 ) = catMaybes (map expandEntry seq)
1145 where
1146 expandEntry :: JS -> Maybe (Int, JS)
1147 expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
1148 Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
1150 expandEntry js = Nothing
1152 expandLT lt JSNoop = []
1155removeInstanceChecks :: JS -> JS
1156removeInstanceChecks (JSCond conds) =
1157 removeNoopConds $ JSCond $ eliminateDeadBranches $ map (
1158 removeHelper *** removeInstanceChecks
1159 ) conds
1160 where
1161 removeHelper (
1162 JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
1163 ) = removeHelper check
1164 removeHelper js = js
1167 eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]
1168 eliminateDeadBranches [(_, js)] = [(JSNoop, js)]
1169 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
1170 eliminateDeadBranches [] = []
1173 removeNoopConds :: JS -> JS
1174 removeNoopConds (JSCond [(JSNoop, js)]) = js
1175 removeNoopConds js = js
1177removeInstanceChecks js = transformJS removeInstanceChecks js
1180reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
1181reduceLoop reduced (cons, program) =
1182 case partition findConstructors program of
1183 ([], js) -> cons ++ js
1184 (candidates, rest) ->
1185 let names = reduced ++ map funName candidates in
1186 reduceLoop names (
1187 cons ++ map reduce candidates, map (reduceCall names) rest
1189 where findConstructors :: JS -> Bool
1190 findConstructors js
1191 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
1192 reducable $ last body
1193 | otherwise = False
1194 where reducable :: JS -> Bool
1195 reducable js
1196 | JSReturn ret <- js = reducable ret
1197 | JSNew _ args <- js = and $ map reducable args
1198 | JSArray fields <- js = and $ map reducable fields
1199 | JSNum _ <- js = True
1200 | JSNull <- js = True
1201 | JSIdent _ <- js = True
1202 | otherwise = False
1205 reduce :: JS -> JS
1206 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1207 | JSReturn js <- last body = (JSAlloc fun (Just js))
1209 reduce js = js
1212 reduceCall :: [String] -> JS -> JS
1213 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1214 JSReturn (JSApp id@(JSIdent ret) _)
1215 )])
1216 | ret `elem` funs = id
1218 reduceCall funs js@(JSApp id@(JSIdent fun) _)
1219 | fun `elem` funs = id
1221 reduceCall funs js = transformJS (reduceCall funs) js
1224extractLocalConstructors :: [JS] -> [JS]
1225extractLocalConstructors js =
1226 concatMap extractLocalConstructors' js
1227 where
1228 globalCons :: [String]
1229 globalCons = concatMap (getGlobalCons) js
1232 extractLocalConstructors' :: JS -> [JS]
1233 extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1234 addCons cons [foldr (uncurry jsSubst) js (reverse cons)]
1235 where
1236 cons :: [(JS, JS)]
1237 cons = zipWith genName (foldJS match (++) [] body) [1..]
1238 where
1239 genName :: JS -> Int -> (JS, JS)
1240 genName js id =
1241 (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1243 match :: JS -> [JS]
1244 match js
1245 | JSNew "__IDRRT__Con" args <- js
1246 , all isConstant args = [js]
1247 | otherwise = []
1250 addCons :: [(JS, JS)] -> [JS] -> [JS]
1251 addCons [] js = js
1252 addCons (con@(_, name):cons) js
1253 | sum (map (countOccur name) js) > 0 =
1254 addCons cons ((allocCon con) : js)
1255 | otherwise =
1256 addCons cons js
1259 countOccur :: JS -> JS -> Int
1260 countOccur ident js = foldJS match (+) 0 js
1261 where
1262 match :: JS -> Int
1263 match js
1264 | js == ident = 1
1265 | otherwise = 0
1268 allocCon :: (JS, JS) -> JS
1269 allocCon (js, JSIdent name) =
1270 JSAlloc name (Just js)
1273 isConstant :: JS -> Bool
1274 isConstant js
1275 | JSNew "__IDRRT__Con" args <- js
1276 , all isConstant args =
1277 True
1278 | otherwise =
1279 isJSConstantConstructor globalCons js
1281 extractLocalConstructors' js = [js]
1284 getGlobalCons :: JS -> [String]
1285 getGlobalCons js = foldJS match (++) [] js
1286 where
1287 match :: JS -> [String]
1288 match js
1289 | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1290 [name]
1291 | otherwise =
1292 []
1295evalCons :: [JS] -> [JS]
1296evalCons js =
1297 map (collapseCont . collapseTC . expandProj . evalCons') js
1298 where
1299 cons :: [(String, JS)]
1300 cons = concatMap getGlobalCons js
1302 evalCons' :: JS -> JS
1303 evalCons' js = transformJS match js
1304 where
1305 match :: JS -> JS
1306 match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1307 | JSIdent name <- arg
1308 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1309 arg
1311 match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1312 | JSIdent name <- arg
1313 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1314 arg
1316 match js = transformJS match js
1319 lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1320 lookupConstructor ctr cons
1321 | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1322 | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1323 | otherwise = Nothing
1326 expandProj :: JS -> JS
1327 expandProj js = transformJS match js
1328 where
1329 match :: JS -> JS
1330 match (
1331 JSIndex (
1332 JSProj (JSIdent name) "vars"
1333 ) (
1334 JSNum (JSInt idx)
1337 | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1338 args !! idx
1340 match js = transformJS match js
1343 collapseTC :: JS -> JS
1344 collapseTC js = transformJS match js
1345 where
1346 match :: JS -> JS
1347 match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1348 JSReturn (JSIdent name)
1349 )])
1350 | Just _ <- lookup name cons = (JSIdent name)
1352 match js = transformJS match js
1355 collapseCont :: JS -> JS
1356 collapseCont js = transformJS match js
1357 where
1358 match :: JS -> JS
1359 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1360 JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1361 )]) = collapseCont ret
1364 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1365 JSReturn (JSIdent name)
1366 )]) = JSIdent name
1368 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1369 JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1370 )])
1371 | all collapsable args = ret
1372 where
1373 collapsable :: JS -> Bool
1374 collapsable (JSIdent _) = True
1375 collapsable js = isJSConstantConstructor (map fst cons) js
1378 match js = transformJS match js
1381getGlobalCons :: JS -> [(String, JS)]
1382getGlobalCons js = foldJS match (++) [] js
1383 where
1384 match :: JS -> [(String, JS)]
1385 match js
1386 | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1387 [(name, con)]
1388 | (JSAlloc name (Just con@(JSIdent _))) <- js =
1389 [(name, con)]
1390 | otherwise =
1391 []
1394getIncludes :: [FilePath] -> IO [String]
1395getIncludes = mapM readFile
1397codegenJavaScript :: CodeGenerator
1398codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
1399 (includes ci) (outputFile ci) (outputType ci)
1401codegenNode :: CodeGenerator
1402codegenNode ci = codegenJS_all Node (simpleDecls ci)
1403 (includes ci) (outputFile ci) (outputType ci)
1405codegenJS_all
1406 :: JSTarget
1407 -> [(Name, SDecl)]
1408 -> [FilePath]
1409 -> FilePath
1410 -> OutputType
1411 -> IO ()
1412codegenJS_all target definitions includes filename outputType = do
1413 let (header, rt) = case target of
1414 Node ->
1415 ("#!/usr/bin/env node\n", "-node")
1416 JavaScript ->
1417 ("", "-browser")
1418 included <- getIncludes includes
1419 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1420 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1421 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
1422 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1423 writeFile filename $ header ++ (
1424 intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions
1427 setPermissions filename (emptyPermissions { readable = True
1428 , executable = target == Node
1429 , writable = True
1430 })
1431 where
1432 def :: [(String, SDecl)]
1433 def = map (first translateNamespace) definitions
1436 checkForBigInt :: [JS] -> Bool
1437 checkForBigInt js = occur
1438 where
1439 occur :: Bool
1440 occur = or $ map (foldJS match (||) False) js
1442 match :: JS -> Bool
1443 match (JSIdent "__IDRRT__bigInt") = True
1444 match (JSNum (JSInteger _)) = True
1445 match js = False
1448 runtime :: String -> String -> String -> [String]
1449 runtime jsbn idrRuntime tgtRuntime =
1450 if checkForBigInt optimized
1451 then [jsbn, idrRuntime, tgtRuntime]
1452 else [idrRuntime, tgtRuntime]
1455 optimized :: [JS]
1456 optimized = translate >>> optimize $ def
1457 where
1458 translate p =
1459 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1460 optimize p =
1461 foldl' (flip ($)) p opt
1463 opt =
1464 [ removeEval
1465 , map inlineJS
1466 , removeIDs
1467 , reduceJS
1468 , map reduceConstants
1469 , initConstructors
1470 , map removeAllocations
1471 , elimDeadLoop
1472 , map elimDuplicateEvals
1473 , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1474 , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1475 , map removeInstanceChecks
1476 , inlineFunctions
1477 , map reduceContinuations
1478 , extractLocalConstructors
1479 , unfoldLookupTable
1480 , evalCons
1483 functions :: [String]
1484 functions = map compileJS optimized
1486 prelude :: [JS]
1487 prelude =
1488 [ JSAnnotation JSConstructor $
1489 JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1490 JSAssign (JSProj JSThis "k") (JSIdent "k")
1491 ))
1492 , JSAnnotation JSConstructor $
1493 JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1494 JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1495 , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1497 ))
1500 mainLoop :: JS
1501 mainLoop =
1502 JSAlloc "main" $ Just $ JSFunction [] (
1503 case target of
1504 Node -> mainFun
1505 JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [
1506 JSString "DOMContentLoaded", JSFunction [] (
1507 mainFun
1508 ), JSFalse
1509 ])]
1511 where
1512 mainFun :: JS
1513 mainFun = jsTailcall $ jsCall runMain []
1516 isReady :: JS
1517 isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
1520 readyState :: JS
1521 readyState = JSProj (JSIdent "document") "readyState"
1524 runMain :: String
1525 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1528 invokeLoop :: JS
1529 invokeLoop = jsCall "main" []
1532translateIdentifier :: String -> String
1533translateIdentifier =
1534 replaceReserved . concatMap replaceBadChars
1535 where replaceBadChars :: Char -> String
1536 replaceBadChars c
1537 | ' ' <- c = "_"
1538 | '_' <- c = "__"
1539 | isDigit c = '_' : show (ord c)
1540 | not (isLetter c && isAscii c) = '_' : show (ord c)
1541 | otherwise = [c]
1542 replaceReserved s
1543 | s `elem` reserved = '_' : s
1544 | otherwise = s
1547 reserved = [ "break"
1548 , "case"
1549 , "catch"
1550 , "continue"
1551 , "debugger"
1552 , "default"
1553 , "delete"
1554 , "do"
1555 , "else"
1556 , "finally"
1557 , "for"
1558 , "function"
1559 , "if"
1560 , "in"
1561 , "instanceof"
1562 , "new"
1563 , "return"
1564 , "switch"
1565 , "this"
1566 , "throw"
1567 , "try"
1568 , "typeof"
1569 , "var"
1570 , "void"
1571 , "while"
1572 , "with"
1574 , "class"
1575 , "enum"
1576 , "export"
1577 , "extends"
1578 , "import"
1579 , "super"
1581 , "implements"
1582 , "interface"
1583 , "let"
1584 , "package"
1585 , "private"
1586 , "protected"
1587 , "public"
1588 , "static"
1589 , "yield"
1593translateNamespace :: Name -> String
1594translateNamespace (UN _) = idrNamespace
1595translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1596translateNamespace (MN _ _) = idrNamespace
1597translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1598translateNamespace NErased = idrNamespace
1601translateName :: Name -> String
1602translateName (UN name) = 'u' : translateIdentifier (str name)
1603translateName (NS name _) = 'n' : translateName name
1604translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1605translateName (SN name) = 's' : translateSpecialName name
1606translateName NErased = "e"
1609translateSpecialName :: SpecialName -> String
1610translateSpecialName name
1611 | WhereN i m n <- name =
1612 'w' : translateName m ++ translateName n ++ show i
1613 | InstanceN n s <- name =
1614 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1615 | ParentN n s <- name =
1616 'p' : translateName n ++ translateIdentifier (str s)
1617 | MethodN n <- name =
1618 'm' : translateName n
1619 | CaseN n <- name =
1620 'c' : translateName n
1623translateConstant :: Const -> JS
1624translateConstant (I i) = JSNum (JSInt i)
1625translateConstant (Fl f) = JSNum (JSFloat f)
1626translateConstant (Ch c) = JSString $ translateChar c
1627translateConstant (Str s) = JSString $ concatMap translateChar s
1628translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1629translateConstant StrType = JSType JSStringTy
1630translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1631translateConstant (AType ATFloat) = JSType JSFloatTy
1632translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1633translateConstant PtrType = JSType JSPtrTy
1634translateConstant Forgot = JSType JSForgotTy
1635translateConstant (BI i) = jsBigInt $ JSString (show i)
1636translateConstant c =
1637 jsError $ "Unimplemented Constant: " ++ show c
1640translateChar :: Char -> String
1641translateChar ch
1642 | '\a' <- ch = "\\u0007"
1643 | '\b' <- ch = "\\b"
1644 | '\f' <- ch = "\\f"
1645 | '\n' <- ch = "\\n"
1646 | '\r' <- ch = "\\r"
1647 | '\t' <- ch = "\\t"
1648 | '\v' <- ch = "\\v"
1649 | '\SO' <- ch = "\\u000E"
1650 | '\DEL' <- ch = "\\u007F"
1651 | '\\' <- ch = "\\\\"
1652 | '\"' <- ch = "\\\""
1653 | '\'' <- ch = "\\\'"
1654 | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
1655 | otherwise = [ch]
1656 where
1657 fill :: String -> String
1658 fill s = if length s == 1
1659 then '0' : s
1660 else s
1662 asciiTab =
1663 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
1664 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
1665 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
1666 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1669translateDeclaration :: (String, SDecl) -> [JS]
1670translateDeclaration (path, SFun name params stackSize body)
1671 | (MN _ ap) <- name
1672 , (SChkCase var cases) <- body
1673 , ap == txt "APPLY" =
1674 [ lookupTable "APPLY" [] var cases
1675 , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1676 JSTernary (
1677 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1678 (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1679 ) (JSApp
1680 (JSIndex
1681 (JSIdent (idrLTNamespace ++ "APPLY"))
1682 (JSProj (JSIdent "mfn0") "tag")
1684 [JSIdent "mfn0", JSIdent "marg0"]
1685 ) JSNull
1689 | (MN _ ev) <- name
1690 , (SChkCase var cases) <- body
1691 , ev == txt "EVAL" =
1692 [ lookupTable "EVAL" [] var cases
1693 , jsDecl $ JSFunction ["marg0"] (JSReturn $
1694 JSTernary (
1695 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1696 (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1697 ) (JSApp
1698 (JSIndex
1699 (JSIdent (idrLTNamespace ++ "EVAL"))
1700 (JSProj (JSIdent "marg0") "tag")
1702 [JSIdent "marg0"]
1703 ) (JSIdent "marg0")
1706 | otherwise =
1707 let fun = translateExpression body in
1708 [jsDecl $ jsFun fun]
1710 where
1711 hasProp :: String -> String -> JS
1712 hasProp table var =
1713 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1716 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1717 caseFun aux var cse =
1718 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1719 jsFunAux aux c
1722 getTag :: SAlt -> Maybe Int
1723 getTag (SConCase _ tag _ _ _) = Just tag
1724 getTag _ = Nothing
1727 lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1728 lookupTable table aux var cases =
1729 JSAlloc (idrLTNamespace ++ table) $ Just (
1730 JSApp (JSFunction [] (
1731 JSSeq $ [
1732 JSAlloc "t" $ Just (JSArray [])
1733 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1734 JSReturn (JSIdent "t")
1736 )) []
1738 where
1739 assignEntries :: [(Int, JS)] -> [JS]
1740 assignEntries entries =
1741 map (\(tag, fun) ->
1742 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1743 ) entries
1746 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1747 lookupEntry aux var alt = do
1748 tag <- getTag alt
1749 return (tag, caseFun aux var alt)
1752 jsDecl :: JS -> JS
1753 jsDecl = JSAlloc (path ++ translateName name) . Just
1756 jsFun body = jsFunAux [] body
1759 jsFunAux :: [(LVar, String)] -> JS -> JS
1760 jsFunAux aux body =
1761 JSFunction (p ++ map snd aux) (
1762 JSSeq $
1763 zipWith assignVar [0..] p ++
1764 map assignAux aux ++
1765 [JSReturn body]
1767 where
1768 assignVar :: Int -> String -> JS
1769 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1772 assignAux :: (LVar, String) -> JS
1773 assignAux (Loc var, val) =
1774 JSAlloc (jsVar var) (Just $ JSIdent val)
1777 p :: [String]
1778 p = map translateName params
1781translateVariableName :: LVar -> String
1782translateVariableName (Loc i) =
1783 jsVar i
1786translateExpression :: SExp -> JS
1787translateExpression (SLet name value body) =
1788 jsLet (translateVariableName name) (
1789 translateExpression value
1790 ) (translateExpression body)
1792translateExpression (SConst cst) =
1793 translateConstant cst
1795translateExpression (SV var) =
1796 JSVar var
1798translateExpression (SApp tc name vars)
1799 | False <- tc =
1800 jsTailcall $ translateFunctionCall name vars
1801 | True <- tc =
1802 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1803 JSReturn $ translateFunctionCall name vars
1804 )]
1805 where
1806 translateFunctionCall name vars =
1807 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1809translateExpression (SOp op vars)
1810 | LNoOp <- op = JSVar (last vars)
1812 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1813 | (LPlus (ATInt ITBig)) <- op
1814 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1815 | (LMinus (ATInt ITBig)) <- op
1816 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1817 | (LTimes (ATInt ITBig)) <- op
1818 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1819 | (LSDiv (ATInt ITBig)) <- op
1820 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1821 | (LSRem (ATInt ITBig)) <- op
1822 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1823 | (LEq (ATInt ITBig)) <- op
1824 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1825 | (LSLt (ATInt ITBig)) <- op
1826 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1827 | (LSLe (ATInt ITBig)) <- op
1828 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1829 | (LSGt (ATInt ITBig)) <- op
1830 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1831 | (LSGe (ATInt ITBig)) <- op
1832 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1834 | (LPlus ATFloat) <- op
1835 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1836 | (LMinus ATFloat) <- op
1837 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1838 | (LTimes ATFloat) <- op
1839 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1840 | (LSDiv ATFloat) <- op
1841 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1842 | (LEq ATFloat) <- op
1843 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1844 | (LSLt ATFloat) <- op
1845 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1846 | (LSLe ATFloat) <- op
1847 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1848 | (LSGt ATFloat) <- op
1849 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1850 | (LSGe ATFloat) <- op
1851 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1853 | (LPlus _) <- op
1854 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1855 | (LMinus _) <- op
1856 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1857 | (LTimes _) <- op
1858 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1859 | (LSDiv _) <- op
1860 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1861 | (LSRem _) <- op
1862 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1863 | (LEq _) <- op
1864 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1865 | (LSLt _) <- op
1866 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1867 | (LSLe _) <- op
1868 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1869 | (LSGt _) <- op
1870 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1871 | (LSGe _) <- op
1872 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1873 | (LAnd _) <- op
1874 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1875 | (LOr _) <- op
1876 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1877 | (LXOr _) <- op
1878 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1879 | (LSHL _) <- op
1880 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1881 | (LASHR _) <- op
1882 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1883 | (LCompl _) <- op
1884 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
1886 | LStrConcat <- op
1887 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1888 | LStrEq <- op
1889 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1890 | LStrLt <- op
1891 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1892 | LStrLen <- op
1893 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1895 | (LStrInt ITNative) <- op
1896 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1897 | (LIntStr ITNative) <- op
1898 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1899 | (LSExt ITNative ITBig) <- op
1900 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1901 | (LTrunc ITBig ITNative) <- op
1902 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1903 | (LIntStr ITBig) <- op
1904 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1905 | (LStrInt ITBig) <- op
1906 , (arg:_) <- vars = jsBigInt $ JSVar arg
1907 | LFloatStr <- op
1908 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1909 | LStrFloat <- op
1910 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1911 | (LIntFloat ITNative) <- op
1912 , (arg:_) <- vars = JSVar arg
1913 | (LFloatInt ITNative) <- op
1914 , (arg:_) <- vars = JSVar arg
1915 | (LChInt ITNative) <- op
1916 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1917 | (LIntCh ITNative) <- op
1918 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1920 | LFExp <- op
1921 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1922 | LFLog <- op
1923 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1924 | LFSin <- op
1925 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1926 | LFCos <- op
1927 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1928 | LFTan <- op
1929 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1930 | LFASin <- op
1931 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1932 | LFACos <- op
1933 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1934 | LFATan <- op
1935 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1936 | LFSqrt <- op
1937 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1938 | LFFloor <- op
1939 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1940 | LFCeil <- op
1941 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1943 | LStrCons <- op
1944 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1945 | LStrHead <- op
1946 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1947 | LStrRev <- op
1948 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1949 | LStrIndex <- op
1950 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1951 | LStrTail <- op
1952 , (arg:_) <- vars = let v = translateVariableName arg in
1953 JSApp (JSProj (JSIdent v) "substr") [
1954 JSNum (JSInt 1),
1955 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
1957 | LNullPtr <- op
1958 , (_) <- vars = JSNull
1960 where
1961 translateBinaryOp :: String -> LVar -> LVar -> JS
1962 translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)
1965 invokeMeth :: LVar -> String -> [LVar] -> JS
1966 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1968translateExpression (SError msg) =
1969 jsError msg
1971translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1972 jsCall (idrRTNamespace ++ "print") [JSVar var]
1974translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
1975 JSBinOp "==" (JSVar var) JSNull
1977translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
1978 JSBinOp "==" (JSVar lhs) (JSVar rhs)
1980translateExpression (SForeign _ _ "idris_time" []) =
1981 JSRaw "(new Date()).getTime()"
1983translateExpression (SForeign _ _ fun args) =
1984 JSFFI fun (map generateWrapper args)
1985 where
1986 generateWrapper (ffunc, name)
1987 | FFunction <- ffunc =
1988 JSApp (
1989 JSIdent $ idrRTNamespace ++ "ffiWrap"
1990 ) [JSIdent $ translateVariableName name]
1991 | FFunctionIO <- ffunc =
1992 JSApp (
1993 JSIdent $ idrRTNamespace ++ "ffiWrap"
1994 ) [JSIdent $ translateVariableName name]
1996 generateWrapper (_, name) =
1997 JSIdent $ translateVariableName name
1999translateExpression patterncase
2000 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
2001 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
2002 where
2003 caseHelper var cases param =
2004 JSApp (JSFunction [param] (
2005 JSCond $ map (expandCase param . translateCaseCond param) cases
2006 )) [JSVar var]
2009 expandCase :: String -> (Cond, JS) -> (JS, JS)
2010 expandCase _ (RawCond cond, branch) = (cond, branch)
2011 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
2012 expandCase var (CaseCond caseTy, branch)
2013 | ConCase tag <- caseTy =
2014 let checkCon = JSIdent var `jsInstanceOf` jsCon
2015 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
2016 (checkCon `jsAnd` checkTag, branch)
2018 | TypeCase ty <- caseTy =
2019 let checkTy = JSIdent var `jsInstanceOf` jsType
2020 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
2021 (checkTy `jsAnd` checkTag, branch)
2023translateExpression (SCon i name vars) =
2024 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
2025 , JSArray $ map JSVar vars
2028translateExpression (SUpdate var@(Loc i) e) =
2029 JSAssign (JSVar var) (translateExpression e)
2031translateExpression (SProj var i) =
2032 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
2034translateExpression SNothing = JSNull
2036translateExpression e =
2037 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
2040data CaseType = ConCase Int
2041 | TypeCase JSType
2042 | DefaultCase
2043 deriving Eq
2046data Cond = CaseCond CaseType
2047 | RawCond JS
2050translateCaseCond :: String -> SAlt -> (Cond, JS)
2051translateCaseCond _ cse@(SDefaultCase _) =
2052 (CaseCond DefaultCase, translateCase Nothing cse)
2054translateCaseCond var cse@(SConstCase ty _)
2055 | StrType <- ty = matchHelper JSStringTy
2056 | PtrType <- ty = matchHelper JSPtrTy
2057 | Forgot <- ty = matchHelper JSForgotTy
2058 | (AType ATFloat) <- ty = matchHelper JSFloatTy
2059 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
2060 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
2061 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
2062 where
2063 matchHelper :: JSType -> (Cond, JS)
2064 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
2066translateCaseCond var cse@(SConstCase cst@(BI _) _) =
2067 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
2068 (RawCond cond, translateCase Nothing cse)
2070translateCaseCond var cse@(SConstCase cst _) =
2071 let cond = JSIdent var `jsEq` translateConstant cst in
2072 (RawCond cond, translateCase Nothing cse)
2074translateCaseCond var cse@(SConCase _ tag _ _ _) =
2075 (CaseCond $ ConCase tag, translateCase (Just var) cse)
2078translateCase :: Maybe String -> SAlt -> JS
2079translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
2080translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
2081translateCase (Just var) (SConCase a _ _ vars e) =
2082 let params = map jsVar [a .. (a + length vars)] in
2083 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
2084 JSThis, JSProj (JSIdent var) "vars"