git.iko.soy/Idris-dev
on d1663cc help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1134 lines 37 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 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 | JSNum JSNum
68 | JSAssign JS JS
69 | JSAlloc String (Maybe JS)
70 | JSIndex JS JS
71 | JSCond [(JS, JS)]
72 | JSTernary JS JS JS
73 deriving Eq
75compileJS :: JS -> String
76compileJS (JSRaw code) =
77 code
79compileJS (JSIdent ident) =
80 ident
82compileJS (JSFunction args body) =
83 "function("
84 ++ intercalate "," args
85 ++ "){\n"
86 ++ compileJS body
87 ++ "\n}"
89compileJS (JSType ty)
90 | JSIntTy <- ty = idrRTNamespace ++ "Int"
91 | JSStringTy <- ty = idrRTNamespace ++ "String"
92 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
93 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
94 | JSCharTy <- ty = idrRTNamespace ++ "Char"
95 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
96 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
98compileJS (JSSeq seq) =
99 intercalate ";\n" (map compileJS seq)
101compileJS (JSReturn val) =
102 "return " ++ compileJS val
104compileJS (JSApp lhs rhs)
105 | JSFunction {} <- lhs =
106 concat ["(", compileJS lhs, ")(", args, ")"]
107 | otherwise =
108 concat [compileJS lhs, "(", args, ")"]
109 where args :: String
110 args = intercalate "," $ map compileJS rhs
112compileJS (JSNew name args) =
113 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
115compileJS (JSError exc) =
116 "(function(){throw '" ++ exc ++ "';})()"
118compileJS (JSOp op lhs rhs) =
119 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
121compileJS (JSProj obj field)
122 | JSFunction {} <- obj =
123 concat ["(", compileJS obj, ").", field]
124 | JSAssign {} <- obj =
125 concat ["(", compileJS obj, ").", field]
126 | otherwise =
127 compileJS obj ++ '.' : field
129compileJS (JSVar var) =
130 translateVariableName var
132compileJS JSNull =
133 "null"
135compileJS JSThis =
136 "this"
138compileJS JSTrue =
139 "true"
141compileJS JSFalse =
142 "false"
144compileJS (JSArray elems) =
145 "[" ++ intercalate "," (map compileJS elems) ++ "]"
147compileJS (JSObject fields) =
148 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
149 where
150 compileField :: (String, JS) -> String
151 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
153compileJS (JSString str) =
154 show str
156compileJS (JSNum num)
157 | JSInt i <- num = show i
158 | JSFloat f <- num = show f
159 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
160 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
161 | JSInteger (JSBigInt i) <- num = show i
163compileJS (JSAssign lhs rhs) =
164 compileJS lhs ++ "=" ++ compileJS rhs
166compileJS (JSAlloc name val) =
167 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
169compileJS (JSIndex lhs rhs) =
170 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
172compileJS (JSCond branches) =
173 intercalate " else " $ map createIfBlock branches
174 where
175 createIfBlock (cond, e) =
176 "if (" ++ compileJS cond ++") {\n"
177 ++ "return " ++ compileJS e
178 ++ ";\n}"
180compileJS (JSTernary cond true false) =
181 let c = compileJS cond
182 t = compileJS true
183 f = compileJS false in
184 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
186jsTailcall :: JS -> JS
187jsTailcall call =
188 jsCall (idrRTNamespace ++ "tailcall") [
189 JSFunction [] (JSReturn call)
190 ]
192jsCall :: String -> [JS] -> JS
193jsCall fun = JSApp (JSIdent fun)
195jsMeth :: JS -> String -> [JS] -> JS
196jsMeth obj meth =
197 JSApp (JSProj obj meth)
199jsInstanceOf :: JS -> JS -> JS
200jsInstanceOf = JSOp "instanceof"
202jsEq :: JS -> JS -> JS
203jsEq = JSOp "=="
205jsAnd :: JS -> JS -> JS
206jsAnd = JSOp "&&"
208jsType :: JS
209jsType = JSIdent $ idrRTNamespace ++ "Type"
211jsCon :: JS
212jsCon = JSIdent $ idrRTNamespace ++ "Con"
214jsTag :: JS -> JS
215jsTag obj = JSProj obj "tag"
217jsTypeTag :: JS -> JS
218jsTypeTag obj = JSProj obj "type"
220jsBigInt :: JS -> JS
221jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
222jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
223jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
225jsVar :: Int -> String
226jsVar = ("__var_" ++) . show
228jsLet :: String -> JS -> JS -> JS
229jsLet name value body =
230 JSApp (
231 JSFunction [name] (
232 JSReturn body
233 )
234 ) [value]
236jsSubst :: String -> JS -> JS -> JS
237jsSubst var new (JSVar old)
238 | var == translateVariableName old = new
239 | otherwise = JSVar old
241jsSubst var new (JSIdent old)
242 | var == old = new
243 | otherwise = JSIdent old
245jsSubst var new (JSArray fields) =
246 JSArray (map (jsSubst var new) fields)
248jsSubst var new (JSNew con [tag, vals]) =
249 JSNew con [tag, jsSubst var new vals]
251jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
252 JSNew con [JSFunction [] (
253 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) vars)
254 )]
256jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
257 JSReturn (JSApp fun args)
258 )]) =
259 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
260 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)
261 )]
263jsSubst var new (JSApp (JSProj obj field) args) =
264 JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args
266jsSubst var new (JSApp (JSFunction [arg] body) vals)
267 | var /= arg =
268 JSApp (JSFunction [arg] (
269 jsSubst var new body
270 )) $ map (jsSubst var new) vals
271 | otherwise =
272 JSApp (JSFunction [arg] (
273 body
274 )) $ map (jsSubst var new) vals
276jsSubst var new (JSReturn ret) =
277 JSReturn $ jsSubst var new ret
279jsSubst var new (JSProj obj field) =
280 JSProj (jsSubst var new obj) field
282jsSubst var new (JSSeq body) =
283 JSSeq $ map (jsSubst var new) body
285jsSubst var new (JSOp op lhs rhs) =
286 JSOp op (jsSubst var new lhs) (jsSubst var new rhs)
288jsSubst var new (JSIndex obj field) =
289 JSIndex (jsSubst var new obj) (jsSubst var new field)
291jsSubst var new (JSCond conds) =
292 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)
294jsSubst _ _ js = js
296inlineJS :: JS -> JS
297inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
298 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
300inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
301 | JSNew con [tag, vals] <- ret
302 , opt <- inlineJS val =
303 JSNew con [tag, jsSubst arg opt vals]
305 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
306 , opt <- inlineJS val =
307 JSNew con [JSFunction [] (
308 JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) vars)
309 )]
311 | JSApp (JSProj obj field) args <- ret
312 , opt <- inlineJS val =
313 JSApp (JSProj (jsSubst arg opt obj) field) $ map (jsSubst arg opt) args
315 | JSIndex (JSProj obj field) idx <- ret
316 , opt <- inlineJS val =
317 JSIndex (JSProj (
318 jsSubst arg opt obj
319 ) field
320 ) (jsSubst arg opt idx)
322 | JSOp op lhs rhs <- ret
323 , opt <- inlineJS val =
324 JSOp op (jsSubst arg opt lhs) $
325 (jsSubst arg opt rhs)
327 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
328 JSReturn (JSApp fun args)
329 )] <- ret
330 , opt <- inlineJS val =
331 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
332 JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) args)
333 )]
335inlineJS (JSApp fun args) =
336 JSApp (inlineJS fun) (map inlineJS args)
338inlineJS (JSNew con args) =
339 JSNew con $ map inlineJS args
341inlineJS (JSArray fields) =
342 JSArray (map inlineJS fields)
344inlineJS (JSAssign lhs rhs) =
345 JSAssign (inlineJS lhs) (inlineJS rhs)
347inlineJS (JSSeq seq) =
348 JSSeq (map inlineJS seq)
350inlineJS (JSFunction args body) =
351 JSFunction args (inlineJS body)
353inlineJS (JSProj (JSFunction args body) field) =
354 JSProj (JSFunction args (inlineJS body)) field
356inlineJS (JSReturn js) =
357 JSReturn $ inlineJS js
359inlineJS (JSAlloc name (Just js)) =
360 JSAlloc name (Just $ inlineJS js)
362inlineJS (JSCond cases) =
363 JSCond (map (second inlineJS) cases)
365inlineJS (JSObject fields) =
366 JSObject (map (second inlineJS) fields)
368inlineJS js = js
370reduceJS :: [JS] -> [JS]
371reduceJS js = reduceLoop [] ([], js)
373funName :: JS -> String
374funName (JSAlloc fun _) = fun
376removeIDs :: [JS] -> [JS]
377removeIDs js =
378 case partition isID js of
379 ([], rest) -> rest
380 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
381 where isID :: JS -> Bool
382 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
383 | JSReturn (JSVar _) <- last body = True
385 isID _ = False
387 idFor :: JS -> (String, Int)
388 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
389 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
391 removeIDCall :: [(String, Int)] -> JS -> JS
392 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
393 JSReturn (JSApp (JSIdent fun) args)
394 )])
395 | Just pos <- lookup fun ids
396 , pos < length args = args !! pos
398 removeIDCall ids (JSNew _ [JSFunction [] (
399 JSReturn (JSApp (JSIdent fun) args)
400 )])
401 | Just pos <- lookup fun ids
402 , pos < length args = args !! pos
404 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
405 | Just pos <- lookup fun ids
406 , pos < length args = args !! pos
408 removeIDCall ids (JSAlloc fun (Just body)) =
409 JSAlloc fun (Just $ removeIDCall ids body)
411 removeIDCall ids (JSReturn js) =
412 JSReturn $ removeIDCall ids js
414 removeIDCall ids (JSSeq js) =
415 JSSeq $ map (removeIDCall ids) js
417 removeIDCall ids (JSNew con args) =
418 JSNew con $ map (removeIDCall ids) args
420 removeIDCall ids (JSFunction args body) =
421 JSFunction args $ removeIDCall ids body
423 removeIDCall ids (JSApp fun args) =
424 JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args
426 removeIDCall ids (JSProj obj field) =
427 JSProj (removeIDCall ids obj) field
429 removeIDCall ids (JSCond conds) =
430 JSCond $ map (removeIDCall ids *** removeIDCall ids) conds
432 removeIDCall ids (JSAssign lhs rhs) =
433 JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs)
435 removeIDCall ids (JSArray fields) =
436 JSArray $ map (removeIDCall ids) fields
438 removeIDCall _ js = js
440reduceConstant :: JS -> JS
441reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
442 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
443 )]) = JSNum num
445reduceConstant (JSReturn ret) =
446 JSReturn (reduceConstant ret)
448reduceConstant (JSApp fun args) =
449 JSApp (reduceConstant fun) (map reduceConstant args)
451reduceConstant (JSArray fields) =
452 JSArray (map reduceConstant fields)
454reduceConstant (JSAlloc name (Just val)) =
455 JSAlloc name $ Just (reduceConstant val)
457reduceConstant (JSNew con args) =
458 JSNew con (map reduceConstant args)
460reduceConstant (JSProj obj field) =
461 JSProj (reduceConstant obj) field
463reduceConstant (JSCond conds) =
464 JSCond $ map (reduceConstant *** reduceConstant) conds
466reduceConstant (JSSeq seq) =
467 JSSeq $ map reduceConstant seq
469reduceConstant (JSFunction args body) =
470 JSFunction args (reduceConstant body)
472reduceConstant js = js
474reduceConstants :: JS -> JS
475reduceConstants js
476 | ret <- reduceConstant js
477 , ret /= js = reduceConstants ret
478 | otherwise = js
480reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
481reduceLoop reduced (cons, program) =
482 case partition findConstructors program of
483 ([], js) -> cons ++ js
484 (candidates, rest) ->
485 let names = reduced ++ map funName candidates in
486 reduceLoop names (
487 cons ++ map reduce candidates, map (reduceCall names) rest
488 )
489 where findConstructors :: JS -> Bool
490 findConstructors js
491 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
492 reducable $ last body
493 | otherwise = False
494 where reducable :: JS -> Bool
495 reducable (JSReturn js) = reducable js
496 reducable (JSNew _ args) = and $ map reducable args
497 reducable (JSArray fields) = and $ map reducable fields
498 reducable (JSNum _) = True
499 reducable JSNull = True
500 reducable (JSIdent _) = True
501 reducable _ = False
503 reduce :: JS -> JS
504 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
505 | JSReturn js <- last body = (JSAlloc fun (Just js))
507 reduce js = js
509 reduceCall :: [String] -> JS -> JS
510 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
511 JSReturn (JSApp id@(JSIdent ret) _)
512 )])
513 | ret `elem` funs = id
515 reduceCall funs js@(JSApp id@(JSIdent fun) _)
516 | fun `elem` funs = id
518 reduceCall funs (JSAlloc fun (Just body)) =
519 JSAlloc fun (Just $ reduceCall funs body)
521 reduceCall funs (JSReturn js) =
522 JSReturn $ reduceCall funs js
524 reduceCall funs (JSSeq js) =
525 JSSeq $ map (reduceCall funs) js
527 reduceCall funs (JSNew con args) =
528 JSNew con $ map (reduceCall funs) args
530 reduceCall funs (JSFunction args body) =
531 JSFunction args $ reduceCall funs body
533 reduceCall funs (JSApp fun args) =
534 JSApp (reduceCall funs fun) $ map (reduceCall funs) args
536 reduceCall funs (JSProj obj field) =
537 JSProj (reduceCall funs obj) field
539 reduceCall funs (JSCond conds) =
540 JSCond $ map (reduceCall funs *** reduceCall funs) conds
542 reduceCall funs (JSAssign lhs rhs) =
543 JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
545 reduceCall funs (JSArray fields) =
546 JSArray $ map (reduceCall funs) fields
548 reduceCall _ js = js
550optimizeJS :: JS -> JS
551optimizeJS = inlineLoop
552 where inlineLoop :: JS -> JS
553 inlineLoop js
554 | opt <- inlineJS js
555 , opt /= js = inlineLoop opt
556 | otherwise = js
558codegenJavaScript
559 :: JSTarget
560 -> [(Name, SDecl)]
561 -> FilePath
562 -> OutputType
563 -> IO ()
564codegenJavaScript target definitions filename outputType = do
565 let (header, runtime) = case target of
566 Node ->
567 ("#!/usr/bin/env node\n", "-node")
568 JavaScript ->
569 ("", "-browser")
570 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
571 idrRuntime <- readFile $ path ++ "Runtime-common.js"
572 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
573 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
574 writeFile filename $ header ++ (
575 intercalate "\n" $ [ jsbn
576 , idrRuntime
577 , tgtRuntime
578 ] ++ functions ++ [mainLoop, invokeLoop]
579 )
581 setPermissions filename (emptyPermissions { readable = True
582 , executable = target == Node
583 , writable = True
584 })
585 where
586 def :: [(String, SDecl)]
587 def = map (first translateNamespace) definitions
589 functions :: [String]
590 functions =
591 map (compileJS . reduceConstants) ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def)
593 mainLoop :: String
594 mainLoop = compileJS $
595 JSAlloc "main" $ Just $ JSFunction [] (
596 case target of
597 Node -> mainFun
598 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
599 JSString "DOMContentLoaded", JSFunction [] (
600 mainFun
601 ), JSFalse
602 ]
603 )
604 where
605 mainFun :: JS
606 mainFun = jsTailcall $ jsCall runMain []
608 runMain :: String
609 runMain = idrNamespace ++ translateName (MN 0 "runMain")
611 invokeLoop :: String
612 invokeLoop = compileJS $ jsCall "main" []
614translateIdentifier :: String -> String
615translateIdentifier =
616 replaceReserved . concatMap replaceBadChars
617 where replaceBadChars :: Char -> String
618 replaceBadChars c
619 | ' ' <- c = "_"
620 | '_' <- c = "__"
621 | isDigit c = '_' : show (ord c)
622 | not (isLetter c && isAscii c) = '_' : show (ord c)
623 | otherwise = [c]
624 replaceReserved s
625 | s `elem` reserved = '_' : s
626 | otherwise = s
627 reserved = [ "break"
628 , "case"
629 , "catch"
630 , "continue"
631 , "debugger"
632 , "default"
633 , "delete"
634 , "do"
635 , "else"
636 , "finally"
637 , "for"
638 , "function"
639 , "if"
640 , "in"
641 , "instanceof"
642 , "new"
643 , "return"
644 , "switch"
645 , "this"
646 , "throw"
647 , "try"
648 , "typeof"
649 , "var"
650 , "void"
651 , "while"
652 , "with"
654 , "class"
655 , "enum"
656 , "export"
657 , "extends"
658 , "import"
659 , "super"
661 , "implements"
662 , "interface"
663 , "let"
664 , "package"
665 , "private"
666 , "protected"
667 , "public"
668 , "static"
669 , "yield"
670 ]
672translateNamespace :: Name -> String
673translateNamespace (UN _) = idrNamespace
674translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
675translateNamespace (MN _ _) = idrNamespace
676translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
677translateNamespace NErased = idrNamespace
679translateName :: Name -> String
680translateName (UN name) = 'u' : translateIdentifier name
681translateName (NS name _) = 'n' : translateName name
682translateName (MN i name) = 'm' : translateIdentifier name ++ show i
683translateName (SN name) = 's' : translateSpecialName name
684translateName NErased = "e"
686translateSpecialName :: SpecialName -> String
687translateSpecialName name
688 | WhereN i m n <- name =
689 'w' : translateName m ++ translateName n ++ show i
690 | InstanceN n s <- name =
691 'i' : translateName n ++ concatMap translateIdentifier s
692 | ParentN n s <- name =
693 'p' : translateName n ++ translateIdentifier s
694 | MethodN n <- name =
695 'm' : translateName n
696 | CaseN n <- name =
697 'c' : translateName n
699translateConstant :: Const -> JS
700translateConstant (I i) = JSNum (JSInt i)
701translateConstant (Fl f) = JSNum (JSFloat f)
702translateConstant (Ch c) = JSString [c]
703translateConstant (Str s) = JSString s
704translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
705translateConstant StrType = JSType JSStringTy
706translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
707translateConstant (AType ATFloat) = JSType JSFloatTy
708translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
709translateConstant PtrType = JSType JSPtrTy
710translateConstant Forgot = JSType JSForgotTy
711translateConstant (BI i) = jsBigInt $ JSString (show i)
712translateConstant c =
713 JSError $ "Unimplemented Constant: " ++ show c
715translateDeclaration :: (String, SDecl) -> JS
716translateDeclaration (path, SFun name params stackSize body)
717 | (MN _ "APPLY") <- name
718 , (SLet var val next) <- body
719 , (SChkCase cvar cases) <- next =
720 let lvar = translateVariableName var
721 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
722 JSSeq [ lookupTable [(var, "chk")] var cases
723 , jsDecl $ JSFunction ["fn0", "arg0"] (
724 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
725 , JSReturn $ jsLet (translateVariableName var) (
726 translateExpression val
727 ) (JSTernary (
728 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
729 (hasProp lookupTableName (translateVariableName var))
730 ) (JSIdent $
731 lookupTableName ++ lookup
732 ) JSNull
733 )
734 ]
735 )
736 ]
738 | (MN _ "EVAL") <- name
739 , (SChkCase var cases) <- body =
740 JSSeq [ lookupTable [] var cases
741 , jsDecl $ JSFunction ["arg0"] (JSReturn $
742 JSTernary (
743 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
744 (hasProp lookupTableName "arg0")
745 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0")
746 )
747 ]
748 | otherwise =
749 let fun = translateExpression body in
750 jsDecl $ jsFun fun
752 where
753 hasProp :: String -> String -> JS
754 hasProp table var =
755 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
757 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
758 caseFun aux var cse =
759 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
761 getTag :: SAlt -> Maybe Int
762 getTag (SConCase _ tag _ _ _) = Just tag
763 getTag _ = Nothing
765 lookupTableName :: String
766 lookupTableName = idrLTNamespace ++ translateName name
768 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
769 lookupTable aux var cases =
770 JSAlloc lookupTableName $ Just (
771 JSApp (JSFunction [] (
772 JSSeq $ [
773 JSAlloc "t" $ Just (JSArray [])
774 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
775 JSReturn (JSIdent "t")
776 ]
777 )) []
778 )
779 where
780 assignEntries :: [(Int, JS)] -> [JS]
781 assignEntries entries =
782 map (\(tag, fun) ->
783 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
784 ) entries
786 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
787 lookupEntry aux var alt = do
788 tag <- getTag alt
789 return (tag, caseFun aux var alt)
791 jsDecl :: JS -> JS
792 jsDecl = JSAlloc (path ++ translateName name) . Just
794 jsFun body = jsFunAux [] body
796 jsFunAux :: [(LVar, String)] -> JS -> JS
797 jsFunAux aux body =
798 JSFunction (p ++ map snd aux) (
799 JSSeq $
800 zipWith assignVar [0..] p ++
801 map allocVar [numP .. (numP + stackSize - 1)] ++
802 map assignAux aux ++
803 [JSReturn body]
804 )
805 where
806 numP :: Int
807 numP = length params
809 allocVar :: Int -> JS
810 allocVar n = JSAlloc (jsVar n) Nothing
812 assignVar :: Int -> String -> JS
813 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
815 assignAux :: (LVar, String) -> JS
816 assignAux (var, val) =
817 JSAssign (JSIdent $ translateVariableName var) (JSIdent val)
819 p :: [String]
820 p = map translateName params
822translateVariableName :: LVar -> String
823translateVariableName (Loc i) =
824 jsVar i
826translateExpression :: SExp -> JS
827translateExpression (SLet name value body) =
828 jsLet (translateVariableName name) (
829 translateExpression value
830 ) (translateExpression body)
832translateExpression (SConst cst) =
833 translateConstant cst
835translateExpression (SV var) =
836 JSVar var
838translateExpression (SApp tc name vars)
839 | False <- tc =
840 jsTailcall $ translateFunctionCall name vars
841 | True <- tc =
842 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
843 JSReturn $ translateFunctionCall name vars
844 )]
845 where
846 translateFunctionCall name vars =
847 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
849translateExpression (SOp op vars)
850 | LNoOp <- op = JSVar (last vars)
852 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
853 | (LPlus (ATInt ITBig)) <- op
854 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
855 | (LMinus (ATInt ITBig)) <- op
856 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
857 | (LTimes (ATInt ITBig)) <- op
858 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
859 | (LSDiv (ATInt ITBig)) <- op
860 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
861 | (LSRem (ATInt ITBig)) <- op
862 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
863 | (LEq (ATInt ITBig)) <- op
864 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
865 | (LSLt (ATInt ITBig)) <- op
866 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
867 | (LSLe (ATInt ITBig)) <- op
868 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
869 | (LSGt (ATInt ITBig)) <- op
870 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
871 | (LSGe (ATInt ITBig)) <- op
872 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
874 | (LPlus ATFloat) <- op
875 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
876 | (LMinus ATFloat) <- op
877 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
878 | (LTimes ATFloat) <- op
879 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
880 | (LSDiv ATFloat) <- op
881 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
882 | (LEq ATFloat) <- op
883 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
884 | (LSLt ATFloat) <- op
885 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
886 | (LSLe ATFloat) <- op
887 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
888 | (LSGt ATFloat) <- op
889 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
890 | (LSGe ATFloat) <- op
891 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
893 | (LPlus _) <- op
894 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
895 | (LMinus _) <- op
896 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
897 | (LTimes _) <- op
898 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
899 | (LSDiv _) <- op
900 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
901 | (LSRem _) <- op
902 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
903 | (LEq _) <- op
904 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
905 | (LSLt _) <- op
906 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
907 | (LSLe _) <- op
908 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
909 | (LSGt _) <- op
910 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
911 | (LSGe _) <- op
912 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
913 | (LAnd _) <- op
914 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
915 | (LOr _) <- op
916 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
917 | (LXOr _) <- op
918 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
919 | (LSHL _) <- op
920 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
921 | (LASHR _) <- op
922 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
923 | (LCompl _) <- op
924 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
926 | LStrConcat <- op
927 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
928 | LStrEq <- op
929 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
930 | LStrLt <- op
931 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
932 | LStrLen <- op
933 , (arg:_) <- vars = JSProj (JSVar arg) "length"
935 | (LStrInt ITNative) <- op
936 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
937 | (LIntStr ITNative) <- op
938 , (arg:_) <- vars = jsCall "String" [JSVar arg]
939 | (LSExt ITNative ITBig) <- op
940 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
941 | (LTrunc ITBig ITNative) <- op
942 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
943 | (LIntStr ITBig) <- op
944 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
945 | (LStrInt ITBig) <- op
946 , (arg:_) <- vars = jsBigInt $ JSVar arg
947 | LFloatStr <- op
948 , (arg:_) <- vars = jsCall "String" [JSVar arg]
949 | LStrFloat <- op
950 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
951 | (LIntFloat ITNative) <- op
952 , (arg:_) <- vars = JSVar arg
953 | (LFloatInt ITNative) <- op
954 , (arg:_) <- vars = JSVar arg
955 | (LChInt ITNative) <- op
956 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
957 | (LIntCh ITNative) <- op
958 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
960 | LFExp <- op
961 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
962 | LFLog <- op
963 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
964 | LFSin <- op
965 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
966 | LFCos <- op
967 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
968 | LFTan <- op
969 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
970 | LFASin <- op
971 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
972 | LFACos <- op
973 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
974 | LFATan <- op
975 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
976 | LFSqrt <- op
977 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
978 | LFFloor <- op
979 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
980 | LFCeil <- op
981 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
983 | LStrCons <- op
984 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
985 | LStrHead <- op
986 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
987 | LStrRev <- op
988 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
989 | LStrIndex <- op
990 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
991 | LStrTail <- op
992 , (arg:_) <- vars = let v = translateVariableName arg in
993 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
994 | LNullPtr <- op
995 , (_) <- vars = JSNull
997 where
998 translateBinaryOp :: String -> LVar -> LVar -> JS
999 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
1001 invokeMeth :: LVar -> String -> [LVar] -> JS
1002 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1004translateExpression (SError msg) =
1005 JSError msg
1007translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1008 jsCall (idrRTNamespace ++ "print") [JSVar var]
1010translateExpression (SForeign _ _ fun args) =
1011 ffi fun (map generateWrapper args)
1012 where
1013 generateWrapper (ffunc, name)
1014 | FFunction <- ffunc =
1015 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1016 | FFunctionIO <- ffunc =
1017 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1019 generateWrapper (_, name) =
1020 translateVariableName name
1022translateExpression patterncase
1023 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1024 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1025 where
1026 caseHelper var cases param =
1027 JSApp (JSFunction [param] (
1028 JSCond $ map (expandCase param . translateCaseCond param) cases
1029 )) [JSVar var]
1031 expandCase :: String -> (Cond, JS) -> (JS, JS)
1032 expandCase _ (RawCond cond, branch) = (cond, branch)
1033 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1034 expandCase var (CaseCond caseTy, branch)
1035 | ConCase tag <- caseTy =
1036 let checkCon = JSIdent var `jsInstanceOf` jsCon
1037 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1038 (checkCon `jsAnd` checkTag, branch)
1040 | TypeCase ty <- caseTy =
1041 let checkTy = JSIdent var `jsInstanceOf` jsType
1042 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1043 (checkTy `jsAnd` checkTag, branch)
1045translateExpression (SCon i name vars) =
1046 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1047 , JSArray $ map JSVar vars
1050translateExpression (SUpdate var@(Loc i) e) =
1051 JSAssign (JSVar var) (translateExpression e)
1053translateExpression (SProj var i) =
1054 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1056translateExpression SNothing = JSNull
1058translateExpression e =
1059 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1061data FFI = FFICode Char | FFIArg Int | FFIError String
1063ffi :: String -> [String] -> JS
1064ffi code args = let parsed = ffiParse code in
1065 case ffiError parsed of
1066 Just err -> JSError err
1067 Nothing -> JSRaw $ renderFFI parsed args
1068 where
1069 ffiParse :: String -> [FFI]
1070 ffiParse "" = []
1071 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1072 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1073 ffiParse ('%':s:ss)
1074 | isDigit s =
1075 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1076 | otherwise =
1077 [FFIError "Invalid positional argument"]
1078 ffiParse (s:ss) = FFICode s : ffiParse ss
1080 ffiError :: [FFI] -> Maybe String
1081 ffiError [] = Nothing
1082 ffiError ((FFIError s):xs) = Just s
1083 ffiError (x:xs) = ffiError xs
1085 renderFFI :: [FFI] -> [String] -> String
1086 renderFFI [] _ = ""
1087 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1088 renderFFI ((FFIArg i) : fs) args
1089 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1090 | otherwise = "Argument index out of bounds"
1092data CaseType = ConCase Int
1093 | TypeCase JSType
1094 | DefaultCase
1095 deriving Eq
1097data Cond = CaseCond CaseType
1098 | RawCond JS
1100translateCaseCond :: String -> SAlt -> (Cond, JS)
1101translateCaseCond _ cse@(SDefaultCase _) =
1102 (CaseCond DefaultCase, translateCase Nothing cse)
1104translateCaseCond var cse@(SConstCase ty _)
1105 | StrType <- ty = matchHelper JSStringTy
1106 | PtrType <- ty = matchHelper JSPtrTy
1107 | Forgot <- ty = matchHelper JSForgotTy
1108 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1109 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1110 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1111 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1112 where
1113 matchHelper :: JSType -> (Cond, JS)
1114 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1116translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1117 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1118 (RawCond cond, translateCase Nothing cse)
1120translateCaseCond var cse@(SConstCase cst _) =
1121 let cond = JSIdent var `jsEq` translateConstant cst in
1122 (RawCond cond, translateCase Nothing cse)
1124translateCaseCond var cse@(SConCase _ tag _ _ _) =
1125 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1127translateCase :: Maybe String -> SAlt -> JS
1128translateCase _ (SDefaultCase e) = translateExpression e
1129translateCase _ (SConstCase _ e) = translateExpression e
1130translateCase (Just var) (SConCase a _ _ vars e) =
1131 let params = map jsVar [a .. (a + length vars)] in
1132 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1133 JSThis, JSProj (JSIdent var) "vars"