git.iko.soy/Idris-dev
on d006e27 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1294 lines 42 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 [tag, vals]) =
262 JSNew con [tag, jsSubst var new vals]
264jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
265 JSNew con [JSFunction [] (
266 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) vars)
267 )]
269jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
270 JSReturn (JSApp fun args)
271 )]) =
272 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
273 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)
274 )]
276jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
277 | var `notElem` args =
278 JSApp (JSProj (JSFunction args (jsSubst var new body)) "apply") (
279 map (jsSubst var new) vals
280 )
281 | otherwise =
282 JSApp (JSProj (JSFunction args body) "apply") (
283 map (jsSubst var new) vals
284 )
286jsSubst var new (JSApp (JSProj obj field) args) =
287 JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args
289jsSubst var new (JSApp (JSFunction [arg] body) vals)
290 | var /= arg =
291 JSApp (JSFunction [arg] (
292 jsSubst var new body
293 )) $ map (jsSubst var new) vals
294 | otherwise =
295 JSApp (JSFunction [arg] (
296 body
297 )) $ map (jsSubst var new) vals
299jsSubst var new (JSReturn ret) =
300 JSReturn $ jsSubst var new ret
302jsSubst var new (JSProj obj field) =
303 JSProj (jsSubst var new obj) field
305jsSubst var new (JSSeq body) =
306 JSSeq $ map (jsSubst var new) body
308jsSubst var new (JSOp op lhs rhs) =
309 JSOp op (jsSubst var new lhs) (jsSubst var new rhs)
311jsSubst var new (JSIndex obj field) =
312 JSIndex (jsSubst var new obj) (jsSubst var new field)
314jsSubst var new (JSCond conds) =
315 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)
317jsSubst var new (JSAssign lhs rhs) =
318 JSAssign (jsSubst var new lhs) (jsSubst var new rhs)
320jsSubst _ _ js = js
323isJSConstant :: JS -> Bool
324isJSConstant js
325 | JSString _ <- js = True
326 | JSChar _ <- js = True
327 | JSNum _ <- js = True
328 | JSType _ <- js = True
330 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
331 | otherwise = False
333inlineJS :: JS -> JS
334inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
335 inlineJS $ jsSubst "cse" val body
337inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
338 JSSeq [ JSAlloc arg (Just (inlineJS val))
339 , inlineJS cond
340 ]
342inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
343 JSThis,JSProj var "vars"
344 ])
345 | var /= JSIdent "cse" =
346 inlineApply args body 0
347 where
348 inlineApply [] body _ = inlineJS body
349 inlineApply (a:as) body n =
350 inlineApply as (
351 jsSubst a (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
352 ) (n + 1)
354inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
355 | isJSConstant val = val
357inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
358 JSFunction [] (JSReturn val)
359 ])
360 | isJSConstant val = val
362inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
363 | JSNew con [tag, vals] <- ret
364 , opt <- inlineJS val =
365 JSNew con [tag, jsSubst arg opt vals]
367 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
368 , opt <- inlineJS val =
369 JSNew con [JSFunction [] (
370 JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) vars)
371 )]
373 | JSApp (JSProj obj field) args <- ret
374 , opt <- inlineJS val =
375 JSApp (JSProj (jsSubst arg opt obj) field) $ map (jsSubst arg opt) args
377 | JSIndex (JSProj obj field) idx <- ret
378 , opt <- inlineJS val =
379 JSIndex (JSProj (
380 jsSubst arg opt obj
381 ) field
382 ) (jsSubst arg opt idx)
384 | JSOp op lhs rhs <- ret
385 , opt <- inlineJS val =
386 JSOp op (jsSubst arg opt lhs) $
387 (jsSubst arg opt rhs)
389 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
390 JSReturn (JSApp fun args)
391 )] <- ret
392 , opt <- inlineJS val =
393 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
394 JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) args)
395 )]
397inlineJS (JSApp fun args) =
398 JSApp (inlineJS fun) (map inlineJS args)
400inlineJS (JSNew con args) =
401 JSNew con $ map inlineJS args
403inlineJS (JSArray fields) =
404 JSArray (map inlineJS fields)
406inlineJS (JSAssign lhs rhs) =
407 JSAssign (inlineJS lhs) (inlineJS rhs)
409inlineJS (JSSeq seq) =
410 JSSeq (map inlineJS seq)
412inlineJS (JSFunction args body) =
413 JSFunction args (inlineJS body)
415inlineJS (JSProj (JSFunction args body) field) =
416 JSProj (JSFunction args (inlineJS body)) field
418inlineJS (JSReturn js) =
419 JSReturn $ inlineJS js
421inlineJS (JSAlloc name (Just js)) =
422 JSAlloc name (Just $ inlineJS js)
424inlineJS (JSCond cases) =
425 JSCond (map (second inlineJS) cases)
427inlineJS (JSObject fields) =
428 JSObject (map (second inlineJS) fields)
430inlineJS (JSOp op lhs rhs) =
431 JSOp op (inlineJS lhs) (inlineJS rhs)
433inlineJS js = js
435reduceJS :: [JS] -> [JS]
436reduceJS js = reduceLoop [] ([], js)
438funName :: JS -> String
439funName (JSAlloc fun _) = fun
441initConstructors :: [JS] -> [JS]
442initConstructors js =
443 let tags = nub $ sort $ concat (map getTags js) in
444 map createConstant tags ++ replaceConstructors tags js
445 where
446 getTags :: JS -> [Int]
447 getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]
449 getTags (JSNew _ args) = concatMap getTags args
451 getTags (JSFunction _ body) = getTags body
453 getTags (JSReturn ret) = getTags ret
455 getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
457 getTags (JSSeq seq) = concatMap getTags seq
459 getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
461 getTags (JSProj obj _) = getTags obj
463 getTags (JSArray vals) = concatMap getTags vals
465 getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
467 getTags (JSAlloc _ (Just val)) = getTags val
469 getTags (JSCond conds) =
470 concatMap (uncurry (++)) $ map (getTags *** getTags) conds
472 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
474 getTags js = []
476 replaceConstructors :: [Int] -> [JS] -> [JS]
477 replaceConstructors tags js = map (replaceHelper tags) js
478 where
479 replaceHelper :: [Int] -> JS -> JS
480 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
481 | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)
483 replaceHelper tags (JSNew con args) =
484 JSNew con $ map (replaceHelper tags) args
486 replaceHelper tags (JSFunction fun body) =
487 JSFunction fun (replaceHelper tags body)
489 replaceHelper tags (JSReturn ret) =
490 JSReturn (replaceHelper tags ret)
492 replaceHelper tags (JSApp lhs rhs) =
493 JSApp (replaceHelper tags lhs) (map (replaceHelper tags) rhs)
495 replaceHelper tags (JSSeq seq) =
496 JSSeq $ map (replaceHelper tags) seq
498 replaceHelper tags (JSOp op lhs rhs) =
499 JSOp op (replaceHelper tags lhs) (replaceHelper tags rhs)
501 replaceHelper tags (JSProj obj field) =
502 JSProj (replaceHelper tags obj) field
504 replaceHelper tags (JSArray vals) =
505 JSArray $ map (replaceHelper tags) vals
507 replaceHelper tags (JSAssign lhs rhs) =
508 JSAssign (replaceHelper tags lhs) (replaceHelper tags rhs)
510 replaceHelper tags (JSAlloc var (Just val)) =
511 JSAlloc var $ Just (replaceHelper tags val)
513 replaceHelper tags (JSCond conds) =
514 JSCond (map ((replaceHelper tags) *** (replaceHelper tags)) conds)
516 replaceHelper tags (JSTernary c t f) =
517 JSTernary (replaceHelper tags c) (
518 replaceHelper tags t
519 ) (
520 replaceHelper tags f
521 )
523 replaceHelper tags js = js
525 createConstant :: Int -> JS
526 createConstant tag =
527 JSAlloc ("__IDRCTR__" ++ show tag) (Just (
528 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
529 ))
531removeIDs :: [JS] -> [JS]
532removeIDs js =
533 case partition isID js of
534 ([], rest) -> rest
535 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
536 where isID :: JS -> Bool
537 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
538 | JSReturn (JSVar _) <- last body = True
540 isID _ = False
542 idFor :: JS -> (String, Int)
543 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
544 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
546 removeIDCall :: [(String, Int)] -> JS -> JS
547 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
548 JSReturn (JSApp (JSIdent fun) args)
549 )])
550 | Just pos <- lookup fun ids
551 , pos < length args = args !! pos
553 removeIDCall ids (JSNew _ [JSFunction [] (
554 JSReturn (JSApp (JSIdent fun) args)
555 )])
556 | Just pos <- lookup fun ids
557 , pos < length args = args !! pos
559 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
560 | Just pos <- lookup fun ids
561 , pos < length args = args !! pos
563 removeIDCall ids (JSAlloc fun (Just body)) =
564 JSAlloc fun (Just $ removeIDCall ids body)
566 removeIDCall ids (JSReturn js) =
567 JSReturn $ removeIDCall ids js
569 removeIDCall ids (JSSeq js) =
570 JSSeq $ map (removeIDCall ids) js
572 removeIDCall ids (JSNew con args) =
573 JSNew con $ map (removeIDCall ids) args
575 removeIDCall ids (JSFunction args body) =
576 JSFunction args $ removeIDCall ids body
578 removeIDCall ids (JSApp fun args) =
579 JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args
581 removeIDCall ids (JSProj obj field) =
582 JSProj (removeIDCall ids obj) field
584 removeIDCall ids (JSCond conds) =
585 JSCond $ map (removeIDCall ids *** removeIDCall ids) conds
587 removeIDCall ids (JSAssign lhs rhs) =
588 JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs)
590 removeIDCall ids (JSArray fields) =
591 JSArray $ map (removeIDCall ids) fields
593 removeIDCall _ js = js
595reduceConstant :: JS -> JS
596reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
597 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
598 )]) = JSNum num
600reduceConstant (JSReturn ret) =
601 JSReturn (reduceConstant ret)
603reduceConstant (JSApp fun args) =
604 JSApp (reduceConstant fun) (map reduceConstant args)
606reduceConstant (JSArray fields) =
607 JSArray (map reduceConstant fields)
609reduceConstant (JSAlloc name (Just val)) =
610 JSAlloc name $ Just (reduceConstant val)
612reduceConstant (JSNew con args) =
613 JSNew con (map reduceConstant args)
615reduceConstant (JSProj obj field) =
616 JSProj (reduceConstant obj) field
618reduceConstant (JSCond conds) =
619 JSCond $ map (reduceConstant *** reduceConstant) conds
621reduceConstant (JSSeq seq) =
622 JSSeq $ map reduceConstant seq
624reduceConstant (JSFunction args body) =
625 JSFunction args (reduceConstant body)
627reduceConstant js = js
629reduceConstants :: JS -> JS
630reduceConstants js
631 | ret <- reduceConstant js
632 , ret /= js = reduceConstants ret
633 | otherwise = js
635reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
636reduceLoop reduced (cons, program) =
637 case partition findConstructors program of
638 ([], js) -> cons ++ js
639 (candidates, rest) ->
640 let names = reduced ++ map funName candidates in
641 reduceLoop names (
642 cons ++ map reduce candidates, map (reduceCall names) rest
643 )
644 where findConstructors :: JS -> Bool
645 findConstructors js
646 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
647 reducable $ last body
648 | otherwise = False
649 where reducable :: JS -> Bool
650 reducable (JSReturn js) = reducable js
651 reducable (JSNew _ args) = and $ map reducable args
652 reducable (JSArray fields) = and $ map reducable fields
653 reducable (JSNum _) = True
654 reducable JSNull = True
655 reducable (JSIdent _) = True
656 reducable _ = False
658 reduce :: JS -> JS
659 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
660 | JSReturn js <- last body = (JSAlloc fun (Just js))
662 reduce js = js
664 reduceCall :: [String] -> JS -> JS
665 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
666 JSReturn (JSApp id@(JSIdent ret) _)
667 )])
668 | ret `elem` funs = id
670 reduceCall funs js@(JSApp id@(JSIdent fun) _)
671 | fun `elem` funs = id
673 reduceCall funs (JSAlloc fun (Just body)) =
674 JSAlloc fun (Just $ reduceCall funs body)
676 reduceCall funs (JSReturn js) =
677 JSReturn $ reduceCall funs js
679 reduceCall funs (JSSeq js) =
680 JSSeq $ map (reduceCall funs) js
682 reduceCall funs (JSNew con args) =
683 JSNew con $ map (reduceCall funs) args
685 reduceCall funs (JSFunction args body) =
686 JSFunction args $ reduceCall funs body
688 reduceCall funs (JSApp fun args) =
689 JSApp (reduceCall funs fun) $ map (reduceCall funs) args
691 reduceCall funs (JSProj obj field) =
692 JSProj (reduceCall funs obj) field
694 reduceCall funs (JSIndex obj idx) =
695 JSIndex (reduceCall funs obj) (reduceCall funs idx)
697 reduceCall funs (JSOp op rhs lhs) =
698 JSOp op (reduceCall funs rhs) (reduceCall funs lhs)
700 reduceCall funs (JSCond conds) =
701 JSCond $ map (reduceCall funs *** reduceCall funs) conds
703 reduceCall funs (JSAssign lhs rhs) =
704 JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
706 reduceCall funs (JSArray fields) =
707 JSArray $ map (reduceCall funs) fields
709 reduceCall _ js = js
711optimizeJS :: JS -> JS
712optimizeJS = inlineLoop
713 where inlineLoop :: JS -> JS
714 inlineLoop js
715 | opt <- inlineJS js
716 , opt /= js = inlineLoop opt
717 | otherwise = js
719codegenJavaScript
720 :: JSTarget
721 -> [(Name, SDecl)]
722 -> FilePath
723 -> OutputType
724 -> IO ()
725codegenJavaScript target definitions filename outputType = do
726 let (header, runtime) = case target of
727 Node ->
728 ("#!/usr/bin/env node\n", "-node")
729 JavaScript ->
730 ("", "-browser")
731 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
732 idrRuntime <- readFile $ path ++ "Runtime-common.js"
733 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
734 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
735 writeFile filename $ header ++ (
736 intercalate "\n" $ [ jsbn
737 , idrRuntime
738 , tgtRuntime
739 ] ++ functions ++ [mainLoop, invokeLoop]
740 )
742 setPermissions filename (emptyPermissions { readable = True
743 , executable = target == Node
744 , writable = True
745 })
746 where
747 def :: [(String, SDecl)]
748 def = map (first translateNamespace) definitions
750 functions :: [String]
751 functions =
752 map compileJS $ initConstructors (map reduceConstants ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def))
754 mainLoop :: String
755 mainLoop = compileJS $
756 JSAlloc "main" $ Just $ JSFunction [] (
757 case target of
758 Node -> mainFun
759 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
760 JSString "DOMContentLoaded", JSFunction [] (
761 mainFun
762 ), JSFalse
763 ]
764 )
765 where
766 mainFun :: JS
767 mainFun = jsTailcall $ jsCall runMain []
769 runMain :: String
770 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
772 invokeLoop :: String
773 invokeLoop = compileJS $ jsCall "main" []
775translateIdentifier :: String -> String
776translateIdentifier =
777 replaceReserved . concatMap replaceBadChars
778 where replaceBadChars :: Char -> String
779 replaceBadChars c
780 | ' ' <- c = "_"
781 | '_' <- c = "__"
782 | isDigit c = '_' : show (ord c)
783 | not (isLetter c && isAscii c) = '_' : show (ord c)
784 | otherwise = [c]
785 replaceReserved s
786 | s `elem` reserved = '_' : s
787 | otherwise = s
788 reserved = [ "break"
789 , "case"
790 , "catch"
791 , "continue"
792 , "debugger"
793 , "default"
794 , "delete"
795 , "do"
796 , "else"
797 , "finally"
798 , "for"
799 , "function"
800 , "if"
801 , "in"
802 , "instanceof"
803 , "new"
804 , "return"
805 , "switch"
806 , "this"
807 , "throw"
808 , "try"
809 , "typeof"
810 , "var"
811 , "void"
812 , "while"
813 , "with"
815 , "class"
816 , "enum"
817 , "export"
818 , "extends"
819 , "import"
820 , "super"
822 , "implements"
823 , "interface"
824 , "let"
825 , "package"
826 , "private"
827 , "protected"
828 , "public"
829 , "static"
830 , "yield"
831 ]
833translateNamespace :: Name -> String
834translateNamespace (UN _) = idrNamespace
835translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
836translateNamespace (MN _ _) = idrNamespace
837translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
838translateNamespace NErased = idrNamespace
840translateName :: Name -> String
841translateName (UN name) = 'u' : translateIdentifier (str name)
842translateName (NS name _) = 'n' : translateName name
843translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
844translateName (SN name) = 's' : translateSpecialName name
845translateName NErased = "e"
847translateSpecialName :: SpecialName -> String
848translateSpecialName name
849 | WhereN i m n <- name =
850 'w' : translateName m ++ translateName n ++ show i
851 | InstanceN n s <- name =
852 'i' : translateName n ++ concatMap (translateIdentifier . str) s
853 | ParentN n s <- name =
854 'p' : translateName n ++ translateIdentifier (str s)
855 | MethodN n <- name =
856 'm' : translateName n
857 | CaseN n <- name =
858 'c' : translateName n
860translateConstant :: Const -> JS
861translateConstant (I i) = JSNum (JSInt i)
862translateConstant (Fl f) = JSNum (JSFloat f)
863translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
864translateConstant (Ch '\a') = JSChar "'\\u0007'"
865translateConstant (Ch '\SO') = JSChar "'\\u000E'"
866translateConstant (Ch c) = JSString [c]
867translateConstant (Str s) = JSString s
868translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
869translateConstant StrType = JSType JSStringTy
870translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
871translateConstant (AType ATFloat) = JSType JSFloatTy
872translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
873translateConstant PtrType = JSType JSPtrTy
874translateConstant Forgot = JSType JSForgotTy
875translateConstant (BI i) = jsBigInt $ JSString (show i)
876translateConstant c =
877 JSError $ "Unimplemented Constant: " ++ show c
879translateDeclaration :: (String, SDecl) -> JS
880translateDeclaration (path, SFun name params stackSize body)
881 | (MN _ ap) <- name
882 , (SLet var val next) <- body
883 , (SChkCase cvar cases) <- next
884 , ap == txt "APPLY" =
885 let lvar = translateVariableName var
886 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
887 JSSeq [ lookupTable [(var, "chk")] var cases
888 , jsDecl $ JSFunction ["fn0", "arg0"] (
889 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
890 , JSAlloc (translateVariableName var) (
891 Just $ translateExpression val
892 )
893 , JSReturn $ (JSTernary (
894 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
895 (hasProp lookupTableName (translateVariableName var))
896 ) (JSIdent $
897 lookupTableName ++ lookup
898 ) JSNull
899 )
900 ]
901 )
902 ]
904 | (MN _ ev) <- name
905 , (SChkCase var cases) <- body
906 , ev == txt "EVAL" =
907 JSSeq [ lookupTable [] var cases
908 , jsDecl $ JSFunction ["arg0"] (JSReturn $
909 JSTernary (
910 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
911 (hasProp lookupTableName "arg0")
912 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0")
913 )
914 ]
915 | otherwise =
916 let fun = translateExpression body in
917 jsDecl $ jsFun fun
919 where
920 hasProp :: String -> String -> JS
921 hasProp table var =
922 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
924 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
925 caseFun aux var cse =
926 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
928 getTag :: SAlt -> Maybe Int
929 getTag (SConCase _ tag _ _ _) = Just tag
930 getTag _ = Nothing
932 lookupTableName :: String
933 lookupTableName = idrLTNamespace ++ translateName name
935 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
936 lookupTable aux var cases =
937 JSAlloc lookupTableName $ Just (
938 JSApp (JSFunction [] (
939 JSSeq $ [
940 JSAlloc "t" $ Just (JSArray [])
941 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
942 JSReturn (JSIdent "t")
943 ]
944 )) []
945 )
946 where
947 assignEntries :: [(Int, JS)] -> [JS]
948 assignEntries entries =
949 map (\(tag, fun) ->
950 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
951 ) entries
953 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
954 lookupEntry aux var alt = do
955 tag <- getTag alt
956 return (tag, caseFun aux var alt)
958 jsDecl :: JS -> JS
959 jsDecl = JSAlloc (path ++ translateName name) . Just
961 jsFun body = jsFunAux [] body
963 jsFunAux :: [(LVar, String)] -> JS -> JS
964 jsFunAux aux body =
965 JSFunction (p ++ map snd aux) (
966 JSSeq $
967 zipWith assignVar [0..] p ++
968 map assignAux aux ++
969 [JSReturn body]
970 )
971 where
972 assignVar :: Int -> String -> JS
973 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
975 assignAux :: (LVar, String) -> JS
976 assignAux (Loc var, val) =
977 JSAlloc (jsVar var) (Just $ JSIdent val)
979 p :: [String]
980 p = map translateName params
982translateVariableName :: LVar -> String
983translateVariableName (Loc i) =
984 jsVar i
986translateExpression :: SExp -> JS
987translateExpression (SLet name value body) =
988 jsLet (translateVariableName name) (
989 translateExpression value
990 ) (translateExpression body)
992translateExpression (SConst cst) =
993 translateConstant cst
995translateExpression (SV var) =
996 JSVar var
998translateExpression (SApp tc name vars)
999 | False <- tc =
1000 jsTailcall $ translateFunctionCall name vars
1001 | True <- tc =
1002 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1003 JSReturn $ translateFunctionCall name vars
1004 )]
1005 where
1006 translateFunctionCall name vars =
1007 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1009translateExpression (SOp op vars)
1010 | LNoOp <- op = JSVar (last vars)
1012 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1013 | (LPlus (ATInt ITBig)) <- op
1014 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1015 | (LMinus (ATInt ITBig)) <- op
1016 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1017 | (LTimes (ATInt ITBig)) <- op
1018 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1019 | (LSDiv (ATInt ITBig)) <- op
1020 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1021 | (LSRem (ATInt ITBig)) <- op
1022 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1023 | (LEq (ATInt ITBig)) <- op
1024 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1025 | (LSLt (ATInt ITBig)) <- op
1026 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1027 | (LSLe (ATInt ITBig)) <- op
1028 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1029 | (LSGt (ATInt ITBig)) <- op
1030 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1031 | (LSGe (ATInt ITBig)) <- op
1032 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1034 | (LPlus ATFloat) <- op
1035 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1036 | (LMinus ATFloat) <- op
1037 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1038 | (LTimes ATFloat) <- op
1039 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1040 | (LSDiv ATFloat) <- op
1041 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1042 | (LEq ATFloat) <- op
1043 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1044 | (LSLt ATFloat) <- op
1045 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1046 | (LSLe ATFloat) <- op
1047 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1048 | (LSGt ATFloat) <- op
1049 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1050 | (LSGe ATFloat) <- op
1051 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1053 | (LPlus _) <- op
1054 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1055 | (LMinus _) <- op
1056 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1057 | (LTimes _) <- op
1058 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1059 | (LSDiv _) <- op
1060 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1061 | (LSRem _) <- op
1062 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1063 | (LEq _) <- op
1064 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1065 | (LSLt _) <- op
1066 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1067 | (LSLe _) <- op
1068 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1069 | (LSGt _) <- op
1070 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1071 | (LSGe _) <- op
1072 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1073 | (LAnd _) <- op
1074 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1075 | (LOr _) <- op
1076 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1077 | (LXOr _) <- op
1078 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1079 | (LSHL _) <- op
1080 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1081 | (LASHR _) <- op
1082 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1083 | (LCompl _) <- op
1084 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
1086 | LStrConcat <- op
1087 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1088 | LStrEq <- op
1089 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1090 | LStrLt <- op
1091 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1092 | LStrLen <- op
1093 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1095 | (LStrInt ITNative) <- op
1096 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1097 | (LIntStr ITNative) <- op
1098 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1099 | (LSExt ITNative ITBig) <- op
1100 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1101 | (LTrunc ITBig ITNative) <- op
1102 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1103 | (LIntStr ITBig) <- op
1104 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1105 | (LStrInt ITBig) <- op
1106 , (arg:_) <- vars = jsBigInt $ JSVar arg
1107 | LFloatStr <- op
1108 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1109 | LStrFloat <- op
1110 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1111 | (LIntFloat ITNative) <- op
1112 , (arg:_) <- vars = JSVar arg
1113 | (LFloatInt ITNative) <- op
1114 , (arg:_) <- vars = JSVar arg
1115 | (LChInt ITNative) <- op
1116 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1117 | (LIntCh ITNative) <- op
1118 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1120 | LFExp <- op
1121 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1122 | LFLog <- op
1123 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1124 | LFSin <- op
1125 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1126 | LFCos <- op
1127 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1128 | LFTan <- op
1129 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1130 | LFASin <- op
1131 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1132 | LFACos <- op
1133 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1134 | LFATan <- op
1135 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1136 | LFSqrt <- op
1137 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1138 | LFFloor <- op
1139 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1140 | LFCeil <- op
1141 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1143 | LStrCons <- op
1144 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1145 | LStrHead <- op
1146 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1147 | LStrRev <- op
1148 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1149 | LStrIndex <- op
1150 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1151 | LStrTail <- op
1152 , (arg:_) <- vars = let v = translateVariableName arg in
1153 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
1154 | LNullPtr <- op
1155 , (_) <- vars = JSNull
1157 where
1158 translateBinaryOp :: String -> LVar -> LVar -> JS
1159 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
1161 invokeMeth :: LVar -> String -> [LVar] -> JS
1162 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1164translateExpression (SError msg) =
1165 JSError msg
1167translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1168 jsCall (idrRTNamespace ++ "print") [JSVar var]
1170translateExpression (SForeign _ _ fun args) =
1171 ffi fun (map generateWrapper args)
1172 where
1173 generateWrapper (ffunc, name)
1174 | FFunction <- ffunc =
1175 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1176 | FFunctionIO <- ffunc =
1177 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1179 generateWrapper (_, name) =
1180 translateVariableName name
1182translateExpression patterncase
1183 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1184 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1185 where
1186 caseHelper var cases param =
1187 JSApp (JSFunction [param] (
1188 JSCond $ map (expandCase param . translateCaseCond param) cases
1189 )) [JSVar var]
1191 expandCase :: String -> (Cond, JS) -> (JS, JS)
1192 expandCase _ (RawCond cond, branch) = (cond, branch)
1193 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1194 expandCase var (CaseCond caseTy, branch)
1195 | ConCase tag <- caseTy =
1196 let checkCon = JSIdent var `jsInstanceOf` jsCon
1197 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1198 (checkCon `jsAnd` checkTag, branch)
1200 | TypeCase ty <- caseTy =
1201 let checkTy = JSIdent var `jsInstanceOf` jsType
1202 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1203 (checkTy `jsAnd` checkTag, branch)
1205translateExpression (SCon i name vars) =
1206 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1207 , JSArray $ map JSVar vars
1210translateExpression (SUpdate var@(Loc i) e) =
1211 JSAssign (JSVar var) (translateExpression e)
1213translateExpression (SProj var i) =
1214 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1216translateExpression SNothing = JSNull
1218translateExpression e =
1219 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1221data FFI = FFICode Char | FFIArg Int | FFIError String
1223ffi :: String -> [String] -> JS
1224ffi code args = let parsed = ffiParse code in
1225 case ffiError parsed of
1226 Just err -> JSError err
1227 Nothing -> JSRaw $ renderFFI parsed args
1228 where
1229 ffiParse :: String -> [FFI]
1230 ffiParse "" = []
1231 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1232 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1233 ffiParse ('%':s:ss)
1234 | isDigit s =
1235 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1236 | otherwise =
1237 [FFIError "Invalid positional argument"]
1238 ffiParse (s:ss) = FFICode s : ffiParse ss
1240 ffiError :: [FFI] -> Maybe String
1241 ffiError [] = Nothing
1242 ffiError ((FFIError s):xs) = Just s
1243 ffiError (x:xs) = ffiError xs
1245 renderFFI :: [FFI] -> [String] -> String
1246 renderFFI [] _ = ""
1247 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1248 renderFFI ((FFIArg i) : fs) args
1249 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1250 | otherwise = "Argument index out of bounds"
1252data CaseType = ConCase Int
1253 | TypeCase JSType
1254 | DefaultCase
1255 deriving Eq
1257data Cond = CaseCond CaseType
1258 | RawCond JS
1260translateCaseCond :: String -> SAlt -> (Cond, JS)
1261translateCaseCond _ cse@(SDefaultCase _) =
1262 (CaseCond DefaultCase, translateCase Nothing cse)
1264translateCaseCond var cse@(SConstCase ty _)
1265 | StrType <- ty = matchHelper JSStringTy
1266 | PtrType <- ty = matchHelper JSPtrTy
1267 | Forgot <- ty = matchHelper JSForgotTy
1268 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1269 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1270 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1271 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1272 where
1273 matchHelper :: JSType -> (Cond, JS)
1274 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1276translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1277 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1278 (RawCond cond, translateCase Nothing cse)
1280translateCaseCond var cse@(SConstCase cst _) =
1281 let cond = JSIdent var `jsEq` translateConstant cst in
1282 (RawCond cond, translateCase Nothing cse)
1284translateCaseCond var cse@(SConCase _ tag _ _ _) =
1285 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1287translateCase :: Maybe String -> SAlt -> JS
1288translateCase _ (SDefaultCase e) = translateExpression e
1289translateCase _ (SConstCase _ e) = translateExpression e
1290translateCase (Just var) (SConCase a _ _ vars e) =
1291 let params = map jsVar [a .. (a + length vars)] in
1292 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1293 JSThis, JSProj (JSIdent var) "vars"