git.iko.soy/Idris-dev
on fa9f021 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1660 lines 52 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where
5import Idris.AbsSyntax hiding (TypeCase)
6import IRTS.Bytecode
7import IRTS.Lang
8import IRTS.Simplified
9import IRTS.CodegenCommon
10import Idris.Core.TT
11import Paths_idris
12import Util.System
14import Control.Arrow
15import Control.Applicative ((<$>), (<*>), pure)
16import Data.Char
17import Data.List
18import Data.Maybe
19import System.IO
20import System.Directory
22idrNamespace :: String
23idrNamespace = "__IDR__"
24idrRTNamespace = "__IDRRT__"
25idrLTNamespace = "__IDRLT__"
28data JSTarget = Node | JavaScript deriving Eq
31data JSType = JSIntTy
32 | JSStringTy
33 | JSIntegerTy
34 | JSFloatTy
35 | JSCharTy
36 | JSPtrTy
37 | JSForgotTy
38 deriving Eq
41data JSInteger = JSBigZero
42 | JSBigOne
43 | JSBigInt Integer
44 deriving Eq
47data JSNum = JSInt Int
48 | JSFloat Double
49 | JSInteger JSInteger
50 deriving Eq
53data JS = JSRaw String
54 | JSIdent String
55 | JSFunction [String] JS
56 | JSType JSType
57 | JSSeq [JS]
58 | JSReturn JS
59 | JSApp JS [JS]
60 | JSNew String [JS]
61 | JSError String
62 | JSBinOp String JS JS
63 | JSPreOp String JS
64 | JSPostOp String JS
65 | JSProj JS String
66 | JSVar LVar
67 | JSNull
68 | JSThis
69 | JSTrue
70 | JSFalse
71 | JSArray [JS]
72 | JSString String
73 | JSChar String
74 | JSNum JSNum
75 | JSAssign JS JS
76 | JSAlloc String (Maybe JS)
77 | JSIndex JS JS
78 | JSCond [(JS, JS)]
79 | JSTernary JS JS JS
80 | JSParens JS
81 | JSWhile JS JS
82 deriving Eq
85compileJS :: JS -> String
86compileJS (JSRaw code) =
87 code
89compileJS (JSIdent ident) =
90 ident
92compileJS (JSFunction args body) =
93 "function("
94 ++ intercalate "," args
95 ++ "){\n"
96 ++ compileJS body
97 ++ "\n}"
99compileJS (JSType ty)
100 | JSIntTy <- ty = idrRTNamespace ++ "Int"
101 | JSStringTy <- ty = idrRTNamespace ++ "String"
102 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
103 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
104 | JSCharTy <- ty = idrRTNamespace ++ "Char"
105 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
106 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
108compileJS (JSSeq seq) =
109 intercalate ";\n" (map compileJS seq)
111compileJS (JSReturn val) =
112 "return " ++ compileJS val
114compileJS (JSApp lhs rhs)
115 | JSFunction {} <- lhs =
116 concat ["(", compileJS lhs, ")(", args, ")"]
117 | otherwise =
118 concat [compileJS lhs, "(", args, ")"]
119 where args :: String
120 args = intercalate "," $ map compileJS rhs
122compileJS (JSNew name args) =
123 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
125compileJS (JSError exc) =
126 "throw new Error(\"" ++ exc ++ "\")"
128compileJS (JSBinOp op lhs rhs) =
129 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
131compileJS (JSProj obj field)
132 | JSFunction {} <- obj =
133 concat ["(", compileJS obj, ").", field]
134 | JSAssign {} <- obj =
135 concat ["(", compileJS obj, ").", field]
136 | otherwise =
137 compileJS obj ++ '.' : field
139compileJS (JSVar var) =
140 translateVariableName var
142compileJS JSNull =
143 "null"
145compileJS JSThis =
146 "this"
148compileJS JSTrue =
149 "true"
151compileJS JSFalse =
152 "false"
154compileJS (JSArray elems) =
155 "[" ++ intercalate "," (map compileJS elems) ++ "]"
157compileJS (JSString str) =
158 show str
160compileJS (JSChar chr) =
161 chr
163compileJS (JSNum num)
164 | JSInt i <- num = show i
165 | JSFloat f <- num = show f
166 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
167 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
168 | JSInteger (JSBigInt i) <- num = show i
170compileJS (JSAssign lhs rhs) =
171 compileJS lhs ++ "=" ++ compileJS rhs
173compileJS (JSAlloc name val) =
174 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
176compileJS (JSIndex lhs rhs) =
177 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
179compileJS (JSCond branches) =
180 intercalate " else " $ map createIfBlock branches
181 where
182 createIfBlock (JSTrue, e) =
183 "{\n"
184 ++ compileJS e
185 ++ ";\n}"
186 createIfBlock (cond, e) =
187 "if (" ++ compileJS cond ++") {\n"
188 ++ compileJS e
189 ++ ";\n}"
191compileJS (JSTernary cond true false) =
192 let c = compileJS cond
193 t = compileJS true
194 f = compileJS false in
195 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
197compileJS (JSParens js) =
198 "(" ++ compileJS js ++ ")"
200compileJS (JSWhile cond body) =
201 "while (" ++ compileJS cond ++ ") {\n"
202 ++ compileJS body
203 ++ "\n}"
205jsTailcall :: JS -> JS
206jsTailcall call =
207 jsCall (idrRTNamespace ++ "tailcall") [
208 JSFunction [] (JSReturn call)
209 ]
212jsCall :: String -> [JS] -> JS
213jsCall fun = JSApp (JSIdent fun)
216jsMeth :: JS -> String -> [JS] -> JS
217jsMeth obj meth =
218 JSApp (JSProj obj meth)
221jsInstanceOf :: JS -> JS -> JS
222jsInstanceOf = JSBinOp "instanceof"
225jsEq :: JS -> JS -> JS
226jsEq = JSBinOp "=="
229jsAnd :: JS -> JS -> JS
230jsAnd = JSBinOp "&&"
233jsType :: JS
234jsType = JSIdent $ idrRTNamespace ++ "Type"
237jsCon :: JS
238jsCon = JSIdent $ idrRTNamespace ++ "Con"
241jsTag :: JS -> JS
242jsTag obj = JSProj obj "tag"
245jsTypeTag :: JS -> JS
246jsTypeTag obj = JSProj obj "type"
249jsBigInt :: JS -> JS
250jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
251jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
252jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
255jsVar :: Int -> String
256jsVar = ("__var_" ++) . show
259jsLet :: String -> JS -> JS -> JS
260jsLet name value body =
261 JSApp (
262 JSFunction [name] (
263 JSReturn body
264 )
265 ) [value]
268jsError :: String -> JS
269jsError err = JSApp (JSFunction [] (JSError err)) []
272foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
273foldJS tr add acc js =
274 fold js
275 where
276 fold js
277 | JSFunction args body <- js =
278 add (tr js) (fold body)
279 | JSSeq seq <- js =
280 add (tr js) $ foldl' add acc (map fold seq)
281 | JSReturn ret <- js =
282 add (tr js) (fold ret)
283 | JSApp lhs rhs <- js =
284 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
285 | JSNew _ args <- js =
286 add (tr js) $ foldl' add acc $ map fold args
287 | JSBinOp _ lhs rhs <- js =
288 add (tr js) $ add (fold lhs) (fold rhs)
289 | JSPreOp _ val <- js =
290 add (tr js) $ fold val
291 | JSPostOp _ val <- js =
292 add (tr js) $ fold val
293 | JSProj obj _ <- js =
294 add (tr js) (fold obj)
295 | JSArray vals <- js =
296 add (tr js) $ foldl' add acc $ map fold vals
297 | JSAssign lhs rhs <- js =
298 add (tr js) $ add (fold lhs) (fold rhs)
299 | JSIndex lhs rhs <- js =
300 add (tr js) $ add (fold lhs) (fold rhs)
301 | JSAlloc _ val <- js =
302 add (tr js) $ fromMaybe acc $ fmap fold val
303 | JSTernary c t f <- js =
304 add (tr js) $ add (fold c) (add (fold t) (fold f))
305 | JSParens val <- js =
306 add (tr js) $ fold val
307 | JSCond conds <- js =
308 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
309 | JSWhile cond body <- js =
310 add (tr js) $ add (fold cond) (fold body)
311 | otherwise =
312 tr js
315transformJS :: (JS -> JS) -> JS -> JS
316transformJS tr js =
317 transformHelper js
318 where
319 transformHelper :: JS -> JS
320 transformHelper js
321 | JSFunction args body <- js = JSFunction args $ tr body
322 | JSSeq seq <- js = JSSeq $ map tr seq
323 | JSReturn ret <- js = JSReturn $ tr ret
324 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
325 | JSNew con args <- js = JSNew con $ map tr args
326 | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
327 | JSPreOp op val <- js = JSPreOp op (tr val)
328 | JSPostOp op val <- js = JSPostOp op (tr val)
329 | JSProj obj field <- js = JSProj (tr obj) field
330 | JSArray vals <- js = JSArray $ map tr vals
331 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
332 | JSAlloc var val <- js = JSAlloc var $ fmap tr val
333 | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
334 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
335 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
336 | JSParens val <- js = JSParens $ tr val
337 | JSWhile cond body <- js = JSWhile(tr cond) (tr body)
338 | otherwise = js
341moveJSDeclToTop :: String -> [JS] -> [JS]
342moveJSDeclToTop decl js = move ([], js)
343 where
344 move :: ([JS], [JS]) -> [JS]
345 move (front, js@(JSAlloc name _):back)
346 | name == decl = js : front ++ back
348 move (front, js:back) =
349 move (front ++ [js], back)
352jsSubst :: JS -> JS -> JS -> JS
353jsSubst var new old
354 | var == old = new
356jsSubst (JSIdent var) new (JSVar old)
357 | var == translateVariableName old = new
358 | otherwise = JSVar old
360jsSubst var new old@(JSIdent _)
361 | var == old = new
362 | otherwise = old
364jsSubst var new (JSArray fields) =
365 JSArray (map (jsSubst var new) fields)
367jsSubst var new (JSNew con vals) =
368 JSNew con $ map (jsSubst var new) vals
370jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
371 | var `notElem` args =
372 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
373 map (jsSubst (JSIdent var) new) vals
374 )
375 | otherwise =
376 JSApp (JSProj (JSFunction args body) "apply") (
377 map (jsSubst (JSIdent var) new) vals
378 )
380jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
381 | var /= arg =
382 JSApp (JSFunction [arg] (
383 jsSubst (JSIdent var) new body
384 )) $ map (jsSubst (JSIdent var) new) vals
385 | otherwise =
386 JSApp (JSFunction [arg] (
387 body
388 )) $ map (jsSubst (JSIdent var) new) vals
390jsSubst var new js = transformJS (jsSubst var new) js
393removeAllocations :: JS -> JS
394removeAllocations (JSSeq body) =
395 let opt = removeHelper (map removeAllocations body) in
396 case opt of
397 [ret] -> ret
398 _ -> JSSeq opt
399 where
400 removeHelper :: [JS] -> [JS]
401 removeHelper [js] = [js]
402 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
403 map (jsSubst (JSIdent name) val) (removeHelper js)
404 removeHelper (j:js) = j : removeHelper js
406removeAllocations js = transformJS removeAllocations js
409isJSConstant :: JS -> Bool
410isJSConstant js
411 | JSString _ <- js = True
412 | JSChar _ <- js = True
413 | JSNum _ <- js = True
414 | JSType _ <- js = True
415 | JSNull <- js = True
417 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
418 | otherwise = False
421inlineJS :: JS -> JS
422inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err
423inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
424 inlineJS $ jsSubst (JSIdent "cse") val body
427inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
428 inlineJS $ JSSeq [ JSAlloc arg (Just val)
429 , cond
430 ]
432inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
433 JSThis,JSProj var "vars"
434 ])
435 | var /= JSIdent "cse" =
436 inlineJS $ inlineApply args body 0
437 where
438 inlineApply [] body _ = inlineJS body
439 inlineApply (a:as) body n =
440 inlineApply as (
441 jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
442 ) (n + 1)
444inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
445 | isJSConstant val = val
447inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
448 JSFunction [] (JSReturn val)
449 ])
450 | isJSConstant val = val
452inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
453 | JSNew con [tag, vals] <- ret
454 , opt <- inlineJS val =
455 inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]
457 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
458 , opt <- inlineJS val =
459 inlineJS $ JSNew con [JSFunction [] (
460 JSReturn (
461 JSApp (
462 inlineJS $ jsSubst (JSIdent arg) opt fun
463 ) (
464 map (inlineJS . jsSubst (JSIdent arg) opt) vars
465 )
466 )
467 )]
469 | JSApp (JSProj obj field) args <- ret
470 , opt <- inlineJS val =
471 inlineJS $ JSApp (
472 inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field
473 ) (
474 map (inlineJS . jsSubst (JSIdent arg) opt) args
475 )
477 | JSIndex (JSProj obj field) idx <- ret
478 , opt <- inlineJS val =
479 inlineJS $ JSIndex (JSProj (
480 inlineJS $ jsSubst (JSIdent arg) opt obj
481 ) field
482 ) (inlineJS $ jsSubst (JSIdent arg) opt idx)
484 | JSBinOp op lhs rhs <- ret
485 , opt <- inlineJS val =
486 inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
487 (inlineJS $ jsSubst (JSIdent arg) opt rhs)
489 | JSApp (JSIdent fun) args <- ret
490 , opt <- inlineJS val =
491 inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args
493inlineJS js = transformJS inlineJS js
496reduceJS :: [JS] -> [JS]
497reduceJS js = reduceLoop [] ([], js)
500funName :: JS -> String
501funName (JSAlloc fun _) = fun
504elimDeadLoop :: [JS] -> [JS]
505elimDeadLoop js
506 | ret <- deadEvalApplyCases js
507 , ret /= js = elimDeadLoop ret
508 | otherwise = js
511deadEvalApplyCases :: [JS] -> [JS]
512deadEvalApplyCases js =
513 let tags = sort $ nub $ concatMap (getTags) js in
514 map (removeHelper tags) js
515 where
516 getTags :: JS -> [Int]
517 getTags = foldJS match (++) []
518 where
519 match js
520 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
521 | otherwise = []
524 removeHelper :: [Int] -> JS -> JS
525 removeHelper tags (JSAlloc fun (Just (
526 JSApp (JSFunction [] (JSSeq seq)) []))
527 ) =
528 (JSAlloc fun (Just (
529 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
530 )
532 removeHelper _ js = js
535 remover :: [Int] -> [JS] -> [JS]
536 remover tags (
537 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
538 )
539 | tag `notElem` tags = remover tags js
541 remover tags (j:js) = j : remover tags js
542 remover _ [] = []
545initConstructors :: [JS] -> [JS]
546initConstructors js =
547 let tags = nub $ sort $ concat (map getTags js) in
548 rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
549 where
550 rearrangePrelude :: [JS] -> [JS]
551 rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
554 getTags :: JS -> [Int]
555 getTags = foldJS match (++) []
556 where
557 match js
558 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
559 | otherwise = []
562 replaceConstructors :: [Int] -> [JS] -> [JS]
563 replaceConstructors tags js = map (replaceHelper tags) js
564 where
565 replaceHelper :: [Int] -> JS -> JS
566 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
567 | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)
569 replaceHelper tags js = transformJS (replaceHelper tags) js
572 createConstant :: Int -> JS
573 createConstant tag =
574 JSAlloc ("__IDRCTR__" ++ show tag) (Just (
575 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
576 ))
579removeIDs :: [JS] -> [JS]
580removeIDs js =
581 case partition isID js of
582 ([], rest) -> rest
583 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
584 where isID :: JS -> Bool
585 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
586 | JSReturn (JSVar _) <- last body = True
588 isID _ = False
591 idFor :: JS -> (String, Int)
592 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
593 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
596 removeIDCall :: [(String, Int)] -> JS -> JS
597 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
598 JSReturn (JSApp (JSIdent fun) args)
599 )])
600 | Just pos <- lookup fun ids
601 , pos < length args = args !! pos
603 removeIDCall ids (JSNew _ [JSFunction [] (
604 JSReturn (JSApp (JSIdent fun) args)
605 )])
606 | Just pos <- lookup fun ids
607 , pos < length args = args !! pos
609 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
610 | Just pos <- lookup fun ids
611 , pos < length args = args !! pos
613 removeIDCall ids js = transformJS (removeIDCall ids) js
616inlineFunctions :: [JS] -> [JS]
617inlineFunctions js =
618 inlineHelper ([], js)
619 where
620 inlineHelper :: ([JS], [JS]) -> [JS]
621 inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
622 | countAll fun front + countAll fun back == 0 =
623 inlineHelper (front, back)
624 | Just new <- inlineAble (
625 countAll fun front + countAll fun back
626 ) fun args body =
627 let f = map (inline fun args new) in
628 inlineHelper (f front, f back)
630 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
631 inlineHelper (front, []) = front
634 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
635 inlineAble 1 fun args body
636 | nonRecur fun body =
637 inlineAble' body
638 where
639 inlineAble' :: JS -> Maybe JS
640 inlineAble' (
641 JSReturn js@(JSNew "__IDRRT__Con" [JSNum _, JSArray vals])
642 )
643 | and $ map (\x -> isJSIdent x || isJSConstant x) vals = Just js
645 inlineAble' (
646 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] (
647 JSReturn (JSApp (JSIdent _) args)
648 )])
649 )
650 | and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js
652 inlineAble' (
653 JSReturn js@(JSIndex (JSProj (JSApp (JSIdent _) args) "vars") _)
654 )
655 | and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js
657 inlineAble' _ = Nothing
659 isJSIdent js
660 | JSIdent _ <- js = True
661 | otherwise = False
663 inlineAble _ _ _ _ = Nothing
666 inline :: String -> [String] -> JS -> JS -> JS
667 inline fun args body js = inline' js
668 where
669 inline' :: JS -> JS
670 inline' (JSApp (JSIdent name) vals)
671 | name == fun =
672 let (js, phs) = insertPlaceHolders args body in
673 inline' $ foldr (uncurry jsSubst) js (zip phs vals)
675 inline' js = transformJS inline' js
677 insertPlaceHolders :: [String] -> JS -> (JS, [JS])
678 insertPlaceHolders args body = insertPlaceHolders' args body []
679 where
680 insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
681 insertPlaceHolders' (a:as) body ph
682 | (body', ph') <- insertPlaceHolders' as body ph =
683 let phvar = JSIdent $ "__PH_" ++ show (length ph') in
684 (jsSubst (JSIdent a) phvar body', phvar : ph')
686 insertPlaceHolders' [] body ph = (body, ph)
689 nonRecur :: String -> JS -> Bool
690 nonRecur name body = countInvokations name body == 0
693 countAll :: String -> [JS] -> Int
694 countAll name js = sum $ map (countInvokations name) js
697 countInvokations :: String -> JS -> Int
698 countInvokations name = foldJS match (+) 0
699 where
700 match :: JS -> Int
701 match js
702 | JSApp (JSIdent ident) _ <- js
703 , name == ident = 1
704 | JSNew con _ <- js
705 , name == con = 1
706 | otherwise = 0
709reduceContinuations :: JS -> JS
710reduceContinuations = transformJS reduceHelper
711 where
712 reduceHelper :: JS -> JS
713 reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] (
714 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
715 )]) = js
717 reduceHelper js = transformJS reduceHelper js
720reduceConstant :: JS -> JS
721reduceConstant
722 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
723 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
724 )])
725 | JSNum num <- val = val
726 | JSBinOp op lhs rhs <- val =
727 JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
729 | JSApp (JSProj lhs op) [rhs] <- val
730 , op `elem` [ "subtract"
731 , "add"
732 , "multiply"
733 , "divide"
734 , "mod"
735 , "equals"
736 , "lesser"
737 , "lesserOrEquals"
738 , "greater"
739 , "greaterOrEquals"
740 ] = val
742reduceConstant (JSApp ident [(JSParens js)]) =
743 JSApp ident [reduceConstant js]
745reduceConstant js = transformJS reduceConstant js
748reduceConstants :: JS -> JS
749reduceConstants js
750 | ret <- reduceConstant js
751 , ret /= js = reduceConstants ret
752 | otherwise = js
755elimDuplicateEvals :: JS -> JS
756elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
757 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
758 where
759 elimHelper :: [JS] -> [JS]
760 elimHelper (j@(JSAlloc var (Just val)):js) =
761 j : map (jsSubst val (JSIdent var)) (elimHelper js)
762 elimHelper (j:js) =
763 j : elimHelper js
764 elimHelper [] = []
766elimDuplicateEvals js = js
769optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
770optimizeRuntimeCalls fun tc js =
771 optTC tc : map optHelper js
772 where
773 optHelper :: JS -> JS
774 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
775 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
776 ])
777 | n == fun = JSApp (JSIdent tc) $ map optHelper args
779 optHelper js = transformJS optHelper js
782 optTC :: String -> JS
783 optTC tc@"__IDRRT__EVALTC" =
784 JSAlloc tc (Just $ JSFunction ["arg0"] (
785 JSSeq [ JSAlloc "ret" $ Just (
786 JSTernary (
787 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
788 (hasProp "__IDRLT__mEVAL0" "arg0")
789 ) (JSApp
790 (JSIndex
791 (JSIdent "__IDRLT__mEVAL0")
792 (JSProj (JSIdent "arg0") "tag")
793 )
794 [JSIdent "arg0"]
795 ) (JSIdent "arg0")
796 )
797 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
798 JSAssign (JSIdent "ret") (
799 JSApp (JSProj (JSIdent "ret") "k") []
800 )
801 )
802 , JSReturn $ JSIdent "ret"
803 ]
804 ))
806 optTC tc@"__IDRRT__APPLYTC" =
807 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
808 JSSeq [ JSAlloc "ev" $ Just (JSApp
809 (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]
810 )
811 , JSAlloc "ret" $ Just (
812 JSTernary (
813 (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
814 (hasProp "__IDRLT__mAPPLY0" "ev")
815 ) (JSApp
816 (JSIndex
817 (JSIdent "__IDRLT__mAPPLY0")
818 (JSProj (JSIdent "ev") "tag")
819 )
820 [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
821 ) JSNull
822 )
823 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
824 JSAssign (JSIdent "ret") (
825 JSApp (JSProj (JSIdent "ret") "k") []
826 )
827 )
828 , JSReturn $ JSIdent "ret"
829 ]
830 ))
833 hasProp :: String -> String -> JS
834 hasProp table var =
835 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
838unfoldLookupTable :: [JS] -> [JS]
839unfoldLookupTable input =
840 let (evals, evalunfold) = unfoldLT "__IDRLT__mEVAL0" input
841 (applys, applyunfold) = unfoldLT "__IDRLT__mAPPLY0" evalunfold
842 js = applyunfold in
843 adaptRuntime $ expandCons evals applys js
844 where
845 adaptRuntime :: [JS] -> [JS]
846 adaptRuntime =
847 adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
850 adaptApply var = map (jsSubst (
851 JSIndex (JSIdent "__IDRLT__mAPPLY0") (JSProj (JSIdent var) "tag")
852 ) (JSProj (JSIdent var) "app"))
855 adaptEval = map (jsSubst (
856 JSIndex (JSIdent "__IDRLT__mEVAL0") (JSProj (JSIdent "arg0") "tag")
857 ) (JSProj (JSIdent "arg0") "eval"))
860 adaptCon js =
861 adaptCon' [] js
862 where
863 adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
864 front ++ (new:back)
866 adaptCon' front (next:back) =
867 adaptCon' (front ++ [next]) back
869 adaptCon' front [] = front
872 new =
873 JSAlloc "__IDRRT__Con" (Just $
874 JSFunction newArgs (
875 JSSeq (map newVar newArgs)
876 )
877 )
878 where
879 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
880 newArgs = ["tag", "eval", "app", "vars"]
883 unfoldLT :: String -> [JS] -> ([Int], [JS])
884 unfoldLT lt js =
885 let (table, code) = extractLT lt js
886 expanded = expandLT lt table in
887 (map fst expanded, map snd expanded ++ code)
890 expandCons :: [Int] -> [Int] -> [JS] -> [JS]
891 expandCons evals applys js =
892 map expandCons' js
893 where
894 expandCons' :: JS -> JS
895 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
896 | evalid <- getId "__IDRLT__mEVAL0" tag evals
897 , applyid <- getId "__IDRLT__mAPPLY0" tag applys =
898 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
899 , maybe JSNull JSIdent evalid
900 , maybe JSNull JSIdent applyid
901 , JSArray (map expandCons' args)
902 ]
904 expandCons' js = transformJS expandCons' js
907 getId :: String -> Int -> [Int] -> Maybe String
908 getId lt tag entries
909 | tag `elem` entries = Just $ ltIdentifier lt tag
910 | otherwise = Nothing
913 ltIdentifier :: String -> Int -> String
914 ltIdentifier "__IDRLT__mEVAL0" id = idrLTNamespace ++ "EVAL" ++ show id
915 ltIdentifier "__IDRLT__mAPPLY0" id = idrLTNamespace ++ "APPLY" ++ show id
918 extractLT :: String -> [JS] -> (JS, [JS])
919 extractLT lt js =
920 extractLT' ([], js)
921 where
922 extractLT' :: ([JS], [JS]) -> (JS, [JS])
923 extractLT' (front, js@(JSAlloc fun _):back)
924 | fun == lt = (js, front ++ back)
926 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
929 expandLT :: String -> JS -> [(Int, JS)]
930 expandLT lt (
931 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
932 ) = catMaybes (map expandEntry seq)
933 where
934 expandEntry :: JS -> Maybe (Int, JS)
935 expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
936 Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
938 expandEntry js = Nothing
941removeInstanceChecks :: JS -> JS
942removeInstanceChecks (JSCond conds) =
943 JSCond $ eliminateDeadBranches $ map (
944 removeHelper *** removeInstanceChecks
945 ) conds
946 where
947 removeHelper (
948 JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
949 ) = removeHelper check
950 removeHelper js = js
953 eliminateDeadBranches (e@(JSTrue, _):_) = [e]
954 eliminateDeadBranches [(_, js)] = [(JSTrue, js)]
955 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
956 eliminateDeadBranches [] = []
958removeInstanceChecks js = transformJS removeInstanceChecks js
961reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
962reduceLoop reduced (cons, program) =
963 case partition findConstructors program of
964 ([], js) -> cons ++ js
965 (candidates, rest) ->
966 let names = reduced ++ map funName candidates in
967 reduceLoop names (
968 cons ++ map reduce candidates, map (reduceCall names) rest
969 )
970 where findConstructors :: JS -> Bool
971 findConstructors js
972 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
973 reducable $ last body
974 | otherwise = False
975 where reducable :: JS -> Bool
976 reducable js
977 | JSReturn ret <- js = reducable ret
978 | JSNew _ args <- js = and $ map reducable args
979 | JSArray fields <- js = and $ map reducable fields
980 | JSNum _ <- js = True
981 | JSNull <- js = True
982 | JSIdent _ <- js = True
983 | otherwise = False
986 reduce :: JS -> JS
987 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
988 | JSReturn js <- last body = (JSAlloc fun (Just js))
990 reduce js = js
993 reduceCall :: [String] -> JS -> JS
994 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
995 JSReturn (JSApp id@(JSIdent ret) _)
996 )])
997 | ret `elem` funs = id
999 reduceCall funs js@(JSApp id@(JSIdent fun) _)
1000 | fun `elem` funs = id
1002 reduceCall funs js = transformJS (reduceCall funs) js
1005optimizeJS :: JS -> JS
1006optimizeJS = inlineLoop
1007 where inlineLoop :: JS -> JS
1008 inlineLoop js
1009 | opt <- inlineJS js
1010 , opt /= js = inlineLoop opt
1011 | otherwise = js
1014codegenJavaScript
1015 :: JSTarget
1016 -> [(Name, SDecl)]
1017 -> FilePath
1018 -> OutputType
1019 -> IO ()
1020codegenJavaScript target definitions filename outputType = do
1021 let (header, runtime) = case target of
1022 Node ->
1023 ("#!/usr/bin/env node\n", "-node")
1024 JavaScript ->
1025 ("", "-browser")
1026 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1027 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1028 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
1029 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1030 writeFile filename $ header ++ (
1031 intercalate "\n" $ [ jsbn
1032 , idrRuntime
1033 , tgtRuntime
1034 ] ++ functions
1037 setPermissions filename (emptyPermissions { readable = True
1038 , executable = target == Node
1039 , writable = True
1040 })
1041 where
1042 def :: [(String, SDecl)]
1043 def = map (first translateNamespace) definitions
1046 functions :: [String]
1047 functions = translate >>> optimize >>> compile $ def
1048 where
1049 translate p =
1050 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1051 optimize p =
1052 foldl' (flip ($)) p opt
1053 compile =
1054 map compileJS
1056 opt =
1057 [ map optimizeJS
1058 , removeIDs
1059 , reduceJS
1060 , map reduceConstants
1061 , initConstructors
1062 , map removeAllocations
1063 , elimDeadLoop
1064 , map elimDuplicateEvals
1065 , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1066 , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1067 , map removeInstanceChecks
1068 , inlineFunctions
1069 , map reduceContinuations
1070 , unfoldLookupTable
1073 prelude :: [JS]
1074 prelude =
1075 [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1076 JSAssign (JSProj JSThis "k") (JSIdent "k")
1077 ))
1078 , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1079 JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1080 , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1082 ))
1085 mainLoop :: JS
1086 mainLoop =
1087 JSAlloc "main" $ Just $ JSFunction [] (
1088 case target of
1089 Node -> mainFun
1090 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
1091 JSString "DOMContentLoaded", JSFunction [] (
1092 mainFun
1093 ), JSFalse
1096 where
1097 mainFun :: JS
1098 mainFun = jsTailcall $ jsCall runMain []
1101 runMain :: String
1102 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1105 invokeLoop :: JS
1106 invokeLoop = jsCall "main" []
1109translateIdentifier :: String -> String
1110translateIdentifier =
1111 replaceReserved . concatMap replaceBadChars
1112 where replaceBadChars :: Char -> String
1113 replaceBadChars c
1114 | ' ' <- c = "_"
1115 | '_' <- c = "__"
1116 | isDigit c = '_' : show (ord c)
1117 | not (isLetter c && isAscii c) = '_' : show (ord c)
1118 | otherwise = [c]
1119 replaceReserved s
1120 | s `elem` reserved = '_' : s
1121 | otherwise = s
1124 reserved = [ "break"
1125 , "case"
1126 , "catch"
1127 , "continue"
1128 , "debugger"
1129 , "default"
1130 , "delete"
1131 , "do"
1132 , "else"
1133 , "finally"
1134 , "for"
1135 , "function"
1136 , "if"
1137 , "in"
1138 , "instanceof"
1139 , "new"
1140 , "return"
1141 , "switch"
1142 , "this"
1143 , "throw"
1144 , "try"
1145 , "typeof"
1146 , "var"
1147 , "void"
1148 , "while"
1149 , "with"
1151 , "class"
1152 , "enum"
1153 , "export"
1154 , "extends"
1155 , "import"
1156 , "super"
1158 , "implements"
1159 , "interface"
1160 , "let"
1161 , "package"
1162 , "private"
1163 , "protected"
1164 , "public"
1165 , "static"
1166 , "yield"
1170translateNamespace :: Name -> String
1171translateNamespace (UN _) = idrNamespace
1172translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1173translateNamespace (MN _ _) = idrNamespace
1174translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1175translateNamespace NErased = idrNamespace
1178translateName :: Name -> String
1179translateName (UN name) = 'u' : translateIdentifier (str name)
1180translateName (NS name _) = 'n' : translateName name
1181translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1182translateName (SN name) = 's' : translateSpecialName name
1183translateName NErased = "e"
1186translateSpecialName :: SpecialName -> String
1187translateSpecialName name
1188 | WhereN i m n <- name =
1189 'w' : translateName m ++ translateName n ++ show i
1190 | InstanceN n s <- name =
1191 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1192 | ParentN n s <- name =
1193 'p' : translateName n ++ translateIdentifier (str s)
1194 | MethodN n <- name =
1195 'm' : translateName n
1196 | CaseN n <- name =
1197 'c' : translateName n
1200translateConstant :: Const -> JS
1201translateConstant (I i) = JSNum (JSInt i)
1202translateConstant (Fl f) = JSNum (JSFloat f)
1203translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
1204translateConstant (Ch '\a') = JSChar "'\\u0007'"
1205translateConstant (Ch '\SO') = JSChar "'\\u000E'"
1206translateConstant (Ch c) = JSString [c]
1207translateConstant (Str s) = JSString s
1208translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1209translateConstant StrType = JSType JSStringTy
1210translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1211translateConstant (AType ATFloat) = JSType JSFloatTy
1212translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1213translateConstant PtrType = JSType JSPtrTy
1214translateConstant Forgot = JSType JSForgotTy
1215translateConstant (BI i) = jsBigInt $ JSString (show i)
1216translateConstant c =
1217 jsError $ "Unimplemented Constant: " ++ show c
1220translateDeclaration :: (String, SDecl) -> [JS]
1221translateDeclaration (path, SFun name params stackSize body)
1222 | (MN _ ap) <- name
1223 , (SLet var val next) <- body
1224 , (SChkCase cvar cases) <- next
1225 , ap == txt "APPLY" =
1226 let lvar = translateVariableName var
1227 lookup t = (JSApp
1228 (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
1229 [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
1230 [ lookupTable [(var, "chk")] var cases
1231 , jsDecl $ JSFunction ["fn0", "arg0"] (
1232 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1233 , JSAlloc (translateVariableName var) (
1234 Just $ translateExpression val
1236 , JSReturn $ (JSTernary (
1237 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1238 (hasProp lookupTableName (translateVariableName var))
1239 ) (lookup lookupTableName) JSNull)
1244 | (MN _ ev) <- name
1245 , (SChkCase var cases) <- body
1246 , ev == txt "EVAL" =
1247 [ lookupTable [] var cases
1248 , jsDecl $ JSFunction ["arg0"] (JSReturn $
1249 JSTernary (
1250 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1251 (hasProp lookupTableName "arg0")
1252 ) (JSApp
1253 (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
1254 [JSIdent "arg0"]
1255 ) (JSIdent "arg0")
1258 | otherwise =
1259 let fun = translateExpression body in
1260 [jsDecl $ jsFun fun]
1262 where
1263 hasProp :: String -> String -> JS
1264 hasProp table var =
1265 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1268 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1269 caseFun aux var cse =
1270 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1271 jsFunAux aux c
1274 getTag :: SAlt -> Maybe Int
1275 getTag (SConCase _ tag _ _ _) = Just tag
1276 getTag _ = Nothing
1279 lookupTableName :: String
1280 lookupTableName = idrLTNamespace ++ translateName name
1283 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
1284 lookupTable aux var cases =
1285 JSAlloc lookupTableName $ Just (
1286 JSApp (JSFunction [] (
1287 JSSeq $ [
1288 JSAlloc "t" $ Just (JSArray [])
1289 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1290 JSReturn (JSIdent "t")
1292 )) []
1294 where
1295 assignEntries :: [(Int, JS)] -> [JS]
1296 assignEntries entries =
1297 map (\(tag, fun) ->
1298 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1299 ) entries
1302 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1303 lookupEntry aux var alt = do
1304 tag <- getTag alt
1305 return (tag, caseFun aux var alt)
1308 jsDecl :: JS -> JS
1309 jsDecl = JSAlloc (path ++ translateName name) . Just
1312 jsFun body = jsFunAux [] body
1315 jsFunAux :: [(LVar, String)] -> JS -> JS
1316 jsFunAux aux body =
1317 JSFunction (p ++ map snd aux) (
1318 JSSeq $
1319 zipWith assignVar [0..] p ++
1320 map assignAux aux ++
1321 [JSReturn body]
1323 where
1324 assignVar :: Int -> String -> JS
1325 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1328 assignAux :: (LVar, String) -> JS
1329 assignAux (Loc var, val) =
1330 JSAlloc (jsVar var) (Just $ JSIdent val)
1333 p :: [String]
1334 p = map translateName params
1337translateVariableName :: LVar -> String
1338translateVariableName (Loc i) =
1339 jsVar i
1342translateExpression :: SExp -> JS
1343translateExpression (SLet name value body) =
1344 jsLet (translateVariableName name) (
1345 translateExpression value
1346 ) (translateExpression body)
1348translateExpression (SConst cst) =
1349 translateConstant cst
1351translateExpression (SV var) =
1352 JSVar var
1354translateExpression (SApp tc name vars)
1355 | False <- tc =
1356 jsTailcall $ translateFunctionCall name vars
1357 | True <- tc =
1358 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1359 JSReturn $ translateFunctionCall name vars
1360 )]
1361 where
1362 translateFunctionCall name vars =
1363 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1365translateExpression (SOp op vars)
1366 | LNoOp <- op = JSVar (last vars)
1368 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1369 | (LPlus (ATInt ITBig)) <- op
1370 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1371 | (LMinus (ATInt ITBig)) <- op
1372 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1373 | (LTimes (ATInt ITBig)) <- op
1374 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1375 | (LSDiv (ATInt ITBig)) <- op
1376 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1377 | (LSRem (ATInt ITBig)) <- op
1378 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1379 | (LEq (ATInt ITBig)) <- op
1380 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1381 | (LSLt (ATInt ITBig)) <- op
1382 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1383 | (LSLe (ATInt ITBig)) <- op
1384 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1385 | (LSGt (ATInt ITBig)) <- op
1386 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1387 | (LSGe (ATInt ITBig)) <- op
1388 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1390 | (LPlus ATFloat) <- op
1391 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1392 | (LMinus ATFloat) <- op
1393 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1394 | (LTimes ATFloat) <- op
1395 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1396 | (LSDiv ATFloat) <- op
1397 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1398 | (LEq ATFloat) <- op
1399 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1400 | (LSLt ATFloat) <- op
1401 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1402 | (LSLe ATFloat) <- op
1403 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1404 | (LSGt ATFloat) <- op
1405 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1406 | (LSGe ATFloat) <- op
1407 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1409 | (LPlus _) <- op
1410 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1411 | (LMinus _) <- op
1412 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1413 | (LTimes _) <- op
1414 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1415 | (LSDiv _) <- op
1416 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1417 | (LSRem _) <- op
1418 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1419 | (LEq _) <- op
1420 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1421 | (LSLt _) <- op
1422 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1423 | (LSLe _) <- op
1424 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1425 | (LSGt _) <- op
1426 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1427 | (LSGe _) <- op
1428 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1429 | (LAnd _) <- op
1430 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1431 | (LOr _) <- op
1432 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1433 | (LXOr _) <- op
1434 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1435 | (LSHL _) <- op
1436 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1437 | (LASHR _) <- op
1438 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1439 | (LCompl _) <- op
1440 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
1442 | LStrConcat <- op
1443 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1444 | LStrEq <- op
1445 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1446 | LStrLt <- op
1447 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1448 | LStrLen <- op
1449 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1451 | (LStrInt ITNative) <- op
1452 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1453 | (LIntStr ITNative) <- op
1454 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1455 | (LSExt ITNative ITBig) <- op
1456 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1457 | (LTrunc ITBig ITNative) <- op
1458 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1459 | (LIntStr ITBig) <- op
1460 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1461 | (LStrInt ITBig) <- op
1462 , (arg:_) <- vars = jsBigInt $ JSVar arg
1463 | LFloatStr <- op
1464 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1465 | LStrFloat <- op
1466 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1467 | (LIntFloat ITNative) <- op
1468 , (arg:_) <- vars = JSVar arg
1469 | (LFloatInt ITNative) <- op
1470 , (arg:_) <- vars = JSVar arg
1471 | (LChInt ITNative) <- op
1472 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1473 | (LIntCh ITNative) <- op
1474 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1476 | LFExp <- op
1477 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1478 | LFLog <- op
1479 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1480 | LFSin <- op
1481 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1482 | LFCos <- op
1483 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1484 | LFTan <- op
1485 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1486 | LFASin <- op
1487 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1488 | LFACos <- op
1489 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1490 | LFATan <- op
1491 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1492 | LFSqrt <- op
1493 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1494 | LFFloor <- op
1495 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1496 | LFCeil <- op
1497 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1499 | LStrCons <- op
1500 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1501 | LStrHead <- op
1502 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1503 | LStrRev <- op
1504 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1505 | LStrIndex <- op
1506 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1507 | LStrTail <- op
1508 , (arg:_) <- vars = let v = translateVariableName arg in
1509 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
1510 | LNullPtr <- op
1511 , (_) <- vars = JSNull
1513 where
1514 translateBinaryOp :: String -> LVar -> LVar -> JS
1515 translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)
1518 invokeMeth :: LVar -> String -> [LVar] -> JS
1519 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1521translateExpression (SError msg) =
1522 jsError msg
1524translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1525 jsCall (idrRTNamespace ++ "print") [JSVar var]
1527translateExpression (SForeign _ _ fun args) =
1528 ffi fun (map generateWrapper args)
1529 where
1530 generateWrapper (ffunc, name)
1531 | FFunction <- ffunc =
1532 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1533 | FFunctionIO <- ffunc =
1534 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1536 generateWrapper (_, name) =
1537 translateVariableName name
1539translateExpression patterncase
1540 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1541 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1542 where
1543 caseHelper var cases param =
1544 JSApp (JSFunction [param] (
1545 JSCond $ map (expandCase param . translateCaseCond param) cases
1546 )) [JSVar var]
1549 expandCase :: String -> (Cond, JS) -> (JS, JS)
1550 expandCase _ (RawCond cond, branch) = (cond, branch)
1551 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1552 expandCase var (CaseCond caseTy, branch)
1553 | ConCase tag <- caseTy =
1554 let checkCon = JSIdent var `jsInstanceOf` jsCon
1555 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1556 (checkCon `jsAnd` checkTag, branch)
1558 | TypeCase ty <- caseTy =
1559 let checkTy = JSIdent var `jsInstanceOf` jsType
1560 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1561 (checkTy `jsAnd` checkTag, branch)
1563translateExpression (SCon i name vars) =
1564 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1565 , JSArray $ map JSVar vars
1568translateExpression (SUpdate var@(Loc i) e) =
1569 JSAssign (JSVar var) (translateExpression e)
1571translateExpression (SProj var i) =
1572 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1574translateExpression SNothing = JSNull
1576translateExpression e =
1577 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1580data FFI = FFICode Char | FFIArg Int | FFIError String
1583ffi :: String -> [String] -> JS
1584ffi code args = let parsed = ffiParse code in
1585 case ffiError parsed of
1586 Just err -> jsError err
1587 Nothing -> JSRaw $ renderFFI parsed args
1588 where
1589 ffiParse :: String -> [FFI]
1590 ffiParse "" = []
1591 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1592 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1593 ffiParse ('%':s:ss)
1594 | isDigit s =
1595 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1596 | otherwise =
1597 [FFIError "Invalid positional argument"]
1598 ffiParse (s:ss) = FFICode s : ffiParse ss
1601 ffiError :: [FFI] -> Maybe String
1602 ffiError [] = Nothing
1603 ffiError ((FFIError s):xs) = Just s
1604 ffiError (x:xs) = ffiError xs
1607 renderFFI :: [FFI] -> [String] -> String
1608 renderFFI [] _ = ""
1609 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1610 renderFFI ((FFIArg i) : fs) args
1611 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1612 | otherwise = "Argument index out of bounds"
1615data CaseType = ConCase Int
1616 | TypeCase JSType
1617 | DefaultCase
1618 deriving Eq
1621data Cond = CaseCond CaseType
1622 | RawCond JS
1625translateCaseCond :: String -> SAlt -> (Cond, JS)
1626translateCaseCond _ cse@(SDefaultCase _) =
1627 (CaseCond DefaultCase, translateCase Nothing cse)
1629translateCaseCond var cse@(SConstCase ty _)
1630 | StrType <- ty = matchHelper JSStringTy
1631 | PtrType <- ty = matchHelper JSPtrTy
1632 | Forgot <- ty = matchHelper JSForgotTy
1633 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1634 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1635 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1636 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1637 where
1638 matchHelper :: JSType -> (Cond, JS)
1639 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1641translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1642 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1643 (RawCond cond, translateCase Nothing cse)
1645translateCaseCond var cse@(SConstCase cst _) =
1646 let cond = JSIdent var `jsEq` translateConstant cst in
1647 (RawCond cond, translateCase Nothing cse)
1649translateCaseCond var cse@(SConCase _ tag _ _ _) =
1650 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1653translateCase :: Maybe String -> SAlt -> JS
1654translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
1655translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
1656translateCase (Just var) (SConCase a _ _ vars e) =
1657 let params = map jsVar [a .. (a + length vars)] in
1658 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1659 JSThis, JSProj (JSIdent var) "vars"