git.iko.soy/Idris-dev
on 0877929 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1195 lines 38 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 _ _ js = js
320isJSConstant :: JS -> Bool
321isJSConstant js
322 | JSString _ <- js = True
323 | JSChar _ <- js = True
324 | JSNum _ <- js = True
325 | JSType _ <- js = True
327 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
328 | otherwise = False
330inlineJS :: JS -> JS
331inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
332 JSThis,JSProj (JSIdent var) "vars"
333 ])
334 | var /= "cse" =
335 inlineApply args body 0
336 where
337 inlineApply [] body _ = body
338 inlineApply (a:as) body n =
339 inlineApply as (
340 jsSubst a (JSIndex (JSProj (JSIdent var) "vars") (JSNum (JSInt n))) body
341 ) (n + 1)
343inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
344 | isJSConstant val = val
346inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
347 JSFunction [] (JSReturn val)
348 ])
349 | isJSConstant val = val
351inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
352 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
354inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
355 | JSNew con [tag, vals] <- ret
356 , opt <- inlineJS val =
357 JSNew con [tag, jsSubst arg opt vals]
359 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
360 , opt <- inlineJS val =
361 JSNew con [JSFunction [] (
362 JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) vars)
363 )]
365 | JSApp (JSProj obj field) args <- ret
366 , opt <- inlineJS val =
367 JSApp (JSProj (jsSubst arg opt obj) field) $ map (jsSubst arg opt) args
369 | JSIndex (JSProj obj field) idx <- ret
370 , opt <- inlineJS val =
371 JSIndex (JSProj (
372 jsSubst arg opt obj
373 ) field
374 ) (jsSubst arg opt idx)
376 | JSOp op lhs rhs <- ret
377 , opt <- inlineJS val =
378 JSOp op (jsSubst arg opt lhs) $
379 (jsSubst arg opt rhs)
381 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
382 JSReturn (JSApp fun args)
383 )] <- ret
384 , opt <- inlineJS val =
385 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
386 JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) args)
387 )]
389inlineJS (JSApp fun args) =
390 JSApp (inlineJS fun) (map inlineJS args)
392inlineJS (JSNew con args) =
393 JSNew con $ map inlineJS args
395inlineJS (JSArray fields) =
396 JSArray (map inlineJS fields)
398inlineJS (JSAssign lhs rhs) =
399 JSAssign (inlineJS lhs) (inlineJS rhs)
401inlineJS (JSSeq seq) =
402 JSSeq (map inlineJS seq)
404inlineJS (JSFunction args body) =
405 JSFunction args (inlineJS body)
407inlineJS (JSProj (JSFunction args body) field) =
408 JSProj (JSFunction args (inlineJS body)) field
410inlineJS (JSReturn js) =
411 JSReturn $ inlineJS js
413inlineJS (JSAlloc name (Just js)) =
414 JSAlloc name (Just $ inlineJS js)
416inlineJS (JSCond cases) =
417 JSCond (map (second inlineJS) cases)
419inlineJS (JSObject fields) =
420 JSObject (map (second inlineJS) fields)
422inlineJS (JSOp op lhs rhs) =
423 JSOp op (inlineJS lhs) (inlineJS rhs)
425inlineJS js = js
427reduceJS :: [JS] -> [JS]
428reduceJS js = reduceLoop [] ([], js)
430funName :: JS -> String
431funName (JSAlloc fun _) = fun
433removeIDs :: [JS] -> [JS]
434removeIDs js =
435 case partition isID js of
436 ([], rest) -> rest
437 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
438 where isID :: JS -> Bool
439 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
440 | JSReturn (JSVar _) <- last body = True
442 isID _ = False
444 idFor :: JS -> (String, Int)
445 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
446 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
448 removeIDCall :: [(String, Int)] -> JS -> JS
449 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
450 JSReturn (JSApp (JSIdent fun) args)
451 )])
452 | Just pos <- lookup fun ids
453 , pos < length args = args !! pos
455 removeIDCall ids (JSNew _ [JSFunction [] (
456 JSReturn (JSApp (JSIdent fun) args)
457 )])
458 | Just pos <- lookup fun ids
459 , pos < length args = args !! pos
461 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
462 | Just pos <- lookup fun ids
463 , pos < length args = args !! pos
465 removeIDCall ids (JSAlloc fun (Just body)) =
466 JSAlloc fun (Just $ removeIDCall ids body)
468 removeIDCall ids (JSReturn js) =
469 JSReturn $ removeIDCall ids js
471 removeIDCall ids (JSSeq js) =
472 JSSeq $ map (removeIDCall ids) js
474 removeIDCall ids (JSNew con args) =
475 JSNew con $ map (removeIDCall ids) args
477 removeIDCall ids (JSFunction args body) =
478 JSFunction args $ removeIDCall ids body
480 removeIDCall ids (JSApp fun args) =
481 JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args
483 removeIDCall ids (JSProj obj field) =
484 JSProj (removeIDCall ids obj) field
486 removeIDCall ids (JSCond conds) =
487 JSCond $ map (removeIDCall ids *** removeIDCall ids) conds
489 removeIDCall ids (JSAssign lhs rhs) =
490 JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs)
492 removeIDCall ids (JSArray fields) =
493 JSArray $ map (removeIDCall ids) fields
495 removeIDCall _ js = js
497reduceConstant :: JS -> JS
498reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
499 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
500 )]) = JSNum num
502reduceConstant (JSReturn ret) =
503 JSReturn (reduceConstant ret)
505reduceConstant (JSApp fun args) =
506 JSApp (reduceConstant fun) (map reduceConstant args)
508reduceConstant (JSArray fields) =
509 JSArray (map reduceConstant fields)
511reduceConstant (JSAlloc name (Just val)) =
512 JSAlloc name $ Just (reduceConstant val)
514reduceConstant (JSNew con args) =
515 JSNew con (map reduceConstant args)
517reduceConstant (JSProj obj field) =
518 JSProj (reduceConstant obj) field
520reduceConstant (JSCond conds) =
521 JSCond $ map (reduceConstant *** reduceConstant) conds
523reduceConstant (JSSeq seq) =
524 JSSeq $ map reduceConstant seq
526reduceConstant (JSFunction args body) =
527 JSFunction args (reduceConstant body)
529reduceConstant js = js
531reduceConstants :: JS -> JS
532reduceConstants js
533 | ret <- reduceConstant js
534 , ret /= js = reduceConstants ret
535 | otherwise = js
537reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
538reduceLoop reduced (cons, program) =
539 case partition findConstructors program of
540 ([], js) -> cons ++ js
541 (candidates, rest) ->
542 let names = reduced ++ map funName candidates in
543 reduceLoop names (
544 cons ++ map reduce candidates, map (reduceCall names) rest
545 )
546 where findConstructors :: JS -> Bool
547 findConstructors js
548 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
549 reducable $ last body
550 | otherwise = False
551 where reducable :: JS -> Bool
552 reducable (JSReturn js) = reducable js
553 reducable (JSNew _ args) = and $ map reducable args
554 reducable (JSArray fields) = and $ map reducable fields
555 reducable (JSNum _) = True
556 reducable JSNull = True
557 reducable (JSIdent _) = True
558 reducable _ = False
560 reduce :: JS -> JS
561 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
562 | JSReturn js <- last body = (JSAlloc fun (Just js))
564 reduce js = js
566 reduceCall :: [String] -> JS -> JS
567 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
568 JSReturn (JSApp id@(JSIdent ret) _)
569 )])
570 | ret `elem` funs = id
572 reduceCall funs js@(JSApp id@(JSIdent fun) _)
573 | fun `elem` funs = id
575 reduceCall funs (JSAlloc fun (Just body)) =
576 JSAlloc fun (Just $ reduceCall funs body)
578 reduceCall funs (JSReturn js) =
579 JSReturn $ reduceCall funs js
581 reduceCall funs (JSSeq js) =
582 JSSeq $ map (reduceCall funs) js
584 reduceCall funs (JSNew con args) =
585 JSNew con $ map (reduceCall funs) args
587 reduceCall funs (JSFunction args body) =
588 JSFunction args $ reduceCall funs body
590 reduceCall funs (JSApp fun args) =
591 JSApp (reduceCall funs fun) $ map (reduceCall funs) args
593 reduceCall funs (JSProj obj field) =
594 JSProj (reduceCall funs obj) field
596 reduceCall funs (JSIndex obj idx) =
597 JSIndex (reduceCall funs obj) (reduceCall funs idx)
599 reduceCall funs (JSOp op rhs lhs) =
600 JSOp op (reduceCall funs rhs) (reduceCall funs lhs)
602 reduceCall funs (JSCond conds) =
603 JSCond $ map (reduceCall funs *** reduceCall funs) conds
605 reduceCall funs (JSAssign lhs rhs) =
606 JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
608 reduceCall funs (JSArray fields) =
609 JSArray $ map (reduceCall funs) fields
611 reduceCall _ js = js
613optimizeJS :: JS -> JS
614optimizeJS = inlineLoop
615 where inlineLoop :: JS -> JS
616 inlineLoop js
617 | opt <- inlineJS js
618 , opt /= js = inlineLoop opt
619 | otherwise = js
621codegenJavaScript
622 :: JSTarget
623 -> [(Name, SDecl)]
624 -> FilePath
625 -> OutputType
626 -> IO ()
627codegenJavaScript target definitions filename outputType = do
628 let (header, runtime) = case target of
629 Node ->
630 ("#!/usr/bin/env node\n", "-node")
631 JavaScript ->
632 ("", "-browser")
633 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
634 idrRuntime <- readFile $ path ++ "Runtime-common.js"
635 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
636 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
637 writeFile filename $ header ++ (
638 intercalate "\n" $ [ jsbn
639 , idrRuntime
640 , tgtRuntime
641 ] ++ functions ++ [mainLoop, invokeLoop]
642 )
644 setPermissions filename (emptyPermissions { readable = True
645 , executable = target == Node
646 , writable = True
647 })
648 where
649 def :: [(String, SDecl)]
650 def = map (first translateNamespace) definitions
652 functions :: [String]
653 functions =
654 map (compileJS . reduceConstants) ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def)
656 mainLoop :: String
657 mainLoop = compileJS $
658 JSAlloc "main" $ Just $ JSFunction [] (
659 case target of
660 Node -> mainFun
661 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
662 JSString "DOMContentLoaded", JSFunction [] (
663 mainFun
664 ), JSFalse
665 ]
666 )
667 where
668 mainFun :: JS
669 mainFun = jsTailcall $ jsCall runMain []
671 runMain :: String
672 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
674 invokeLoop :: String
675 invokeLoop = compileJS $ jsCall "main" []
677translateIdentifier :: String -> String
678translateIdentifier =
679 replaceReserved . concatMap replaceBadChars
680 where replaceBadChars :: Char -> String
681 replaceBadChars c
682 | ' ' <- c = "_"
683 | '_' <- c = "__"
684 | isDigit c = '_' : show (ord c)
685 | not (isLetter c && isAscii c) = '_' : show (ord c)
686 | otherwise = [c]
687 replaceReserved s
688 | s `elem` reserved = '_' : s
689 | otherwise = s
690 reserved = [ "break"
691 , "case"
692 , "catch"
693 , "continue"
694 , "debugger"
695 , "default"
696 , "delete"
697 , "do"
698 , "else"
699 , "finally"
700 , "for"
701 , "function"
702 , "if"
703 , "in"
704 , "instanceof"
705 , "new"
706 , "return"
707 , "switch"
708 , "this"
709 , "throw"
710 , "try"
711 , "typeof"
712 , "var"
713 , "void"
714 , "while"
715 , "with"
717 , "class"
718 , "enum"
719 , "export"
720 , "extends"
721 , "import"
722 , "super"
724 , "implements"
725 , "interface"
726 , "let"
727 , "package"
728 , "private"
729 , "protected"
730 , "public"
731 , "static"
732 , "yield"
733 ]
735translateNamespace :: Name -> String
736translateNamespace (UN _) = idrNamespace
737translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
738translateNamespace (MN _ _) = idrNamespace
739translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
740translateNamespace NErased = idrNamespace
742translateName :: Name -> String
743translateName (UN name) = 'u' : translateIdentifier (str name)
744translateName (NS name _) = 'n' : translateName name
745translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
746translateName (SN name) = 's' : translateSpecialName name
747translateName NErased = "e"
749translateSpecialName :: SpecialName -> String
750translateSpecialName name
751 | WhereN i m n <- name =
752 'w' : translateName m ++ translateName n ++ show i
753 | InstanceN n s <- name =
754 'i' : translateName n ++ concatMap (translateIdentifier . str) s
755 | ParentN n s <- name =
756 'p' : translateName n ++ translateIdentifier (str s)
757 | MethodN n <- name =
758 'm' : translateName n
759 | CaseN n <- name =
760 'c' : translateName n
762translateConstant :: Const -> JS
763translateConstant (I i) = JSNum (JSInt i)
764translateConstant (Fl f) = JSNum (JSFloat f)
765translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
766translateConstant (Ch '\a') = JSChar "'\\u0007'"
767translateConstant (Ch '\SO') = JSChar "'\\u000E'"
768translateConstant (Ch c) = JSString [c]
769translateConstant (Str s) = JSString s
770translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
771translateConstant StrType = JSType JSStringTy
772translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
773translateConstant (AType ATFloat) = JSType JSFloatTy
774translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
775translateConstant PtrType = JSType JSPtrTy
776translateConstant Forgot = JSType JSForgotTy
777translateConstant (BI i) = jsBigInt $ JSString (show i)
778translateConstant c =
779 JSError $ "Unimplemented Constant: " ++ show c
781translateDeclaration :: (String, SDecl) -> JS
782translateDeclaration (path, SFun name params stackSize body)
783 | (MN _ ap) <- name
784 , (SLet var val next) <- body
785 , (SChkCase cvar cases) <- next
786 , ap == txt "APPLY" =
787 let lvar = translateVariableName var
788 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
789 JSSeq [ lookupTable [(var, "chk")] var cases
790 , jsDecl $ JSFunction ["fn0", "arg0"] (
791 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
792 , JSReturn $ jsLet (translateVariableName var) (
793 translateExpression val
794 ) (JSTernary (
795 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
796 (hasProp lookupTableName (translateVariableName var))
797 ) (JSIdent $
798 lookupTableName ++ lookup
799 ) JSNull
800 )
801 ]
802 )
803 ]
805 | (MN _ ev) <- name
806 , (SChkCase var cases) <- body
807 , ev == txt "EVAL" =
808 JSSeq [ lookupTable [] var cases
809 , jsDecl $ JSFunction ["arg0"] (JSReturn $
810 JSTernary (
811 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
812 (hasProp lookupTableName "arg0")
813 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0")
814 )
815 ]
816 | otherwise =
817 let fun = translateExpression body in
818 jsDecl $ jsFun fun
820 where
821 hasProp :: String -> String -> JS
822 hasProp table var =
823 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
825 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
826 caseFun aux var cse =
827 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
829 getTag :: SAlt -> Maybe Int
830 getTag (SConCase _ tag _ _ _) = Just tag
831 getTag _ = Nothing
833 lookupTableName :: String
834 lookupTableName = idrLTNamespace ++ translateName name
836 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
837 lookupTable aux var cases =
838 JSAlloc lookupTableName $ Just (
839 JSApp (JSFunction [] (
840 JSSeq $ [
841 JSAlloc "t" $ Just (JSArray [])
842 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
843 JSReturn (JSIdent "t")
844 ]
845 )) []
846 )
847 where
848 assignEntries :: [(Int, JS)] -> [JS]
849 assignEntries entries =
850 map (\(tag, fun) ->
851 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
852 ) entries
854 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
855 lookupEntry aux var alt = do
856 tag <- getTag alt
857 return (tag, caseFun aux var alt)
859 jsDecl :: JS -> JS
860 jsDecl = JSAlloc (path ++ translateName name) . Just
862 jsFun body = jsFunAux [] body
864 jsFunAux :: [(LVar, String)] -> JS -> JS
865 jsFunAux aux body =
866 JSFunction (p ++ map snd aux) (
867 JSSeq $
868 zipWith assignVar [0..] p ++
869 map assignAux aux ++
870 [JSReturn body]
871 )
872 where
873 assignVar :: Int -> String -> JS
874 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
876 assignAux :: (LVar, String) -> JS
877 assignAux (Loc var, val) =
878 JSAlloc (jsVar var) (Just $ JSIdent val)
880 p :: [String]
881 p = map translateName params
883translateVariableName :: LVar -> String
884translateVariableName (Loc i) =
885 jsVar i
887translateExpression :: SExp -> JS
888translateExpression (SLet name value body) =
889 jsLet (translateVariableName name) (
890 translateExpression value
891 ) (translateExpression body)
893translateExpression (SConst cst) =
894 translateConstant cst
896translateExpression (SV var) =
897 JSVar var
899translateExpression (SApp tc name vars)
900 | False <- tc =
901 jsTailcall $ translateFunctionCall name vars
902 | True <- tc =
903 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
904 JSReturn $ translateFunctionCall name vars
905 )]
906 where
907 translateFunctionCall name vars =
908 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
910translateExpression (SOp op vars)
911 | LNoOp <- op = JSVar (last vars)
913 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
914 | (LPlus (ATInt ITBig)) <- op
915 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
916 | (LMinus (ATInt ITBig)) <- op
917 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
918 | (LTimes (ATInt ITBig)) <- op
919 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
920 | (LSDiv (ATInt ITBig)) <- op
921 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
922 | (LSRem (ATInt ITBig)) <- op
923 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
924 | (LEq (ATInt ITBig)) <- op
925 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
926 | (LSLt (ATInt ITBig)) <- op
927 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
928 | (LSLe (ATInt ITBig)) <- op
929 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
930 | (LSGt (ATInt ITBig)) <- op
931 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
932 | (LSGe (ATInt ITBig)) <- op
933 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
935 | (LPlus ATFloat) <- op
936 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
937 | (LMinus ATFloat) <- op
938 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
939 | (LTimes ATFloat) <- op
940 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
941 | (LSDiv ATFloat) <- op
942 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
943 | (LEq ATFloat) <- op
944 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
945 | (LSLt ATFloat) <- op
946 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
947 | (LSLe ATFloat) <- op
948 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
949 | (LSGt ATFloat) <- op
950 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
951 | (LSGe ATFloat) <- op
952 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
954 | (LPlus _) <- op
955 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
956 | (LMinus _) <- op
957 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
958 | (LTimes _) <- op
959 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
960 | (LSDiv _) <- op
961 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
962 | (LSRem _) <- op
963 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
964 | (LEq _) <- op
965 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
966 | (LSLt _) <- op
967 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
968 | (LSLe _) <- op
969 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
970 | (LSGt _) <- op
971 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
972 | (LSGe _) <- op
973 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
974 | (LAnd _) <- op
975 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
976 | (LOr _) <- op
977 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
978 | (LXOr _) <- op
979 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
980 | (LSHL _) <- op
981 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
982 | (LASHR _) <- op
983 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
984 | (LCompl _) <- op
985 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
987 | LStrConcat <- op
988 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
989 | LStrEq <- op
990 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
991 | LStrLt <- op
992 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
993 | LStrLen <- op
994 , (arg:_) <- vars = JSProj (JSVar arg) "length"
996 | (LStrInt ITNative) <- op
997 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
998 | (LIntStr ITNative) <- op
999 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1000 | (LSExt ITNative ITBig) <- op
1001 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1002 | (LTrunc ITBig ITNative) <- op
1003 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1004 | (LIntStr ITBig) <- op
1005 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1006 | (LStrInt ITBig) <- op
1007 , (arg:_) <- vars = jsBigInt $ JSVar arg
1008 | LFloatStr <- op
1009 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1010 | LStrFloat <- op
1011 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1012 | (LIntFloat ITNative) <- op
1013 , (arg:_) <- vars = JSVar arg
1014 | (LFloatInt ITNative) <- op
1015 , (arg:_) <- vars = JSVar arg
1016 | (LChInt ITNative) <- op
1017 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1018 | (LIntCh ITNative) <- op
1019 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1021 | LFExp <- op
1022 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1023 | LFLog <- op
1024 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1025 | LFSin <- op
1026 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1027 | LFCos <- op
1028 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1029 | LFTan <- op
1030 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1031 | LFASin <- op
1032 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1033 | LFACos <- op
1034 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1035 | LFATan <- op
1036 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1037 | LFSqrt <- op
1038 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1039 | LFFloor <- op
1040 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1041 | LFCeil <- op
1042 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1044 | LStrCons <- op
1045 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1046 | LStrHead <- op
1047 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1048 | LStrRev <- op
1049 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1050 | LStrIndex <- op
1051 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1052 | LStrTail <- op
1053 , (arg:_) <- vars = let v = translateVariableName arg in
1054 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
1055 | LNullPtr <- op
1056 , (_) <- vars = JSNull
1058 where
1059 translateBinaryOp :: String -> LVar -> LVar -> JS
1060 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
1062 invokeMeth :: LVar -> String -> [LVar] -> JS
1063 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1065translateExpression (SError msg) =
1066 JSError msg
1068translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1069 jsCall (idrRTNamespace ++ "print") [JSVar var]
1071translateExpression (SForeign _ _ fun args) =
1072 ffi fun (map generateWrapper args)
1073 where
1074 generateWrapper (ffunc, name)
1075 | FFunction <- ffunc =
1076 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1077 | FFunctionIO <- ffunc =
1078 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1080 generateWrapper (_, name) =
1081 translateVariableName name
1083translateExpression patterncase
1084 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1085 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1086 where
1087 caseHelper var cases param =
1088 JSApp (JSFunction [param] (
1089 JSCond $ map (expandCase param . translateCaseCond param) cases
1090 )) [JSVar var]
1092 expandCase :: String -> (Cond, JS) -> (JS, JS)
1093 expandCase _ (RawCond cond, branch) = (cond, branch)
1094 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1095 expandCase var (CaseCond caseTy, branch)
1096 | ConCase tag <- caseTy =
1097 let checkCon = JSIdent var `jsInstanceOf` jsCon
1098 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1099 (checkCon `jsAnd` checkTag, branch)
1101 | TypeCase ty <- caseTy =
1102 let checkTy = JSIdent var `jsInstanceOf` jsType
1103 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1104 (checkTy `jsAnd` checkTag, branch)
1106translateExpression (SCon i name vars) =
1107 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1108 , JSArray $ map JSVar vars
1111translateExpression (SUpdate var@(Loc i) e) =
1112 JSAssign (JSVar var) (translateExpression e)
1114translateExpression (SProj var i) =
1115 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1117translateExpression SNothing = JSNull
1119translateExpression e =
1120 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1122data FFI = FFICode Char | FFIArg Int | FFIError String
1124ffi :: String -> [String] -> JS
1125ffi code args = let parsed = ffiParse code in
1126 case ffiError parsed of
1127 Just err -> JSError err
1128 Nothing -> JSRaw $ renderFFI parsed args
1129 where
1130 ffiParse :: String -> [FFI]
1131 ffiParse "" = []
1132 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1133 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1134 ffiParse ('%':s:ss)
1135 | isDigit s =
1136 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1137 | otherwise =
1138 [FFIError "Invalid positional argument"]
1139 ffiParse (s:ss) = FFICode s : ffiParse ss
1141 ffiError :: [FFI] -> Maybe String
1142 ffiError [] = Nothing
1143 ffiError ((FFIError s):xs) = Just s
1144 ffiError (x:xs) = ffiError xs
1146 renderFFI :: [FFI] -> [String] -> String
1147 renderFFI [] _ = ""
1148 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1149 renderFFI ((FFIArg i) : fs) args
1150 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1151 | otherwise = "Argument index out of bounds"
1153data CaseType = ConCase Int
1154 | TypeCase JSType
1155 | DefaultCase
1156 deriving Eq
1158data Cond = CaseCond CaseType
1159 | RawCond JS
1161translateCaseCond :: String -> SAlt -> (Cond, JS)
1162translateCaseCond _ cse@(SDefaultCase _) =
1163 (CaseCond DefaultCase, translateCase Nothing cse)
1165translateCaseCond var cse@(SConstCase ty _)
1166 | StrType <- ty = matchHelper JSStringTy
1167 | PtrType <- ty = matchHelper JSPtrTy
1168 | Forgot <- ty = matchHelper JSForgotTy
1169 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1170 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1171 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1172 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1173 where
1174 matchHelper :: JSType -> (Cond, JS)
1175 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1177translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1178 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1179 (RawCond cond, translateCase Nothing cse)
1181translateCaseCond var cse@(SConstCase cst _) =
1182 let cond = JSIdent var `jsEq` translateConstant cst in
1183 (RawCond cond, translateCase Nothing cse)
1185translateCaseCond var cse@(SConCase _ tag _ _ _) =
1186 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1188translateCase :: Maybe String -> SAlt -> JS
1189translateCase _ (SDefaultCase e) = translateExpression e
1190translateCase _ (SConstCase _ e) = translateExpression e
1191translateCase (Just var) (SConCase a _ _ vars e) =
1192 let params = map jsVar [a .. (a + length vars)] in
1193 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1194 JSThis, JSProj (JSIdent var) "vars"