git.iko.soy/Idris-dev
on 694832f help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1492 lines 48 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__"
27data JSTarget = Node | JavaScript deriving Eq
29data JSType = JSIntTy
30 | JSStringTy
31 | JSIntegerTy
32 | JSFloatTy
33 | JSCharTy
34 | JSPtrTy
35 | JSForgotTy
36 deriving Eq
38data JSInteger = JSBigZero
39 | JSBigOne
40 | JSBigInt Integer
41 deriving Eq
43data JSNum = JSInt Int
44 | JSFloat Double
45 | JSInteger JSInteger
46 deriving Eq
48data JS = JSRaw String
49 | JSIdent String
50 | JSFunction [String] JS
51 | JSType JSType
52 | JSSeq [JS]
53 | JSReturn JS
54 | JSApp JS [JS]
55 | JSNew String [JS]
56 | JSError String
57 | JSOp String JS JS
58 | JSProj JS String
59 | JSVar LVar
60 | JSNull
61 | JSThis
62 | JSTrue
63 | JSFalse
64 | JSArray [JS]
65 | JSObject [(String, JS)]
66 | JSString String
67 | JSChar String
68 | JSNum JSNum
69 | JSAssign JS JS
70 | JSAlloc String (Maybe JS)
71 | JSIndex JS JS
72 | JSCond [(JS, JS)]
73 | JSTernary JS JS JS
74 deriving Eq
76compileJS :: JS -> String
77compileJS (JSRaw code) =
78 code
80compileJS (JSIdent ident) =
81 ident
83compileJS (JSFunction args body) =
84 "function("
85 ++ intercalate "," args
86 ++ "){\n"
87 ++ compileJS body
88 ++ "\n}"
90compileJS (JSType ty)
91 | JSIntTy <- ty = idrRTNamespace ++ "Int"
92 | JSStringTy <- ty = idrRTNamespace ++ "String"
93 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
94 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
95 | JSCharTy <- ty = idrRTNamespace ++ "Char"
96 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
97 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
99compileJS (JSSeq seq) =
100 intercalate ";\n" (map compileJS seq)
102compileJS (JSReturn val) =
103 "return " ++ compileJS val
105compileJS (JSApp lhs rhs)
106 | JSFunction {} <- lhs =
107 concat ["(", compileJS lhs, ")(", args, ")"]
108 | otherwise =
109 concat [compileJS lhs, "(", args, ")"]
110 where args :: String
111 args = intercalate "," $ map compileJS rhs
113compileJS (JSNew name args) =
114 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
116compileJS (JSError exc) =
117 "(function(){throw '" ++ exc ++ "';})()"
119compileJS (JSOp op lhs rhs) =
120 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
122compileJS (JSProj obj field)
123 | JSFunction {} <- obj =
124 concat ["(", compileJS obj, ").", field]
125 | JSAssign {} <- obj =
126 concat ["(", compileJS obj, ").", field]
127 | otherwise =
128 compileJS obj ++ '.' : field
130compileJS (JSVar var) =
131 translateVariableName var
133compileJS JSNull =
134 "null"
136compileJS JSThis =
137 "this"
139compileJS JSTrue =
140 "true"
142compileJS JSFalse =
143 "false"
145compileJS (JSArray elems) =
146 "[" ++ intercalate "," (map compileJS elems) ++ "]"
148compileJS (JSObject fields) =
149 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
150 where
151 compileField :: (String, JS) -> String
152 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
154compileJS (JSString str) =
155 show str
157compileJS (JSChar chr) =
158 chr
160compileJS (JSNum num)
161 | JSInt i <- num = show i
162 | JSFloat f <- num = show f
163 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
164 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
165 | JSInteger (JSBigInt i) <- num = show i
167compileJS (JSAssign lhs rhs) =
168 compileJS lhs ++ "=" ++ compileJS rhs
170compileJS (JSAlloc name val) =
171 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
173compileJS (JSIndex lhs rhs) =
174 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
176compileJS (JSCond branches) =
177 intercalate " else " $ map createIfBlock (eliminateDeadBranches branches)
178 where
179 eliminateDeadBranches (e@(JSTrue, _):_) = [e]
180 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
181 eliminateDeadBranches [] = []
183 createIfBlock (JSTrue, e) =
184 "{\n"
185 ++ "return " ++ compileJS e
186 ++ ";\n}"
187 createIfBlock (cond, e) =
188 "if (" ++ compileJS cond ++") {\n"
189 ++ "return " ++ compileJS e
190 ++ ";\n}"
192compileJS (JSTernary cond true false) =
193 let c = compileJS cond
194 t = compileJS true
195 f = compileJS false in
196 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
198jsTailcall :: JS -> JS
199jsTailcall call =
200 jsCall (idrRTNamespace ++ "tailcall") [
201 JSFunction [] (JSReturn call)
202 ]
204jsCall :: String -> [JS] -> JS
205jsCall fun = JSApp (JSIdent fun)
207jsMeth :: JS -> String -> [JS] -> JS
208jsMeth obj meth =
209 JSApp (JSProj obj meth)
211jsInstanceOf :: JS -> JS -> JS
212jsInstanceOf = JSOp "instanceof"
214jsEq :: JS -> JS -> JS
215jsEq = JSOp "=="
217jsAnd :: JS -> JS -> JS
218jsAnd = JSOp "&&"
220jsType :: JS
221jsType = JSIdent $ idrRTNamespace ++ "Type"
223jsCon :: JS
224jsCon = JSIdent $ idrRTNamespace ++ "Con"
226jsTag :: JS -> JS
227jsTag obj = JSProj obj "tag"
229jsTypeTag :: JS -> JS
230jsTypeTag obj = JSProj obj "type"
232jsBigInt :: JS -> JS
233jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
234jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
235jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
237jsVar :: Int -> String
238jsVar = ("__var_" ++) . show
240jsLet :: String -> JS -> JS -> JS
241jsLet name value body =
242 JSApp (
243 JSFunction [name] (
244 JSReturn body
245 )
246 ) [value]
249jsSubst :: String -> JS -> JS -> JS
250jsSubst var new (JSVar old)
251 | var == translateVariableName old = new
252 | otherwise = JSVar old
254jsSubst var new (JSIdent old)
255 | var == old = new
256 | otherwise = JSIdent old
258jsSubst var new (JSArray fields) =
259 JSArray (map (jsSubst var new) fields)
261jsSubst var new (JSNew con vals) =
262 JSNew con $ map (jsSubst var new) vals
264jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
265 | var `notElem` args =
266 JSApp (JSProj (JSFunction args (jsSubst var new body)) "apply") (
267 map (jsSubst var new) vals
268 )
269 | otherwise =
270 JSApp (JSProj (JSFunction args body) "apply") (
271 map (jsSubst var new) vals
272 )
274jsSubst var new (JSApp (JSFunction [arg] body) vals)
275 | var /= arg =
276 JSApp (JSFunction [arg] (
277 jsSubst var new body
278 )) $ map (jsSubst var new) vals
279 | otherwise =
280 JSApp (JSFunction [arg] (
281 body
282 )) $ map (jsSubst var new) vals
284jsSubst var new (JSApp lhs rhs) =
285 JSApp (jsSubst var new lhs) (map (jsSubst var new) rhs)
287jsSubst var new (JSFunction [] body) =
288 JSFunction [] (jsSubst var new body)
290jsSubst var new (JSReturn ret) =
291 JSReturn $ jsSubst var new ret
293jsSubst var new (JSProj obj field) =
294 JSProj (jsSubst var new obj) field
296jsSubst var new (JSSeq body) =
297 JSSeq $ map (jsSubst var new) body
299jsSubst var new (JSOp op lhs rhs) =
300 JSOp op (jsSubst var new lhs) (jsSubst var new rhs)
302jsSubst var new (JSIndex obj field) =
303 JSIndex (jsSubst var new obj) (jsSubst var new field)
305jsSubst var new (JSCond conds) =
306 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)
308jsSubst var new (JSAssign lhs rhs) =
309 JSAssign (jsSubst var new lhs) (jsSubst var new rhs)
311jsSubst var new (JSAlloc val (Just js)) =
312 JSAlloc val (Just (jsSubst var new js))
314jsSubst _ _ js = js
317removeAllocations :: JS -> JS
318removeAllocations (JSSeq body) =
319 let opt = removeHelper (map removeAllocations body) in
320 case opt of
321 [ret] -> ret
322 _ -> JSSeq opt
323 where
324 removeHelper :: [JS] -> [JS]
325 removeHelper [js] = [js]
326 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
327 map (jsSubst name val) (removeHelper js)
328 removeHelper (j:js) = j : removeHelper js
330removeAllocations (JSFunction args body) =
331 JSFunction args $ removeAllocations body
333removeAllocations (JSReturn ret) =
334 JSReturn $ removeAllocations ret
336removeAllocations (JSApp fun args) =
337 JSApp (removeAllocations fun) (map removeAllocations args)
339removeAllocations (JSNew con args) =
340 JSNew con $ map removeAllocations args
342removeAllocations (JSOp op lhs rhs) =
343 JSOp op (removeAllocations lhs) (removeAllocations rhs)
345removeAllocations (JSProj obj field) =
346 JSProj (removeAllocations obj) field
348removeAllocations (JSArray vals) =
349 JSArray $ map removeAllocations vals
351removeAllocations (JSAssign lhs rhs) =
352 JSAssign (removeAllocations lhs) (removeAllocations rhs)
354removeAllocations (JSAlloc name (Just val)) =
355 JSAlloc name $ Just (removeAllocations val)
357removeAllocations (JSIndex val idx) =
358 JSIndex (removeAllocations val) (removeAllocations idx)
360removeAllocations (JSCond conds) =
361 JSCond $ map (removeAllocations *** removeAllocations) conds
363removeAllocations (JSTernary c t f) =
364 JSTernary (removeAllocations c) (removeAllocations t) (removeAllocations f)
366removeAllocations js = js
369isJSConstant :: JS -> Bool
370isJSConstant js
371 | JSString _ <- js = True
372 | JSChar _ <- js = True
373 | JSNum _ <- js = True
374 | JSType _ <- js = True
376 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
377 | otherwise = False
379inlineJS :: JS -> JS
380inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
381 inlineJS $ jsSubst "cse" val body
383inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
384 JSSeq [ JSAlloc arg (Just (inlineJS val))
385 , inlineJS cond
386 ]
388inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
389 JSThis,JSProj var "vars"
390 ])
391 | var /= JSIdent "cse" =
392 inlineApply args body 0
393 where
394 inlineApply [] body _ = inlineJS body
395 inlineApply (a:as) body n =
396 inlineApply as (
397 jsSubst a (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
398 ) (n + 1)
400inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
401 | isJSConstant val = val
403inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
404 JSFunction [] (JSReturn val)
405 ])
406 | isJSConstant val = val
408inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
409 | JSNew con [tag, vals] <- ret
410 , opt <- inlineJS val =
411 JSNew con [tag, jsSubst arg opt vals]
413 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
414 , opt <- inlineJS val =
415 JSNew con [JSFunction [] (
416 JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) vars)
417 )]
419 | JSApp (JSProj obj field) args <- ret
420 , opt <- inlineJS val =
421 JSApp (JSProj (jsSubst arg opt obj) field) $ map (jsSubst arg opt) args
423 | JSIndex (JSProj obj field) idx <- ret
424 , opt <- inlineJS val =
425 JSIndex (JSProj (
426 jsSubst arg opt obj
427 ) field
428 ) (jsSubst arg opt idx)
430 | JSOp op lhs rhs <- ret
431 , opt <- inlineJS val =
432 JSOp op (jsSubst arg opt lhs) $
433 (jsSubst arg opt rhs)
435 | JSApp (JSIdent fun) args <- ret
436 , opt <- inlineJS val =
437 JSApp (JSIdent fun) $ map (jsSubst arg opt) args
439inlineJS (JSApp fun args) =
440 JSApp (inlineJS fun) (map inlineJS args)
442inlineJS (JSNew con args) =
443 JSNew con $ map inlineJS args
445inlineJS (JSArray fields) =
446 JSArray (map inlineJS fields)
448inlineJS (JSAssign lhs rhs) =
449 JSAssign (inlineJS lhs) (inlineJS rhs)
451inlineJS (JSSeq seq) =
452 JSSeq (map inlineJS seq)
454inlineJS (JSFunction args body) =
455 JSFunction args (inlineJS body)
457inlineJS (JSProj (JSFunction args body) field) =
458 JSProj (JSFunction args (inlineJS body)) field
460inlineJS (JSReturn js) =
461 JSReturn $ inlineJS js
463inlineJS (JSAlloc name (Just js)) =
464 JSAlloc name (Just $ inlineJS js)
466inlineJS (JSCond cases) =
467 JSCond (map (second inlineJS) cases)
469inlineJS (JSObject fields) =
470 JSObject (map (second inlineJS) fields)
472inlineJS (JSOp op lhs rhs) =
473 JSOp op (inlineJS lhs) (inlineJS rhs)
475inlineJS js = js
477reduceJS :: [JS] -> [JS]
478reduceJS js = reduceLoop [] ([], js)
480funName :: JS -> String
481funName (JSAlloc fun _) = fun
484deadEvalApplyCases :: [JS] -> [JS]
485deadEvalApplyCases js =
486 let tags = sort $ nub $ concatMap (getTags) js in
487 map (removeHelper tags) js
488 where
489 getTags :: JS -> [Int]
490 getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), args]) =
491 tag : getTags args
493 getTags (JSNew _ args) = concatMap getTags args
495 getTags (JSFunction _ body) = getTags body
497 getTags (JSReturn ret) = getTags ret
499 getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
501 getTags (JSSeq seq) = concatMap getTags seq
503 getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
505 getTags (JSProj obj _) = getTags obj
507 getTags (JSArray vals) = concatMap getTags vals
509 getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
511 getTags (JSAlloc _ (Just val)) = getTags val
513 getTags (JSCond conds) =
514 concatMap (uncurry (++)) $ map (getTags *** getTags) conds
516 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
518 getTags js = []
519 removeHelper :: [Int] -> JS -> JS
520 removeHelper tags (JSAlloc fun (Just (
521 JSApp (JSFunction [] (JSSeq seq)) []))
522 ) =
523 (JSAlloc fun (Just (
524 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
525 )
527 removeHelper _ js = js
529 remover :: [Int] -> [JS] -> [JS]
530 remover tags (
531 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
532 )
533 | tag `notElem` tags = remover tags js
535 remover tags (j:js) = j : remover tags js
536 remover _ [] = []
539initConstructors :: [JS] -> [JS]
540initConstructors js =
541 let tags = nub $ sort $ concat (map getTags js) in
542 map createConstant tags ++ replaceConstructors tags js
543 where
544 getTags :: JS -> [Int]
545 getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]
547 getTags (JSNew _ args) = concatMap getTags args
549 getTags (JSFunction _ body) = getTags body
551 getTags (JSReturn ret) = getTags ret
553 getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
555 getTags (JSSeq seq) = concatMap getTags seq
557 getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
559 getTags (JSProj obj _) = getTags obj
561 getTags (JSArray vals) = concatMap getTags vals
563 getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
565 getTags (JSAlloc _ (Just val)) = getTags val
567 getTags (JSCond conds) =
568 concatMap (uncurry (++)) $ map (getTags *** getTags) conds
570 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
572 getTags js = []
574 replaceConstructors :: [Int] -> [JS] -> [JS]
575 replaceConstructors tags js = map (replaceHelper tags) js
576 where
577 replaceHelper :: [Int] -> JS -> JS
578 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
579 | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)
581 replaceHelper tags (JSNew con args) =
582 JSNew con $ map (replaceHelper tags) args
584 replaceHelper tags (JSFunction fun body) =
585 JSFunction fun (replaceHelper tags body)
587 replaceHelper tags (JSReturn ret) =
588 JSReturn (replaceHelper tags ret)
590 replaceHelper tags (JSApp lhs rhs) =
591 JSApp (replaceHelper tags lhs) (map (replaceHelper tags) rhs)
593 replaceHelper tags (JSSeq seq) =
594 JSSeq $ map (replaceHelper tags) seq
596 replaceHelper tags (JSOp op lhs rhs) =
597 JSOp op (replaceHelper tags lhs) (replaceHelper tags rhs)
599 replaceHelper tags (JSProj obj field) =
600 JSProj (replaceHelper tags obj) field
602 replaceHelper tags (JSArray vals) =
603 JSArray $ map (replaceHelper tags) vals
605 replaceHelper tags (JSAssign lhs rhs) =
606 JSAssign (replaceHelper tags lhs) (replaceHelper tags rhs)
608 replaceHelper tags (JSAlloc var (Just val)) =
609 JSAlloc var $ Just (replaceHelper tags val)
611 replaceHelper tags (JSCond conds) =
612 JSCond (map ((replaceHelper tags) *** (replaceHelper tags)) conds)
614 replaceHelper tags (JSTernary c t f) =
615 JSTernary (replaceHelper tags c) (
616 replaceHelper tags t
617 ) (
618 replaceHelper tags f
619 )
621 replaceHelper tags js = js
623 createConstant :: Int -> JS
624 createConstant tag =
625 JSAlloc ("__IDRCTR__" ++ show tag) (Just (
626 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
627 ))
629removeIDs :: [JS] -> [JS]
630removeIDs js =
631 case partition isID js of
632 ([], rest) -> rest
633 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
634 where isID :: JS -> Bool
635 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
636 | JSReturn (JSVar _) <- last body = True
638 isID _ = False
640 idFor :: JS -> (String, Int)
641 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
642 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
644 removeIDCall :: [(String, Int)] -> JS -> JS
645 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
646 JSReturn (JSApp (JSIdent fun) args)
647 )])
648 | Just pos <- lookup fun ids
649 , pos < length args = args !! pos
651 removeIDCall ids (JSNew _ [JSFunction [] (
652 JSReturn (JSApp (JSIdent fun) args)
653 )])
654 | Just pos <- lookup fun ids
655 , pos < length args = args !! pos
657 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
658 | Just pos <- lookup fun ids
659 , pos < length args = args !! pos
661 removeIDCall ids (JSAlloc fun (Just body)) =
662 JSAlloc fun (Just $ removeIDCall ids body)
664 removeIDCall ids (JSReturn js) =
665 JSReturn $ removeIDCall ids js
667 removeIDCall ids (JSSeq js) =
668 JSSeq $ map (removeIDCall ids) js
670 removeIDCall ids (JSNew con args) =
671 JSNew con $ map (removeIDCall ids) args
673 removeIDCall ids (JSFunction args body) =
674 JSFunction args $ removeIDCall ids body
676 removeIDCall ids (JSApp fun args) =
677 JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args
679 removeIDCall ids (JSProj obj field) =
680 JSProj (removeIDCall ids obj) field
682 removeIDCall ids (JSCond conds) =
683 JSCond $ map (removeIDCall ids *** removeIDCall ids) conds
685 removeIDCall ids (JSAssign lhs rhs) =
686 JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs)
688 removeIDCall ids (JSArray fields) =
689 JSArray $ map (removeIDCall ids) fields
691 removeIDCall _ js = js
693inlineFunctions :: [JS] -> [JS]
694inlineFunctions js =
695 let funs = collectFunctions js
696 occurences = map ((id . fst) &&& countAll js) funs in
697 removeDeadFunctions occurences js
698 where
699 removeDeadFunctions :: [(String, (Int, JS))] -> [JS] -> [JS]
700 removeDeadFunctions _ [] = []
701 removeDeadFunctions funOccur ((JSAlloc fun (Just (JSFunction _ _))):js)
702 | Just (o, _) <- lookup fun funOccur
703 , o == 0 = removeDeadFunctions funOccur js
705 removeDeadFunctions funOccur (j:js) = j : removeDeadFunctions funOccur js
708 collectFunctions :: [JS] -> [(String, JS)]
709 collectFunctions js =
710 catMaybes $ map collectHelper js
713 collectHelper :: JS -> Maybe (String, JS)
714 collectHelper (JSAlloc fun (Just js@(JSFunction _ body)))
715 | fun /= "main" && nonRecur fun body = Just (fun, js)
716 collectHelper _ = Nothing
719 nonRecur :: String -> JS -> Bool
720 nonRecur name body = countInvokations name body == 0
723 countAll :: [JS] -> (String, JS) -> (Int, JS)
724 countAll js (name, fun) = (sum $ map (countInvokations name) js, fun)
727 countInvokations :: String -> JS -> Int
728 countInvokations name (JSApp (JSIdent ident) args)
729 | name == ident = 1 + (sum $ map (countInvokations name) args)
730 | otherwise = sum $ map (countInvokations name) args
732 countInvokations name (JSApp lhs rhs) =
733 countInvokations name lhs + (sum $ map (countInvokations name) rhs)
735 countInvokations name (JSFunction _ body) =
736 countInvokations name body
738 countInvokations name (JSSeq seq) =
739 sum $ map (countInvokations name) seq
741 countInvokations name (JSReturn ret) =
742 countInvokations name ret
744 countInvokations name (JSNew _ args) =
745 sum $ map (countInvokations name) args
747 countInvokations name (JSOp _ lhs rhs) =
748 countInvokations name lhs + countInvokations name rhs
750 countInvokations name (JSProj obj _) =
751 countInvokations name obj
753 countInvokations name (JSArray vals) =
754 sum $ map (countInvokations name) vals
756 countInvokations name (JSAssign _ rhs) =
757 countInvokations name rhs
759 countInvokations name (JSAlloc _ (Just js)) =
760 countInvokations name js
762 countInvokations name (JSIndex lhs rhs) =
763 countInvokations name lhs + countInvokations name rhs
765 countInvokations name (JSCond conds) =
766 sum $ map (uncurry (+)) (
767 map (countInvokations name *** countInvokations name) conds
768 )
770 countInvokations name (JSTernary c t f) =
771 sum $ [ countInvokations name c
772 , countInvokations name t
773 , countInvokations name f
774 ]
776 countInvokations _ _ = 0
779reduceConstant :: JS -> JS
780reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
781 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
782 )]) = JSNum num
784reduceConstant (JSReturn ret) =
785 JSReturn (reduceConstant ret)
787reduceConstant (JSApp fun args) =
788 JSApp (reduceConstant fun) (map reduceConstant args)
790reduceConstant (JSArray fields) =
791 JSArray (map reduceConstant fields)
793reduceConstant (JSAlloc name (Just val)) =
794 JSAlloc name $ Just (reduceConstant val)
796reduceConstant (JSNew con args) =
797 JSNew con (map reduceConstant args)
799reduceConstant (JSProj obj field) =
800 JSProj (reduceConstant obj) field
802reduceConstant (JSCond conds) =
803 JSCond $ map (reduceConstant *** reduceConstant) conds
805reduceConstant (JSSeq seq) =
806 JSSeq $ map reduceConstant seq
808reduceConstant (JSFunction args body) =
809 JSFunction args (reduceConstant body)
811reduceConstant js = js
813reduceConstants :: JS -> JS
814reduceConstants js
815 | ret <- reduceConstant js
816 , ret /= js = reduceConstants ret
817 | otherwise = js
819reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
820reduceLoop reduced (cons, program) =
821 case partition findConstructors program of
822 ([], js) -> cons ++ js
823 (candidates, rest) ->
824 let names = reduced ++ map funName candidates in
825 reduceLoop names (
826 cons ++ map reduce candidates, map (reduceCall names) rest
827 )
828 where findConstructors :: JS -> Bool
829 findConstructors js
830 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
831 reducable $ last body
832 | otherwise = False
833 where reducable :: JS -> Bool
834 reducable (JSReturn js) = reducable js
835 reducable (JSNew _ args) = and $ map reducable args
836 reducable (JSArray fields) = and $ map reducable fields
837 reducable (JSNum _) = True
838 reducable JSNull = True
839 reducable (JSIdent _) = True
840 reducable _ = False
842 reduce :: JS -> JS
843 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
844 | JSReturn js <- last body = (JSAlloc fun (Just js))
846 reduce js = js
848 reduceCall :: [String] -> JS -> JS
849 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
850 JSReturn (JSApp id@(JSIdent ret) _)
851 )])
852 | ret `elem` funs = id
854 reduceCall funs js@(JSApp id@(JSIdent fun) _)
855 | fun `elem` funs = id
857 reduceCall funs (JSAlloc fun (Just body)) =
858 JSAlloc fun (Just $ reduceCall funs body)
860 reduceCall funs (JSReturn js) =
861 JSReturn $ reduceCall funs js
863 reduceCall funs (JSSeq js) =
864 JSSeq $ map (reduceCall funs) js
866 reduceCall funs (JSNew con args) =
867 JSNew con $ map (reduceCall funs) args
869 reduceCall funs (JSFunction args body) =
870 JSFunction args $ reduceCall funs body
872 reduceCall funs (JSApp fun args) =
873 JSApp (reduceCall funs fun) $ map (reduceCall funs) args
875 reduceCall funs (JSProj obj field) =
876 JSProj (reduceCall funs obj) field
878 reduceCall funs (JSIndex obj idx) =
879 JSIndex (reduceCall funs obj) (reduceCall funs idx)
881 reduceCall funs (JSOp op rhs lhs) =
882 JSOp op (reduceCall funs rhs) (reduceCall funs lhs)
884 reduceCall funs (JSCond conds) =
885 JSCond $ map (reduceCall funs *** reduceCall funs) conds
887 reduceCall funs (JSAssign lhs rhs) =
888 JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
890 reduceCall funs (JSArray fields) =
891 JSArray $ map (reduceCall funs) fields
893 reduceCall _ js = js
895optimizeJS :: JS -> JS
896optimizeJS = inlineLoop
897 where inlineLoop :: JS -> JS
898 inlineLoop js
899 | opt <- inlineJS js
900 , opt /= js = inlineLoop opt
901 | otherwise = js
903codegenJavaScript
904 :: JSTarget
905 -> [(Name, SDecl)]
906 -> FilePath
907 -> OutputType
908 -> IO ()
909codegenJavaScript target definitions filename outputType = do
910 let (header, runtime) = case target of
911 Node ->
912 ("#!/usr/bin/env node\n", "-node")
913 JavaScript ->
914 ("", "-browser")
915 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
916 idrRuntime <- readFile $ path ++ "Runtime-common.js"
917 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
918 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
919 writeFile filename $ header ++ (
920 intercalate "\n" $ [ jsbn
921 , idrRuntime
922 , tgtRuntime
923 ] ++ functions
924 )
926 setPermissions filename (emptyPermissions { readable = True
927 , executable = target == Node
928 , writable = True
929 })
930 where
931 def :: [(String, SDecl)]
932 def = map (first translateNamespace) definitions
934 functions :: [String]
935 functions =
936 let translated =
937 concatMap translateDeclaration def ++ [mainLoop, invokeLoop]
939 optimized = map optimizeJS translated
940 idsRemoved = removeIDs optimized
941 reduced = reduceJS idsRemoved
942 constRemoved = map reduceConstants reduced
943 constrInit = initConstructors constRemoved
944 removeAlloc = map removeAllocations constrInit
945 deadElim = deadEvalApplyCases removeAlloc
946 js = inlineFunctions deadElim in
947 map compileJS js
949 mainLoop :: JS
950 mainLoop =
951 JSAlloc "main" $ Just $ JSFunction [] (
952 case target of
953 Node -> mainFun
954 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
955 JSString "DOMContentLoaded", JSFunction [] (
956 mainFun
957 ), JSFalse
958 ]
959 )
960 where
961 mainFun :: JS
962 mainFun = jsTailcall $ jsCall runMain []
964 runMain :: String
965 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
967 invokeLoop :: JS
968 invokeLoop = jsCall "main" []
970translateIdentifier :: String -> String
971translateIdentifier =
972 replaceReserved . concatMap replaceBadChars
973 where replaceBadChars :: Char -> String
974 replaceBadChars c
975 | ' ' <- c = "_"
976 | '_' <- c = "__"
977 | isDigit c = '_' : show (ord c)
978 | not (isLetter c && isAscii c) = '_' : show (ord c)
979 | otherwise = [c]
980 replaceReserved s
981 | s `elem` reserved = '_' : s
982 | otherwise = s
983 reserved = [ "break"
984 , "case"
985 , "catch"
986 , "continue"
987 , "debugger"
988 , "default"
989 , "delete"
990 , "do"
991 , "else"
992 , "finally"
993 , "for"
994 , "function"
995 , "if"
996 , "in"
997 , "instanceof"
998 , "new"
999 , "return"
1000 , "switch"
1001 , "this"
1002 , "throw"
1003 , "try"
1004 , "typeof"
1005 , "var"
1006 , "void"
1007 , "while"
1008 , "with"
1010 , "class"
1011 , "enum"
1012 , "export"
1013 , "extends"
1014 , "import"
1015 , "super"
1017 , "implements"
1018 , "interface"
1019 , "let"
1020 , "package"
1021 , "private"
1022 , "protected"
1023 , "public"
1024 , "static"
1025 , "yield"
1028translateNamespace :: Name -> String
1029translateNamespace (UN _) = idrNamespace
1030translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1031translateNamespace (MN _ _) = idrNamespace
1032translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1033translateNamespace NErased = idrNamespace
1035translateName :: Name -> String
1036translateName (UN name) = 'u' : translateIdentifier (str name)
1037translateName (NS name _) = 'n' : translateName name
1038translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1039translateName (SN name) = 's' : translateSpecialName name
1040translateName NErased = "e"
1042translateSpecialName :: SpecialName -> String
1043translateSpecialName name
1044 | WhereN i m n <- name =
1045 'w' : translateName m ++ translateName n ++ show i
1046 | InstanceN n s <- name =
1047 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1048 | ParentN n s <- name =
1049 'p' : translateName n ++ translateIdentifier (str s)
1050 | MethodN n <- name =
1051 'm' : translateName n
1052 | CaseN n <- name =
1053 'c' : translateName n
1055translateConstant :: Const -> JS
1056translateConstant (I i) = JSNum (JSInt i)
1057translateConstant (Fl f) = JSNum (JSFloat f)
1058translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
1059translateConstant (Ch '\a') = JSChar "'\\u0007'"
1060translateConstant (Ch '\SO') = JSChar "'\\u000E'"
1061translateConstant (Ch c) = JSString [c]
1062translateConstant (Str s) = JSString s
1063translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1064translateConstant StrType = JSType JSStringTy
1065translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1066translateConstant (AType ATFloat) = JSType JSFloatTy
1067translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1068translateConstant PtrType = JSType JSPtrTy
1069translateConstant Forgot = JSType JSForgotTy
1070translateConstant (BI i) = jsBigInt $ JSString (show i)
1071translateConstant c =
1072 JSError $ "Unimplemented Constant: " ++ show c
1074translateDeclaration :: (String, SDecl) -> [JS]
1075translateDeclaration (path, SFun name params stackSize body)
1076 | (MN _ ap) <- name
1077 , (SLet var val next) <- body
1078 , (SChkCase cvar cases) <- next
1079 , ap == txt "APPLY" =
1080 let lvar = translateVariableName var
1081 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
1082 [ lookupTable [(var, "chk")] var cases
1083 , jsDecl $ JSFunction ["fn0", "arg0"] (
1084 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1085 , JSAlloc (translateVariableName var) (
1086 Just $ translateExpression val
1088 , JSReturn $ (JSTernary (
1089 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1090 (hasProp lookupTableName (translateVariableName var))
1091 ) (JSIdent $
1092 lookupTableName ++ lookup
1093 ) JSNull
1099 | (MN _ ev) <- name
1100 , (SChkCase var cases) <- body
1101 , ev == txt "EVAL" =
1102 [ lookupTable [] var cases
1103 , jsDecl $ JSFunction ["arg0"] (JSReturn $
1104 JSTernary (
1105 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1106 (hasProp lookupTableName "arg0")
1107 ) (JSApp
1108 (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
1109 [JSIdent "arg0"]
1110 ) (JSIdent "arg0")
1113 | otherwise =
1114 let fun = translateExpression body in
1115 [jsDecl $ jsFun fun]
1117 where
1118 hasProp :: String -> String -> JS
1119 hasProp table var =
1120 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1122 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1123 caseFun aux var cse =
1124 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
1126 getTag :: SAlt -> Maybe Int
1127 getTag (SConCase _ tag _ _ _) = Just tag
1128 getTag _ = Nothing
1130 lookupTableName :: String
1131 lookupTableName = idrLTNamespace ++ translateName name
1133 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
1134 lookupTable aux var cases =
1135 JSAlloc lookupTableName $ Just (
1136 JSApp (JSFunction [] (
1137 JSSeq $ [
1138 JSAlloc "t" $ Just (JSArray [])
1139 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1140 JSReturn (JSIdent "t")
1142 )) []
1144 where
1145 assignEntries :: [(Int, JS)] -> [JS]
1146 assignEntries entries =
1147 map (\(tag, fun) ->
1148 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1149 ) entries
1151 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1152 lookupEntry aux var alt = do
1153 tag <- getTag alt
1154 return (tag, caseFun aux var alt)
1156 jsDecl :: JS -> JS
1157 jsDecl = JSAlloc (path ++ translateName name) . Just
1159 jsFun body = jsFunAux [] body
1161 jsFunAux :: [(LVar, String)] -> JS -> JS
1162 jsFunAux aux body =
1163 JSFunction (p ++ map snd aux) (
1164 JSSeq $
1165 zipWith assignVar [0..] p ++
1166 map assignAux aux ++
1167 [JSReturn body]
1169 where
1170 assignVar :: Int -> String -> JS
1171 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1173 assignAux :: (LVar, String) -> JS
1174 assignAux (Loc var, val) =
1175 JSAlloc (jsVar var) (Just $ JSIdent val)
1177 p :: [String]
1178 p = map translateName params
1180translateVariableName :: LVar -> String
1181translateVariableName (Loc i) =
1182 jsVar i
1184translateExpression :: SExp -> JS
1185translateExpression (SLet name value body) =
1186 jsLet (translateVariableName name) (
1187 translateExpression value
1188 ) (translateExpression body)
1190translateExpression (SConst cst) =
1191 translateConstant cst
1193translateExpression (SV var) =
1194 JSVar var
1196translateExpression (SApp tc name vars)
1197 | False <- tc =
1198 jsTailcall $ translateFunctionCall name vars
1199 | True <- tc =
1200 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1201 JSReturn $ translateFunctionCall name vars
1202 )]
1203 where
1204 translateFunctionCall name vars =
1205 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1207translateExpression (SOp op vars)
1208 | LNoOp <- op = JSVar (last vars)
1210 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1211 | (LPlus (ATInt ITBig)) <- op
1212 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1213 | (LMinus (ATInt ITBig)) <- op
1214 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1215 | (LTimes (ATInt ITBig)) <- op
1216 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1217 | (LSDiv (ATInt ITBig)) <- op
1218 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1219 | (LSRem (ATInt ITBig)) <- op
1220 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1221 | (LEq (ATInt ITBig)) <- op
1222 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1223 | (LSLt (ATInt ITBig)) <- op
1224 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1225 | (LSLe (ATInt ITBig)) <- op
1226 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1227 | (LSGt (ATInt ITBig)) <- op
1228 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1229 | (LSGe (ATInt ITBig)) <- op
1230 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1232 | (LPlus ATFloat) <- op
1233 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1234 | (LMinus ATFloat) <- op
1235 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1236 | (LTimes ATFloat) <- op
1237 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1238 | (LSDiv ATFloat) <- op
1239 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1240 | (LEq ATFloat) <- op
1241 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1242 | (LSLt ATFloat) <- op
1243 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1244 | (LSLe ATFloat) <- op
1245 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1246 | (LSGt ATFloat) <- op
1247 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1248 | (LSGe ATFloat) <- op
1249 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1251 | (LPlus _) <- op
1252 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1253 | (LMinus _) <- op
1254 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1255 | (LTimes _) <- op
1256 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1257 | (LSDiv _) <- op
1258 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1259 | (LSRem _) <- op
1260 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1261 | (LEq _) <- op
1262 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1263 | (LSLt _) <- op
1264 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1265 | (LSLe _) <- op
1266 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1267 | (LSGt _) <- op
1268 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1269 | (LSGe _) <- op
1270 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1271 | (LAnd _) <- op
1272 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1273 | (LOr _) <- op
1274 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1275 | (LXOr _) <- op
1276 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1277 | (LSHL _) <- op
1278 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1279 | (LASHR _) <- op
1280 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1281 | (LCompl _) <- op
1282 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
1284 | LStrConcat <- op
1285 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1286 | LStrEq <- op
1287 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1288 | LStrLt <- op
1289 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1290 | LStrLen <- op
1291 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1293 | (LStrInt ITNative) <- op
1294 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1295 | (LIntStr ITNative) <- op
1296 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1297 | (LSExt ITNative ITBig) <- op
1298 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1299 | (LTrunc ITBig ITNative) <- op
1300 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1301 | (LIntStr ITBig) <- op
1302 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1303 | (LStrInt ITBig) <- op
1304 , (arg:_) <- vars = jsBigInt $ JSVar arg
1305 | LFloatStr <- op
1306 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1307 | LStrFloat <- op
1308 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1309 | (LIntFloat ITNative) <- op
1310 , (arg:_) <- vars = JSVar arg
1311 | (LFloatInt ITNative) <- op
1312 , (arg:_) <- vars = JSVar arg
1313 | (LChInt ITNative) <- op
1314 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1315 | (LIntCh ITNative) <- op
1316 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1318 | LFExp <- op
1319 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1320 | LFLog <- op
1321 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1322 | LFSin <- op
1323 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1324 | LFCos <- op
1325 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1326 | LFTan <- op
1327 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1328 | LFASin <- op
1329 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1330 | LFACos <- op
1331 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1332 | LFATan <- op
1333 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1334 | LFSqrt <- op
1335 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1336 | LFFloor <- op
1337 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1338 | LFCeil <- op
1339 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1341 | LStrCons <- op
1342 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1343 | LStrHead <- op
1344 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1345 | LStrRev <- op
1346 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1347 | LStrIndex <- op
1348 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1349 | LStrTail <- op
1350 , (arg:_) <- vars = let v = translateVariableName arg in
1351 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
1352 | LNullPtr <- op
1353 , (_) <- vars = JSNull
1355 where
1356 translateBinaryOp :: String -> LVar -> LVar -> JS
1357 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
1359 invokeMeth :: LVar -> String -> [LVar] -> JS
1360 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1362translateExpression (SError msg) =
1363 JSError msg
1365translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1366 jsCall (idrRTNamespace ++ "print") [JSVar var]
1368translateExpression (SForeign _ _ fun args) =
1369 ffi fun (map generateWrapper args)
1370 where
1371 generateWrapper (ffunc, name)
1372 | FFunction <- ffunc =
1373 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1374 | FFunctionIO <- ffunc =
1375 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1377 generateWrapper (_, name) =
1378 translateVariableName name
1380translateExpression patterncase
1381 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1382 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1383 where
1384 caseHelper var cases param =
1385 JSApp (JSFunction [param] (
1386 JSCond $ map (expandCase param . translateCaseCond param) cases
1387 )) [JSVar var]
1389 expandCase :: String -> (Cond, JS) -> (JS, JS)
1390 expandCase _ (RawCond cond, branch) = (cond, branch)
1391 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1392 expandCase var (CaseCond caseTy, branch)
1393 | ConCase tag <- caseTy =
1394 let checkCon = JSIdent var `jsInstanceOf` jsCon
1395 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1396 (checkCon `jsAnd` checkTag, branch)
1398 | TypeCase ty <- caseTy =
1399 let checkTy = JSIdent var `jsInstanceOf` jsType
1400 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1401 (checkTy `jsAnd` checkTag, branch)
1403translateExpression (SCon i name vars) =
1404 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1405 , JSArray $ map JSVar vars
1408translateExpression (SUpdate var@(Loc i) e) =
1409 JSAssign (JSVar var) (translateExpression e)
1411translateExpression (SProj var i) =
1412 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1414translateExpression SNothing = JSNull
1416translateExpression e =
1417 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1419data FFI = FFICode Char | FFIArg Int | FFIError String
1421ffi :: String -> [String] -> JS
1422ffi code args = let parsed = ffiParse code in
1423 case ffiError parsed of
1424 Just err -> JSError err
1425 Nothing -> JSRaw $ renderFFI parsed args
1426 where
1427 ffiParse :: String -> [FFI]
1428 ffiParse "" = []
1429 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1430 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1431 ffiParse ('%':s:ss)
1432 | isDigit s =
1433 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1434 | otherwise =
1435 [FFIError "Invalid positional argument"]
1436 ffiParse (s:ss) = FFICode s : ffiParse ss
1438 ffiError :: [FFI] -> Maybe String
1439 ffiError [] = Nothing
1440 ffiError ((FFIError s):xs) = Just s
1441 ffiError (x:xs) = ffiError xs
1443 renderFFI :: [FFI] -> [String] -> String
1444 renderFFI [] _ = ""
1445 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1446 renderFFI ((FFIArg i) : fs) args
1447 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1448 | otherwise = "Argument index out of bounds"
1450data CaseType = ConCase Int
1451 | TypeCase JSType
1452 | DefaultCase
1453 deriving Eq
1455data Cond = CaseCond CaseType
1456 | RawCond JS
1458translateCaseCond :: String -> SAlt -> (Cond, JS)
1459translateCaseCond _ cse@(SDefaultCase _) =
1460 (CaseCond DefaultCase, translateCase Nothing cse)
1462translateCaseCond var cse@(SConstCase ty _)
1463 | StrType <- ty = matchHelper JSStringTy
1464 | PtrType <- ty = matchHelper JSPtrTy
1465 | Forgot <- ty = matchHelper JSForgotTy
1466 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1467 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1468 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1469 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1470 where
1471 matchHelper :: JSType -> (Cond, JS)
1472 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1474translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1475 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1476 (RawCond cond, translateCase Nothing cse)
1478translateCaseCond var cse@(SConstCase cst _) =
1479 let cond = JSIdent var `jsEq` translateConstant cst in
1480 (RawCond cond, translateCase Nothing cse)
1482translateCaseCond var cse@(SConCase _ tag _ _ _) =
1483 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1485translateCase :: Maybe String -> SAlt -> JS
1486translateCase _ (SDefaultCase e) = translateExpression e
1487translateCase _ (SConstCase _ e) = translateExpression e
1488translateCase (Just var) (SConCase a _ _ vars e) =
1489 let params = map jsVar [a .. (a + length vars)] in
1490 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1491 JSThis, JSProj (JSIdent var) "vars"