git.iko.soy/Idris-dev
on 3c58bbf help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1453 lines 45 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 | JSOp String JS JS
63 | JSProj JS String
64 | JSVar LVar
65 | JSNull
66 | JSThis
67 | JSTrue
68 | JSFalse
69 | JSArray [JS]
70 | JSString String
71 | JSChar String
72 | JSNum JSNum
73 | JSAssign JS JS
74 | JSAlloc String (Maybe JS)
75 | JSIndex JS JS
76 | JSCond [(JS, JS)]
77 | JSTernary JS JS JS
78 | JSParens JS
79 deriving Eq
82compileJS :: JS -> String
83compileJS (JSRaw code) =
84 code
86compileJS (JSIdent ident) =
87 ident
89compileJS (JSFunction args body) =
90 "function("
91 ++ intercalate "," args
92 ++ "){\n"
93 ++ compileJS body
94 ++ "\n}"
96compileJS (JSType ty)
97 | JSIntTy <- ty = idrRTNamespace ++ "Int"
98 | JSStringTy <- ty = idrRTNamespace ++ "String"
99 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
100 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
101 | JSCharTy <- ty = idrRTNamespace ++ "Char"
102 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
103 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
105compileJS (JSSeq seq) =
106 intercalate ";\n" (map compileJS seq)
108compileJS (JSReturn val) =
109 "return " ++ compileJS val
111compileJS (JSApp lhs rhs)
112 | JSFunction {} <- lhs =
113 concat ["(", compileJS lhs, ")(", args, ")"]
114 | otherwise =
115 concat [compileJS lhs, "(", args, ")"]
116 where args :: String
117 args = intercalate "," $ map compileJS rhs
119compileJS (JSNew name args) =
120 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
122compileJS (JSError exc) =
123 "throw new Error(\"" ++ exc ++ "\")"
125compileJS (JSOp op lhs rhs) =
126 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
128compileJS (JSProj obj field)
129 | JSFunction {} <- obj =
130 concat ["(", compileJS obj, ").", field]
131 | JSAssign {} <- obj =
132 concat ["(", compileJS obj, ").", field]
133 | otherwise =
134 compileJS obj ++ '.' : field
136compileJS (JSVar var) =
137 translateVariableName var
139compileJS JSNull =
140 "null"
142compileJS JSThis =
143 "this"
145compileJS JSTrue =
146 "true"
148compileJS JSFalse =
149 "false"
151compileJS (JSArray elems) =
152 "[" ++ intercalate "," (map compileJS elems) ++ "]"
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 branches
178 where
179 createIfBlock (JSTrue, e) =
180 "{\n"
181 ++ compileJS e
182 ++ ";\n}"
183 createIfBlock (cond, e) =
184 "if (" ++ compileJS cond ++") {\n"
185 ++ compileJS e
186 ++ ";\n}"
188compileJS (JSTernary cond true false) =
189 let c = compileJS cond
190 t = compileJS true
191 f = compileJS false in
192 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
194compileJS (JSParens js) =
195 "(" ++ compileJS js ++ ")"
198jsTailcall :: JS -> JS
199jsTailcall call =
200 jsCall (idrRTNamespace ++ "tailcall") [
201 JSFunction [] (JSReturn call)
202 ]
205jsCall :: String -> [JS] -> JS
206jsCall fun = JSApp (JSIdent fun)
209jsMeth :: JS -> String -> [JS] -> JS
210jsMeth obj meth =
211 JSApp (JSProj obj meth)
214jsInstanceOf :: JS -> JS -> JS
215jsInstanceOf = JSOp "instanceof"
218jsEq :: JS -> JS -> JS
219jsEq = JSOp "=="
222jsAnd :: JS -> JS -> JS
223jsAnd = JSOp "&&"
226jsType :: JS
227jsType = JSIdent $ idrRTNamespace ++ "Type"
230jsCon :: JS
231jsCon = JSIdent $ idrRTNamespace ++ "Con"
234jsTag :: JS -> JS
235jsTag obj = JSProj obj "tag"
238jsTypeTag :: JS -> JS
239jsTypeTag obj = JSProj obj "type"
242jsBigInt :: JS -> JS
243jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
244jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
245jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
248jsVar :: Int -> String
249jsVar = ("__var_" ++) . show
252jsLet :: String -> JS -> JS -> JS
253jsLet name value body =
254 JSApp (
255 JSFunction [name] (
256 JSReturn body
257 )
258 ) [value]
261jsError :: String -> JS
262jsError err = JSApp (JSFunction [] (JSError err)) []
265transformJS :: (JS -> JS) -> JS -> JS
266transformJS tr js =
267 transformHelper js
268 where
269 transformHelper :: JS -> JS
270 transformHelper js
271 | JSFunction args body <- js = JSFunction args $ tr body
272 | JSSeq seq <- js = JSSeq $ map tr seq
273 | JSReturn ret <- js = JSReturn $ tr ret
274 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
275 | JSNew con args <- js = JSNew con $ map tr args
276 | JSOp op lhs rhs <- js = JSOp op (tr lhs) (tr rhs)
277 | JSProj obj field <- js = JSProj (tr obj) field
278 | JSArray vals <- js = JSArray $ map tr vals
279 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
280 | JSAlloc var val <- js = JSAlloc var $ fmap tr val
281 | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
282 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
283 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
284 | JSParens val <- js = JSParens $ tr val
285 | otherwise = js
288jsSubst :: JS -> JS -> JS -> JS
289jsSubst var new old
290 | var == old = new
292jsSubst (JSIdent var) new (JSVar old)
293 | var == translateVariableName old = new
294 | otherwise = JSVar old
296jsSubst var new old@(JSIdent _)
297 | var == old = new
298 | otherwise = old
300jsSubst var new (JSArray fields) =
301 JSArray (map (jsSubst var new) fields)
303jsSubst var new (JSNew con vals) =
304 JSNew con $ map (jsSubst var new) vals
306jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
307 | var `notElem` args =
308 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
309 map (jsSubst (JSIdent var) new) vals
310 )
311 | otherwise =
312 JSApp (JSProj (JSFunction args body) "apply") (
313 map (jsSubst (JSIdent var) new) vals
314 )
316jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
317 | var /= arg =
318 JSApp (JSFunction [arg] (
319 jsSubst (JSIdent var) new body
320 )) $ map (jsSubst (JSIdent var) new) vals
321 | otherwise =
322 JSApp (JSFunction [arg] (
323 body
324 )) $ map (jsSubst (JSIdent var) new) vals
326jsSubst var new js = transformJS (jsSubst var new) js
329removeAllocations :: JS -> JS
330removeAllocations (JSSeq body) =
331 let opt = removeHelper (map removeAllocations body) in
332 case opt of
333 [ret] -> ret
334 _ -> JSSeq opt
335 where
336 removeHelper :: [JS] -> [JS]
337 removeHelper [js] = [js]
338 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
339 map (jsSubst (JSIdent name) val) (removeHelper js)
340 removeHelper (j:js) = j : removeHelper js
342removeAllocations js = transformJS removeAllocations js
345isJSConstant :: JS -> Bool
346isJSConstant js
347 | JSString _ <- js = True
348 | JSChar _ <- js = True
349 | JSNum _ <- js = True
350 | JSType _ <- js = True
352 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
353 | otherwise = False
356inlineJS :: JS -> JS
357inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err
358inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
359 inlineJS $ jsSubst (JSIdent "cse") val body
362inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
363 inlineJS $ JSSeq [ JSAlloc arg (Just val)
364 , cond
365 ]
367inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
368 JSThis,JSProj var "vars"
369 ])
370 | var /= JSIdent "cse" =
371 inlineJS $ inlineApply args body 0
372 where
373 inlineApply [] body _ = inlineJS body
374 inlineApply (a:as) body n =
375 inlineApply as (
376 jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
377 ) (n + 1)
379inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
380 | isJSConstant val = val
382inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
383 JSFunction [] (JSReturn val)
384 ])
385 | isJSConstant val = val
387inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
388 | JSNew con [tag, vals] <- ret
389 , opt <- inlineJS val =
390 inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]
392 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
393 , opt <- inlineJS val =
394 inlineJS $ JSNew con [JSFunction [] (
395 JSReturn (
396 JSApp (
397 inlineJS $ jsSubst (JSIdent arg) opt fun
398 ) (
399 map (inlineJS . jsSubst (JSIdent arg) opt) vars
400 )
401 )
402 )]
404 | JSApp (JSProj obj field) args <- ret
405 , opt <- inlineJS val =
406 inlineJS $ JSApp (
407 inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field
408 ) (
409 map (inlineJS . jsSubst (JSIdent arg) opt) args
410 )
412 | JSIndex (JSProj obj field) idx <- ret
413 , opt <- inlineJS val =
414 inlineJS $ JSIndex (JSProj (
415 inlineJS $ jsSubst (JSIdent arg) opt obj
416 ) field
417 ) (inlineJS $ jsSubst (JSIdent arg) opt idx)
419 | JSOp op lhs rhs <- ret
420 , opt <- inlineJS val =
421 inlineJS $ JSOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
422 (inlineJS $ jsSubst (JSIdent arg) opt rhs)
424 | JSApp (JSIdent fun) args <- ret
425 , opt <- inlineJS val =
426 inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args
428inlineJS js = transformJS inlineJS js
431reduceJS :: [JS] -> [JS]
432reduceJS js = reduceLoop [] ([], js)
435funName :: JS -> String
436funName (JSAlloc fun _) = fun
439elimDeadLoop :: [JS] -> [JS]
440elimDeadLoop js
441 | ret <- deadEvalApplyCases js
442 , ret /= js = elimDeadLoop ret
443 | otherwise = js
446deadEvalApplyCases :: [JS] -> [JS]
447deadEvalApplyCases js =
448 let tags = sort $ nub $ concatMap (getTags) js in
449 map (removeHelper tags) js
450 where
451 getTags :: JS -> [Int]
452 getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), args]) =
453 tag : getTags args
455 getTags (JSNew _ args) = concatMap getTags args
457 getTags (JSFunction _ body) = getTags body
459 getTags (JSReturn ret) = getTags ret
461 getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
463 getTags (JSSeq seq) = concatMap getTags seq
465 getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
467 getTags (JSProj obj _) = getTags obj
469 getTags (JSArray vals) = concatMap getTags vals
471 getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
473 getTags (JSAlloc _ (Just val)) = getTags val
475 getTags (JSCond conds) =
476 concatMap (uncurry (++)) $ map (getTags *** getTags) conds
478 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
480 getTags (JSParens js) = getTags js
482 getTags js = []
485 removeHelper :: [Int] -> JS -> JS
486 removeHelper tags (JSAlloc fun (Just (
487 JSApp (JSFunction [] (JSSeq seq)) []))
488 ) =
489 (JSAlloc fun (Just (
490 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
491 )
493 removeHelper _ js = js
496 remover :: [Int] -> [JS] -> [JS]
497 remover tags (
498 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
499 )
500 | tag `notElem` tags = remover tags js
502 remover tags (j:js) = j : remover tags js
503 remover _ [] = []
506initConstructors :: [JS] -> [JS]
507initConstructors js =
508 let tags = nub $ sort $ concat (map getTags js) in
509 map createConstant tags ++ replaceConstructors tags js
510 where
511 getTags :: JS -> [Int]
512 getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]
514 getTags (JSNew _ args) = concatMap getTags args
516 getTags (JSFunction _ body) = getTags body
518 getTags (JSReturn ret) = getTags ret
520 getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
522 getTags (JSSeq seq) = concatMap getTags seq
524 getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
526 getTags (JSProj obj _) = getTags obj
528 getTags (JSArray vals) = concatMap getTags vals
530 getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
532 getTags (JSAlloc _ (Just val)) = getTags val
534 getTags (JSCond conds) =
535 concatMap (uncurry (++)) $ map (getTags *** getTags) conds
537 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
539 getTags (JSParens js) = getTags js
541 getTags js = []
544 replaceConstructors :: [Int] -> [JS] -> [JS]
545 replaceConstructors tags js = map (replaceHelper tags) js
546 where
547 replaceHelper :: [Int] -> JS -> JS
548 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
549 | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)
551 replaceHelper tags js = transformJS (replaceHelper tags) js
554 createConstant :: Int -> JS
555 createConstant tag =
556 JSAlloc ("__IDRCTR__" ++ show tag) (Just (
557 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
558 ))
561removeIDs :: [JS] -> [JS]
562removeIDs js =
563 case partition isID js of
564 ([], rest) -> rest
565 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
566 where isID :: JS -> Bool
567 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
568 | JSReturn (JSVar _) <- last body = True
570 isID _ = False
573 idFor :: JS -> (String, Int)
574 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
575 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
578 removeIDCall :: [(String, Int)] -> JS -> JS
579 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
580 JSReturn (JSApp (JSIdent fun) args)
581 )])
582 | Just pos <- lookup fun ids
583 , pos < length args = args !! pos
585 removeIDCall ids (JSNew _ [JSFunction [] (
586 JSReturn (JSApp (JSIdent fun) args)
587 )])
588 | Just pos <- lookup fun ids
589 , pos < length args = args !! pos
591 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
592 | Just pos <- lookup fun ids
593 , pos < length args = args !! pos
595 removeIDCall ids js = transformJS (removeIDCall ids) js
598inlineFunctions :: [JS] -> [JS]
599inlineFunctions js =
600 let funs = collectFunctions js
601 occurences = map ((id . fst) &&& countAll js) funs in
602 removeDeadFunctions occurences js
603 where
604 removeDeadFunctions :: [(String, (Int, JS))] -> [JS] -> [JS]
605 removeDeadFunctions _ [] = []
606 removeDeadFunctions funOccur ((JSAlloc fun (Just (JSFunction _ _))):js)
607 | Just (o, _) <- lookup fun funOccur
608 , o == 0 = removeDeadFunctions funOccur js
610 removeDeadFunctions funOccur (j:js) = j : removeDeadFunctions funOccur js
613 collectFunctions :: [JS] -> [(String, JS)]
614 collectFunctions js =
615 catMaybes $ map collectHelper js
618 collectHelper :: JS -> Maybe (String, JS)
619 collectHelper (JSAlloc fun (Just js@(JSFunction _ body)))
620 | fun /= "main" && nonRecur fun body = Just (fun, js)
621 collectHelper _ = Nothing
624 nonRecur :: String -> JS -> Bool
625 nonRecur name body = countInvokations name body == 0
628 countAll :: [JS] -> (String, JS) -> (Int, JS)
629 countAll js (name, fun) = (sum $ map (countInvokations name) js, fun)
632 countInvokations :: String -> JS -> Int
633 countInvokations name (JSApp (JSIdent ident) args)
634 | name == ident = 1 + (sum $ map (countInvokations name) args)
635 | otherwise = sum $ map (countInvokations name) args
637 countInvokations name (JSApp lhs rhs) =
638 countInvokations name lhs + (sum $ map (countInvokations name) rhs)
640 countInvokations name (JSFunction _ body) =
641 countInvokations name body
643 countInvokations name (JSSeq seq) =
644 sum $ map (countInvokations name) seq
646 countInvokations name (JSReturn ret) =
647 countInvokations name ret
649 countInvokations name (JSNew _ args) =
650 sum $ map (countInvokations name) args
652 countInvokations name (JSOp _ lhs rhs) =
653 countInvokations name lhs + countInvokations name rhs
655 countInvokations name (JSProj obj _) =
656 countInvokations name obj
658 countInvokations name (JSArray vals) =
659 sum $ map (countInvokations name) vals
661 countInvokations name (JSAssign _ rhs) =
662 countInvokations name rhs
664 countInvokations name (JSAlloc _ (Just js)) =
665 countInvokations name js
667 countInvokations name (JSIndex lhs rhs) =
668 countInvokations name lhs + countInvokations name rhs
670 countInvokations name (JSCond conds) =
671 sum $ map (uncurry (+)) (
672 map (countInvokations name *** countInvokations name) conds
673 )
675 countInvokations name (JSTernary c t f) =
676 sum $ [ countInvokations name c
677 , countInvokations name t
678 , countInvokations name f
679 ]
681 countInvokations name (JSParens js) =
682 countInvokations name js
684 countInvokations _ _ = 0
687reduceConstant :: JS -> JS
688reduceConstant
689 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
690 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
691 )])
692 | JSNum num <- val = val
693 | JSOp op lhs rhs <- val =
694 JSParens $ JSOp op (reduceConstant lhs) (reduceConstant rhs)
696 | JSApp (JSProj lhs op) [rhs] <- val
697 , op `elem` [ "subtract"
698 , "add"
699 , "multiply"
700 , "divide"
701 , "mod"
702 , "equals"
703 , "lesser"
704 , "lesserOrEquals"
705 , "greater"
706 , "greaterOrEquals"
707 ] = val
709reduceConstant (JSApp ident [(JSParens js)]) =
710 JSApp ident [reduceConstant js]
712reduceConstant js = transformJS reduceConstant js
715reduceConstants :: JS -> JS
716reduceConstants js
717 | ret <- reduceConstant js
718 , ret /= js = reduceConstants ret
719 | otherwise = js
722elimDuplicateEvals :: JS -> JS
723elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
724 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
725 where
726 elimHelper :: [JS] -> [JS]
727 elimHelper (j@(JSAlloc var (Just val)):js) =
728 j : map (jsSubst val (JSIdent var)) (elimHelper js)
729 elimHelper (j:js) =
730 j : elimHelper js
731 elimHelper [] = []
733elimDuplicateEvals js = js
736optimizeEvalTailcalls :: (String, String) -> JS -> JS
737optimizeEvalTailcalls (fun, tc) js =
738 optHelper js
739 where
740 optHelper :: JS -> JS
741 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
742 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
743 ])
744 | n == fun = JSApp (JSIdent tc) $ map optHelper args
746 optHelper js = transformJS optHelper js
749removeInstanceChecks :: JS -> JS
750removeInstanceChecks (JSCond conds) =
751 JSCond $ eliminateDeadBranches $ map (
752 removeHelper *** removeInstanceChecks
753 ) conds
754 where
755 removeHelper (
756 JSOp "&&" (JSOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
757 ) = removeHelper check
758 removeHelper js = js
761 eliminateDeadBranches (e@(JSTrue, _):_) = [e]
762 eliminateDeadBranches [(_, js)] = [(JSTrue, js)]
763 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
764 eliminateDeadBranches [] = []
766removeInstanceChecks js = transformJS removeInstanceChecks js
769reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
770reduceLoop reduced (cons, program) =
771 case partition findConstructors program of
772 ([], js) -> cons ++ js
773 (candidates, rest) ->
774 let names = reduced ++ map funName candidates in
775 reduceLoop names (
776 cons ++ map reduce candidates, map (reduceCall names) rest
777 )
778 where findConstructors :: JS -> Bool
779 findConstructors js
780 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
781 reducable $ last body
782 | otherwise = False
783 where reducable :: JS -> Bool
784 reducable js
785 | JSReturn ret <- js = reducable ret
786 | JSNew _ args <- js = and $ map reducable args
787 | JSArray fields <- js = and $ map reducable fields
788 | JSNum _ <- js = True
789 | JSNull <- js = True
790 | JSIdent _ <- js = True
791 | otherwise = False
794 reduce :: JS -> JS
795 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
796 | JSReturn js <- last body = (JSAlloc fun (Just js))
798 reduce js = js
801 reduceCall :: [String] -> JS -> JS
802 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
803 JSReturn (JSApp id@(JSIdent ret) _)
804 )])
805 | ret `elem` funs = id
807 reduceCall funs js@(JSApp id@(JSIdent fun) _)
808 | fun `elem` funs = id
810 reduceCall funs js = transformJS (reduceCall funs) js
813optimizeJS :: JS -> JS
814optimizeJS = inlineLoop
815 where inlineLoop :: JS -> JS
816 inlineLoop js
817 | opt <- inlineJS js
818 , opt /= js = inlineLoop opt
819 | otherwise = js
822codegenJavaScript
823 :: JSTarget
824 -> [(Name, SDecl)]
825 -> FilePath
826 -> OutputType
827 -> IO ()
828codegenJavaScript target definitions filename outputType = do
829 let (header, runtime) = case target of
830 Node ->
831 ("#!/usr/bin/env node\n", "-node")
832 JavaScript ->
833 ("", "-browser")
834 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
835 idrRuntime <- readFile $ path ++ "Runtime-common.js"
836 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
837 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
838 writeFile filename $ header ++ (
839 intercalate "\n" $ [ jsbn
840 , idrRuntime
841 , tgtRuntime
842 ] ++ functions
843 )
845 setPermissions filename (emptyPermissions { readable = True
846 , executable = target == Node
847 , writable = True
848 })
849 where
850 def :: [(String, SDecl)]
851 def = map (first translateNamespace) definitions
854 functions :: [String]
855 functions = translate >>> optimize >>> compile $ def
856 where
857 translate p = concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
858 optimize p = foldl' (flip ($)) p opt
859 compile = map compileJS
861 opt =
862 [ map optimizeJS
863 , removeIDs
864 , reduceJS
865 , map reduceConstants
866 , initConstructors
867 , map removeAllocations
868 , elimDeadLoop
869 , inlineFunctions
870 , map elimDuplicateEvals
871 , map (optimizeEvalTailcalls ("__IDR__mEVAL0", "__IDRRT__EVALTC"))
872 , map (optimizeEvalTailcalls ("__IDR__mAPPLY0", "__IDRRT__APPLYTC"))
873 , map removeInstanceChecks
874 ]
877 mainLoop :: JS
878 mainLoop =
879 JSAlloc "main" $ Just $ JSFunction [] (
880 case target of
881 Node -> mainFun
882 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
883 JSString "DOMContentLoaded", JSFunction [] (
884 mainFun
885 ), JSFalse
886 ]
887 )
888 where
889 mainFun :: JS
890 mainFun = jsTailcall $ jsCall runMain []
893 runMain :: String
894 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
897 invokeLoop :: JS
898 invokeLoop = jsCall "main" []
901translateIdentifier :: String -> String
902translateIdentifier =
903 replaceReserved . concatMap replaceBadChars
904 where replaceBadChars :: Char -> String
905 replaceBadChars c
906 | ' ' <- c = "_"
907 | '_' <- c = "__"
908 | isDigit c = '_' : show (ord c)
909 | not (isLetter c && isAscii c) = '_' : show (ord c)
910 | otherwise = [c]
911 replaceReserved s
912 | s `elem` reserved = '_' : s
913 | otherwise = s
916 reserved = [ "break"
917 , "case"
918 , "catch"
919 , "continue"
920 , "debugger"
921 , "default"
922 , "delete"
923 , "do"
924 , "else"
925 , "finally"
926 , "for"
927 , "function"
928 , "if"
929 , "in"
930 , "instanceof"
931 , "new"
932 , "return"
933 , "switch"
934 , "this"
935 , "throw"
936 , "try"
937 , "typeof"
938 , "var"
939 , "void"
940 , "while"
941 , "with"
943 , "class"
944 , "enum"
945 , "export"
946 , "extends"
947 , "import"
948 , "super"
950 , "implements"
951 , "interface"
952 , "let"
953 , "package"
954 , "private"
955 , "protected"
956 , "public"
957 , "static"
958 , "yield"
959 ]
962translateNamespace :: Name -> String
963translateNamespace (UN _) = idrNamespace
964translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
965translateNamespace (MN _ _) = idrNamespace
966translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
967translateNamespace NErased = idrNamespace
970translateName :: Name -> String
971translateName (UN name) = 'u' : translateIdentifier (str name)
972translateName (NS name _) = 'n' : translateName name
973translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
974translateName (SN name) = 's' : translateSpecialName name
975translateName NErased = "e"
978translateSpecialName :: SpecialName -> String
979translateSpecialName name
980 | WhereN i m n <- name =
981 'w' : translateName m ++ translateName n ++ show i
982 | InstanceN n s <- name =
983 'i' : translateName n ++ concatMap (translateIdentifier . str) s
984 | ParentN n s <- name =
985 'p' : translateName n ++ translateIdentifier (str s)
986 | MethodN n <- name =
987 'm' : translateName n
988 | CaseN n <- name =
989 'c' : translateName n
992translateConstant :: Const -> JS
993translateConstant (I i) = JSNum (JSInt i)
994translateConstant (Fl f) = JSNum (JSFloat f)
995translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
996translateConstant (Ch '\a') = JSChar "'\\u0007'"
997translateConstant (Ch '\SO') = JSChar "'\\u000E'"
998translateConstant (Ch c) = JSString [c]
999translateConstant (Str s) = JSString s
1000translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1001translateConstant StrType = JSType JSStringTy
1002translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1003translateConstant (AType ATFloat) = JSType JSFloatTy
1004translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1005translateConstant PtrType = JSType JSPtrTy
1006translateConstant Forgot = JSType JSForgotTy
1007translateConstant (BI i) = jsBigInt $ JSString (show i)
1008translateConstant c =
1009 jsError $ "Unimplemented Constant: " ++ show c
1012translateDeclaration :: (String, SDecl) -> [JS]
1013translateDeclaration (path, SFun name params stackSize body)
1014 | (MN _ ap) <- name
1015 , (SLet var val next) <- body
1016 , (SChkCase cvar cases) <- next
1017 , ap == txt "APPLY" =
1018 let lvar = translateVariableName var
1019 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
1020 [ lookupTable [(var, "chk")] var cases
1021 , jsDecl $ JSFunction ["fn0", "arg0"] (
1022 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1023 , JSAlloc (translateVariableName var) (
1024 Just $ translateExpression val
1026 , JSReturn $ (JSTernary (
1027 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1028 (hasProp lookupTableName (translateVariableName var))
1029 ) (JSIdent $
1030 lookupTableName ++ lookup
1031 ) JSNull
1037 | (MN _ ev) <- name
1038 , (SChkCase var cases) <- body
1039 , ev == txt "EVAL" =
1040 [ lookupTable [] var cases
1041 , jsDecl $ JSFunction ["arg0"] (JSReturn $
1042 JSTernary (
1043 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1044 (hasProp lookupTableName "arg0")
1045 ) (JSApp
1046 (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
1047 [JSIdent "arg0"]
1048 ) (JSIdent "arg0")
1051 | otherwise =
1052 let fun = translateExpression body in
1053 [jsDecl $ jsFun fun]
1055 where
1056 hasProp :: String -> String -> JS
1057 hasProp table var =
1058 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1061 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1062 caseFun aux var cse =
1063 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1064 jsFunAux aux c
1067 getTag :: SAlt -> Maybe Int
1068 getTag (SConCase _ tag _ _ _) = Just tag
1069 getTag _ = Nothing
1072 lookupTableName :: String
1073 lookupTableName = idrLTNamespace ++ translateName name
1076 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
1077 lookupTable aux var cases =
1078 JSAlloc lookupTableName $ Just (
1079 JSApp (JSFunction [] (
1080 JSSeq $ [
1081 JSAlloc "t" $ Just (JSArray [])
1082 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1083 JSReturn (JSIdent "t")
1085 )) []
1087 where
1088 assignEntries :: [(Int, JS)] -> [JS]
1089 assignEntries entries =
1090 map (\(tag, fun) ->
1091 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1092 ) entries
1095 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1096 lookupEntry aux var alt = do
1097 tag <- getTag alt
1098 return (tag, caseFun aux var alt)
1101 jsDecl :: JS -> JS
1102 jsDecl = JSAlloc (path ++ translateName name) . Just
1105 jsFun body = jsFunAux [] body
1108 jsFunAux :: [(LVar, String)] -> JS -> JS
1109 jsFunAux aux body =
1110 JSFunction (p ++ map snd aux) (
1111 JSSeq $
1112 zipWith assignVar [0..] p ++
1113 map assignAux aux ++
1114 [JSReturn body]
1116 where
1117 assignVar :: Int -> String -> JS
1118 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1121 assignAux :: (LVar, String) -> JS
1122 assignAux (Loc var, val) =
1123 JSAlloc (jsVar var) (Just $ JSIdent val)
1126 p :: [String]
1127 p = map translateName params
1130translateVariableName :: LVar -> String
1131translateVariableName (Loc i) =
1132 jsVar i
1135translateExpression :: SExp -> JS
1136translateExpression (SLet name value body) =
1137 jsLet (translateVariableName name) (
1138 translateExpression value
1139 ) (translateExpression body)
1141translateExpression (SConst cst) =
1142 translateConstant cst
1144translateExpression (SV var) =
1145 JSVar var
1147translateExpression (SApp tc name vars)
1148 | False <- tc =
1149 jsTailcall $ translateFunctionCall name vars
1150 | True <- tc =
1151 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1152 JSReturn $ translateFunctionCall name vars
1153 )]
1154 where
1155 translateFunctionCall name vars =
1156 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1158translateExpression (SOp op vars)
1159 | LNoOp <- op = JSVar (last vars)
1161 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1162 | (LPlus (ATInt ITBig)) <- op
1163 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1164 | (LMinus (ATInt ITBig)) <- op
1165 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1166 | (LTimes (ATInt ITBig)) <- op
1167 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1168 | (LSDiv (ATInt ITBig)) <- op
1169 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1170 | (LSRem (ATInt ITBig)) <- op
1171 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1172 | (LEq (ATInt ITBig)) <- op
1173 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1174 | (LSLt (ATInt ITBig)) <- op
1175 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1176 | (LSLe (ATInt ITBig)) <- op
1177 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1178 | (LSGt (ATInt ITBig)) <- op
1179 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1180 | (LSGe (ATInt ITBig)) <- op
1181 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1183 | (LPlus ATFloat) <- op
1184 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1185 | (LMinus ATFloat) <- op
1186 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1187 | (LTimes ATFloat) <- op
1188 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1189 | (LSDiv ATFloat) <- op
1190 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1191 | (LEq ATFloat) <- op
1192 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1193 | (LSLt ATFloat) <- op
1194 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1195 | (LSLe ATFloat) <- op
1196 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1197 | (LSGt ATFloat) <- op
1198 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1199 | (LSGe ATFloat) <- op
1200 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1202 | (LPlus _) <- op
1203 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1204 | (LMinus _) <- op
1205 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1206 | (LTimes _) <- op
1207 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1208 | (LSDiv _) <- op
1209 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1210 | (LSRem _) <- op
1211 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1212 | (LEq _) <- op
1213 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1214 | (LSLt _) <- op
1215 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1216 | (LSLe _) <- op
1217 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1218 | (LSGt _) <- op
1219 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1220 | (LSGe _) <- op
1221 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1222 | (LAnd _) <- op
1223 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1224 | (LOr _) <- op
1225 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1226 | (LXOr _) <- op
1227 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1228 | (LSHL _) <- op
1229 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1230 | (LASHR _) <- op
1231 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1232 | (LCompl _) <- op
1233 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
1235 | LStrConcat <- op
1236 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1237 | LStrEq <- op
1238 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1239 | LStrLt <- op
1240 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1241 | LStrLen <- op
1242 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1244 | (LStrInt ITNative) <- op
1245 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1246 | (LIntStr ITNative) <- op
1247 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1248 | (LSExt ITNative ITBig) <- op
1249 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1250 | (LTrunc ITBig ITNative) <- op
1251 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1252 | (LIntStr ITBig) <- op
1253 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1254 | (LStrInt ITBig) <- op
1255 , (arg:_) <- vars = jsBigInt $ JSVar arg
1256 | LFloatStr <- op
1257 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1258 | LStrFloat <- op
1259 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1260 | (LIntFloat ITNative) <- op
1261 , (arg:_) <- vars = JSVar arg
1262 | (LFloatInt ITNative) <- op
1263 , (arg:_) <- vars = JSVar arg
1264 | (LChInt ITNative) <- op
1265 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1266 | (LIntCh ITNative) <- op
1267 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1269 | LFExp <- op
1270 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1271 | LFLog <- op
1272 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1273 | LFSin <- op
1274 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1275 | LFCos <- op
1276 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1277 | LFTan <- op
1278 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1279 | LFASin <- op
1280 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1281 | LFACos <- op
1282 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1283 | LFATan <- op
1284 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1285 | LFSqrt <- op
1286 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1287 | LFFloor <- op
1288 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1289 | LFCeil <- op
1290 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1292 | LStrCons <- op
1293 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1294 | LStrHead <- op
1295 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1296 | LStrRev <- op
1297 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1298 | LStrIndex <- op
1299 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1300 | LStrTail <- op
1301 , (arg:_) <- vars = let v = translateVariableName arg in
1302 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
1303 | LNullPtr <- op
1304 , (_) <- vars = JSNull
1306 where
1307 translateBinaryOp :: String -> LVar -> LVar -> JS
1308 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
1311 invokeMeth :: LVar -> String -> [LVar] -> JS
1312 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1314translateExpression (SError msg) =
1315 jsError msg
1317translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1318 jsCall (idrRTNamespace ++ "print") [JSVar var]
1320translateExpression (SForeign _ _ fun args) =
1321 ffi fun (map generateWrapper args)
1322 where
1323 generateWrapper (ffunc, name)
1324 | FFunction <- ffunc =
1325 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1326 | FFunctionIO <- ffunc =
1327 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1329 generateWrapper (_, name) =
1330 translateVariableName name
1332translateExpression patterncase
1333 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1334 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1335 where
1336 caseHelper var cases param =
1337 JSApp (JSFunction [param] (
1338 JSCond $ map (expandCase param . translateCaseCond param) cases
1339 )) [JSVar var]
1342 expandCase :: String -> (Cond, JS) -> (JS, JS)
1343 expandCase _ (RawCond cond, branch) = (cond, branch)
1344 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1345 expandCase var (CaseCond caseTy, branch)
1346 | ConCase tag <- caseTy =
1347 let checkCon = JSIdent var `jsInstanceOf` jsCon
1348 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1349 (checkCon `jsAnd` checkTag, branch)
1351 | TypeCase ty <- caseTy =
1352 let checkTy = JSIdent var `jsInstanceOf` jsType
1353 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1354 (checkTy `jsAnd` checkTag, branch)
1356translateExpression (SCon i name vars) =
1357 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1358 , JSArray $ map JSVar vars
1361translateExpression (SUpdate var@(Loc i) e) =
1362 JSAssign (JSVar var) (translateExpression e)
1364translateExpression (SProj var i) =
1365 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1367translateExpression SNothing = JSNull
1369translateExpression e =
1370 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1373data FFI = FFICode Char | FFIArg Int | FFIError String
1376ffi :: String -> [String] -> JS
1377ffi code args = let parsed = ffiParse code in
1378 case ffiError parsed of
1379 Just err -> jsError err
1380 Nothing -> JSRaw $ renderFFI parsed args
1381 where
1382 ffiParse :: String -> [FFI]
1383 ffiParse "" = []
1384 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1385 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1386 ffiParse ('%':s:ss)
1387 | isDigit s =
1388 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1389 | otherwise =
1390 [FFIError "Invalid positional argument"]
1391 ffiParse (s:ss) = FFICode s : ffiParse ss
1394 ffiError :: [FFI] -> Maybe String
1395 ffiError [] = Nothing
1396 ffiError ((FFIError s):xs) = Just s
1397 ffiError (x:xs) = ffiError xs
1400 renderFFI :: [FFI] -> [String] -> String
1401 renderFFI [] _ = ""
1402 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1403 renderFFI ((FFIArg i) : fs) args
1404 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1405 | otherwise = "Argument index out of bounds"
1408data CaseType = ConCase Int
1409 | TypeCase JSType
1410 | DefaultCase
1411 deriving Eq
1414data Cond = CaseCond CaseType
1415 | RawCond JS
1418translateCaseCond :: String -> SAlt -> (Cond, JS)
1419translateCaseCond _ cse@(SDefaultCase _) =
1420 (CaseCond DefaultCase, translateCase Nothing cse)
1422translateCaseCond var cse@(SConstCase ty _)
1423 | StrType <- ty = matchHelper JSStringTy
1424 | PtrType <- ty = matchHelper JSPtrTy
1425 | Forgot <- ty = matchHelper JSForgotTy
1426 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1427 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1428 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1429 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1430 where
1431 matchHelper :: JSType -> (Cond, JS)
1432 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1434translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1435 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1436 (RawCond cond, translateCase Nothing cse)
1438translateCaseCond var cse@(SConstCase cst _) =
1439 let cond = JSIdent var `jsEq` translateConstant cst in
1440 (RawCond cond, translateCase Nothing cse)
1442translateCaseCond var cse@(SConCase _ tag _ _ _) =
1443 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1446translateCase :: Maybe String -> SAlt -> JS
1447translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
1448translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
1449translateCase (Just var) (SConCase a _ _ vars e) =
1450 let params = map jsVar [a .. (a + length vars)] in
1451 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1452 JSThis, JSProj (JSIdent var) "vars"