git.iko.soy/Idris-dev
on cd462c9 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1056 lines 34 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 JSNum = JSInt Int
39 | JSFloat Double
40 | JSInteger Integer
41 deriving Eq
43data JS = JSRaw String
44 | JSIdent String
45 | JSFunction [String] JS
46 | JSType JSType
47 | JSSeq [JS]
48 | JSReturn JS
49 | JSApp JS [JS]
50 | JSNew String [JS]
51 | JSError String
52 | JSOp String JS JS
53 | JSProj JS String
54 | JSVar LVar
55 | JSNull
56 | JSThis
57 | JSTrue
58 | JSFalse
59 | JSArray [JS]
60 | JSObject [(String, JS)]
61 | JSString String
62 | JSNum JSNum
63 | JSAssign JS JS
64 | JSAlloc String (Maybe JS)
65 | JSIndex JS JS
66 | JSCond [(JS, JS)]
67 | JSTernary JS JS JS
68 deriving Eq
70compileJS :: JS -> String
71compileJS (JSRaw code) =
72 code
74compileJS (JSIdent ident) =
75 ident
77compileJS (JSFunction args body) =
78 "function("
79 ++ intercalate "," args
80 ++ "){\n"
81 ++ compileJS body
82 ++ "\n}"
84compileJS (JSType ty)
85 | JSIntTy <- ty = idrRTNamespace ++ "Int"
86 | JSStringTy <- ty = idrRTNamespace ++ "String"
87 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
88 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
89 | JSCharTy <- ty = idrRTNamespace ++ "Char"
90 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
91 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
93compileJS (JSSeq seq) =
94 intercalate ";\n" (map compileJS seq)
96compileJS (JSReturn val) =
97 "return " ++ compileJS val
99compileJS (JSApp lhs rhs)
100 | JSFunction {} <- lhs =
101 concat ["(", compileJS lhs, ")(", args, ")"]
102 | otherwise =
103 concat [compileJS lhs, "(", args, ")"]
104 where args :: String
105 args = intercalate "," $ map compileJS rhs
107compileJS (JSNew name args) =
108 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
110compileJS (JSError exc) =
111 "(function(){throw '" ++ exc ++ "';})()"
113compileJS (JSOp op lhs rhs) =
114 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
116compileJS (JSProj obj field)
117 | JSFunction {} <- obj =
118 concat ["(", compileJS obj, ").", field]
119 | JSAssign {} <- obj =
120 concat ["(", compileJS obj, ").", field]
121 | otherwise =
122 compileJS obj ++ '.' : field
124compileJS (JSVar var) =
125 translateVariableName var
127compileJS JSNull =
128 "null"
130compileJS JSThis =
131 "this"
133compileJS JSTrue =
134 "true"
136compileJS JSFalse =
137 "false"
139compileJS (JSArray elems) =
140 "[" ++ intercalate "," (map compileJS elems) ++ "]"
142compileJS (JSObject fields) =
143 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
144 where
145 compileField :: (String, JS) -> String
146 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
148compileJS (JSString str) =
149 show str
151compileJS (JSNum num)
152 | JSInt i <- num = show i
153 | JSFloat f <- num = show f
154 | JSInteger i <- num = show i
156compileJS (JSAssign lhs rhs) =
157 compileJS lhs ++ "=" ++ compileJS rhs
159compileJS (JSAlloc name val) =
160 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
162compileJS (JSIndex lhs rhs) =
163 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
165compileJS (JSCond branches) =
166 intercalate " else " $ map createIfBlock branches
167 where
168 createIfBlock (cond, e) =
169 "if (" ++ compileJS cond ++") {\n"
170 ++ "return " ++ compileJS e
171 ++ ";\n}"
173compileJS (JSTernary cond true false) =
174 let c = compileJS cond
175 t = compileJS true
176 f = compileJS false in
177 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
179jsTailcall :: JS -> JS
180jsTailcall call =
181 jsCall (idrRTNamespace ++ "tailcall") [
182 JSFunction [] (JSReturn call)
183 ]
185jsCall :: String -> [JS] -> JS
186jsCall fun = JSApp (JSIdent fun)
188jsMeth :: JS -> String -> [JS] -> JS
189jsMeth obj meth =
190 JSApp (JSProj obj meth)
192jsInstanceOf :: JS -> JS -> JS
193jsInstanceOf = JSOp "instanceof"
195jsEq :: JS -> JS -> JS
196jsEq = JSOp "=="
198jsAnd :: JS -> JS -> JS
199jsAnd = JSOp "&&"
201jsType :: JS
202jsType = JSIdent $ idrRTNamespace ++ "Type"
204jsCon :: JS
205jsCon = JSIdent $ idrRTNamespace ++ "Con"
207jsTag :: JS -> JS
208jsTag obj = JSProj obj "tag"
210jsTypeTag :: JS -> JS
211jsTypeTag obj = JSProj obj "type"
213jsBigInt :: JS -> JS
214jsBigInt (JSString "0") = JSIdent "__IDRRT__ZERO"
215jsBigInt (JSString "1") = JSIdent "__IDRRT__ONE"
216jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
218jsVar :: Int -> String
219jsVar = ("__var_" ++) . show
221jsLet :: String -> JS -> JS -> JS
222jsLet name value body =
223 JSApp (
224 JSFunction [name] (
225 JSReturn body
226 )
227 ) [value]
229jsSubst :: String -> JS -> JS -> JS
230jsSubst var new (JSVar old)
231 | var == translateVariableName old = new
233jsSubst var new (JSIdent old)
234 | var == old = new
236jsSubst var new (JSArray fields) =
237 JSArray (map (jsSubst var new) fields)
239jsSubst var new (JSNew con [tag, vals]) =
240 JSNew con [tag, jsSubst var new vals]
242jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
243 JSNew con [JSFunction [] (
244 JSReturn $ JSApp fun (map (jsSubst var new) vars)
245 )]
247jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
248 JSReturn (JSApp fun args)
249 )]) =
250 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
251 JSReturn $ JSApp fun (map (jsSubst var new) args)
252 )]
254jsSubst var new (JSApp (JSFunction [arg] body) vals)
255 | var /= arg =
256 JSApp (JSFunction [arg] (
257 jsSubst var new body
258 )) $ map (jsSubst var new) vals
260jsSubst var new (JSReturn ret) =
261 JSReturn $ jsSubst var new ret
263jsSubst _ _ js = js
265inlineJS :: JS -> JS
266inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
267 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
269inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
270 | JSNew con [tag, vals] <- ret
271 , opt <- inlineJS val =
272 JSNew con [tag, jsSubst arg opt vals]
274 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
275 , opt <- inlineJS val =
276 JSNew con [JSFunction [] (
277 JSReturn $ JSApp fun (map (jsSubst arg opt) vars)
278 )]
280 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
281 JSReturn (JSApp fun args)
282 )] <- ret
283 , opt <- inlineJS val =
284 JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
285 JSReturn $ JSApp fun (map (jsSubst arg opt) args)
286 )]
288 | JSIndex (JSProj obj field) idx <- ret
289 , opt <- inlineJS val =
290 JSIndex (JSProj (
291 jsSubst arg opt obj
292 ) field
293 ) (jsSubst arg opt idx)
295 | JSOp op lhs rhs <- ret =
296 JSOp op (jsSubst arg (inlineJS val) lhs) $
297 (jsSubst arg (inlineJS val) rhs)
299inlineJS (JSApp fun args) =
300 JSApp (inlineJS fun) (map inlineJS args)
302inlineJS (JSNew con args) =
303 JSNew con $ map inlineJS args
305inlineJS (JSArray fields) =
306 JSArray (map inlineJS fields)
308inlineJS (JSAssign lhs rhs) =
309 JSAssign lhs (inlineJS rhs)
311inlineJS (JSSeq seq) =
312 JSSeq (map inlineJS seq)
314inlineJS (JSFunction args body) =
315 JSFunction args (inlineJS body)
317inlineJS (JSProj (JSFunction args body) "apply") =
318 JSProj (JSFunction args (inlineJS body)) "apply"
320inlineJS (JSReturn js) =
321 JSReturn $ inlineJS js
323inlineJS (JSAlloc name (Just js)) =
324 JSAlloc name (Just $ inlineJS js)
326inlineJS (JSCond cases) =
327 JSCond (map (second inlineJS) cases)
329inlineJS (JSObject fields) =
330 JSObject (map (second inlineJS) fields)
332inlineJS js = js
334reduceJS :: [JS] -> [JS]
335reduceJS js = reduceLoop [] ([], js)
337funName :: JS -> String
338funName (JSAlloc fun _) = fun
340removeIDs :: [JS] -> [JS]
341removeIDs js =
342 case partition isID js of
343 ([], rest) -> rest
344 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
345 where isID :: JS -> Bool
346 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
347 | JSReturn (JSVar _) <- last body = True
349 isID _ = False
351 idFor :: JS -> (String, Int)
352 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
353 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
355 removeIDCall :: [(String, Int)] -> JS -> JS
356 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
357 JSReturn (JSApp (JSIdent fun) args)
358 )])
359 | Just pos <- lookup fun ids
360 , pos < length args = args !! pos
362 removeIDCall ids (JSNew _ [JSFunction [] (
363 JSReturn (JSApp (JSIdent fun) args)
364 )])
365 | Just pos <- lookup fun ids
366 , pos < length args = args !! pos
368 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
369 | Just pos <- lookup fun ids
370 , pos < length args = args !! pos
372 removeIDCall ids (JSAlloc fun (Just body)) =
373 JSAlloc fun (Just $ removeIDCall ids body)
375 removeIDCall ids (JSReturn js) =
376 JSReturn $ removeIDCall ids js
378 removeIDCall ids (JSSeq js) =
379 JSSeq $ map (removeIDCall ids) js
381 removeIDCall ids (JSNew con args) =
382 JSNew con $ map (removeIDCall ids) args
384 removeIDCall ids (JSFunction args body) =
385 JSFunction args $ removeIDCall ids body
387 removeIDCall ids (JSApp fun args) =
388 JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args
390 removeIDCall ids (JSProj obj field) =
391 JSProj (removeIDCall ids obj) field
393 removeIDCall ids (JSCond conds) =
394 JSCond $ map (removeIDCall ids *** removeIDCall ids) conds
396 removeIDCall ids (JSAssign lhs rhs) =
397 JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs)
399 removeIDCall ids (JSArray fields) =
400 JSArray $ map (removeIDCall ids) fields
402 removeIDCall _ js = js
405reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
406reduceLoop reduced (cons, program) =
407 case partition findConstructors program of
408 ([], js) -> cons ++ js
409 (candidates, rest) ->
410 let names = reduced ++ map funName candidates in
411 reduceLoop names (
412 cons ++ map reduce candidates, map (reduceCall names) rest
413 )
414 where findConstructors :: JS -> Bool
415 findConstructors js
416 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
417 reducable $ last body
418 | otherwise = False
419 where reducable :: JS -> Bool
420 reducable (JSReturn js) = reducable js
421 reducable (JSNew _ args) = and $ map reducable args
422 reducable (JSArray fields) = and $ map reducable fields
423 reducable (JSNum _) = True
424 reducable JSNull = True
425 reducable (JSIdent _) = True
426 reducable _ = False
428 reduce :: JS -> JS
429 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
430 | JSReturn js <- last body = (JSAlloc fun (Just js))
432 reduce js = js
434 reduceCall :: [String] -> JS -> JS
435 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
436 JSReturn (JSApp id@(JSIdent ret) _)
437 )])
438 | ret `elem` funs = id
440 reduceCall funs js@(JSApp id@(JSIdent fun) _)
441 | fun `elem` funs = id
443 reduceCall funs (JSAlloc fun (Just body)) =
444 JSAlloc fun (Just $ reduceCall funs body)
446 reduceCall funs (JSReturn js) =
447 JSReturn $ reduceCall funs js
449 reduceCall funs (JSSeq js) =
450 JSSeq $ map (reduceCall funs) js
452 reduceCall funs (JSNew con args) =
453 JSNew con $ map (reduceCall funs) args
455 reduceCall funs (JSFunction args body) =
456 JSFunction args $ reduceCall funs body
458 reduceCall funs (JSApp fun args) =
459 JSApp (reduceCall funs fun) $ map (reduceCall funs) args
461 reduceCall funs (JSProj obj field) =
462 JSProj (reduceCall funs obj) field
464 reduceCall funs (JSCond conds) =
465 JSCond $ map (reduceCall funs *** reduceCall funs) conds
467 reduceCall funs (JSAssign lhs rhs) =
468 JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
470 reduceCall funs (JSArray fields) =
471 JSArray $ map (reduceCall funs) fields
473 reduceCall _ js = js
475optimizeJS :: JS -> JS
476optimizeJS = inlineLoop
477 where inlineLoop :: JS -> JS
478 inlineLoop js
479 | opt <- inlineJS js
480 , opt /= js = inlineLoop opt
481 | otherwise = js
483codegenJavaScript
484 :: JSTarget
485 -> [(Name, SDecl)]
486 -> FilePath
487 -> OutputType
488 -> IO ()
489codegenJavaScript target definitions filename outputType = do
490 let (header, runtime) = case target of
491 Node ->
492 ("#!/usr/bin/env node\n", "-node")
493 JavaScript ->
494 ("", "-browser")
495 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
496 idrRuntime <- readFile $ path ++ "Runtime-common.js"
497 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
498 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
499 writeFile filename $ header ++ (
500 intercalate "\n" $ [ jsbn
501 , idrRuntime
502 , tgtRuntime
503 ] ++ functions ++ [mainLoop, invokeLoop]
504 )
506 setPermissions filename (emptyPermissions { readable = True
507 , executable = target == Node
508 , writable = True
509 })
510 where
511 def :: [(String, SDecl)]
512 def = map (first translateNamespace) definitions
514 functions :: [String]
515 functions =
516 map compileJS ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def)
518 mainLoop :: String
519 mainLoop = compileJS $
520 JSAlloc "main" $ Just $ JSFunction [] (
521 case target of
522 Node -> mainFun
523 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
524 JSString "DOMContentLoaded", JSFunction [] (
525 mainFun
526 ), JSFalse
527 ]
528 )
529 where
530 mainFun :: JS
531 mainFun = jsTailcall $ jsCall runMain []
533 runMain :: String
534 runMain = idrNamespace ++ translateName (MN 0 "runMain")
536 invokeLoop :: String
537 invokeLoop = compileJS $ jsCall "main" []
539translateIdentifier :: String -> String
540translateIdentifier =
541 replaceReserved . concatMap replaceBadChars
542 where replaceBadChars :: Char -> String
543 replaceBadChars c
544 | ' ' <- c = "_"
545 | '_' <- c = "__"
546 | isDigit c = '_' : show (ord c)
547 | not (isLetter c && isAscii c) = '_' : show (ord c)
548 | otherwise = [c]
549 replaceReserved s
550 | s `elem` reserved = '_' : s
551 | otherwise = s
552 reserved = [ "break"
553 , "case"
554 , "catch"
555 , "continue"
556 , "debugger"
557 , "default"
558 , "delete"
559 , "do"
560 , "else"
561 , "finally"
562 , "for"
563 , "function"
564 , "if"
565 , "in"
566 , "instanceof"
567 , "new"
568 , "return"
569 , "switch"
570 , "this"
571 , "throw"
572 , "try"
573 , "typeof"
574 , "var"
575 , "void"
576 , "while"
577 , "with"
579 , "class"
580 , "enum"
581 , "export"
582 , "extends"
583 , "import"
584 , "super"
586 , "implements"
587 , "interface"
588 , "let"
589 , "package"
590 , "private"
591 , "protected"
592 , "public"
593 , "static"
594 , "yield"
595 ]
597translateNamespace :: Name -> String
598translateNamespace (UN _) = idrNamespace
599translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
600translateNamespace (MN _ _) = idrNamespace
601translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
602translateNamespace NErased = idrNamespace
604translateName :: Name -> String
605translateName (UN name) = 'u' : translateIdentifier name
606translateName (NS name _) = 'n' : translateName name
607translateName (MN i name) = 'm' : translateIdentifier name ++ show i
608translateName (SN name) = 's' : translateSpecialName name
609translateName NErased = "e"
611translateSpecialName :: SpecialName -> String
612translateSpecialName name
613 | WhereN i m n <- name =
614 'w' : translateName m ++ translateName n ++ show i
615 | InstanceN n s <- name =
616 'i' : translateName n ++ concatMap translateIdentifier s
617 | ParentN n s <- name =
618 'p' : translateName n ++ translateIdentifier s
619 | MethodN n <- name =
620 'm' : translateName n
621 | CaseN n <- name =
622 'c' : translateName n
624translateConstant :: Const -> JS
625translateConstant (I i) = JSNum (JSInt i)
626translateConstant (Fl f) = JSNum (JSFloat f)
627translateConstant (Ch c) = JSString [c]
628translateConstant (Str s) = JSString s
629translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
630translateConstant StrType = JSType JSStringTy
631translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
632translateConstant (AType ATFloat) = JSType JSFloatTy
633translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
634translateConstant PtrType = JSType JSPtrTy
635translateConstant Forgot = JSType JSForgotTy
636translateConstant (BI i) = jsBigInt $ JSString (show i)
637translateConstant c =
638 JSError $ "Unimplemented Constant: " ++ show c
640translateDeclaration :: (String, SDecl) -> JS
641translateDeclaration (path, SFun name params stackSize body)
642 | (MN _ "APPLY") <- name
643 , (SLet var val next) <- body
644 , (SChkCase cvar cases) <- next =
645 let lvar = translateVariableName var
646 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
647 JSSeq [ lookupTable [(var, "chk")] var cases
648 , jsDecl $ JSFunction ["fn0", "arg0"] (
649 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
650 , JSReturn $ jsLet (translateVariableName var) (
651 translateExpression val
652 ) (JSTernary (
653 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
654 (hasProp lookupTableName (translateVariableName var))
655 ) (JSIdent $
656 lookupTableName ++ lookup
657 ) JSNull
658 )
659 ]
660 )
661 ]
663 | (MN _ "EVAL") <- name
664 , (SChkCase var cases) <- body =
665 JSSeq [ lookupTable [] var cases
666 , jsDecl $ JSFunction ["arg0"] (JSReturn $
667 JSTernary (
668 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
669 (hasProp lookupTableName "arg0")
670 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0")
671 )
672 ]
673 | otherwise =
674 let fun = translateExpression body in
675 jsDecl $ jsFun fun
677 where
678 hasProp :: String -> String -> JS
679 hasProp table var =
680 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
682 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
683 caseFun aux var cse =
684 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
686 getTag :: SAlt -> Maybe Int
687 getTag (SConCase _ tag _ _ _) = Just tag
688 getTag _ = Nothing
690 lookupTableName :: String
691 lookupTableName = idrLTNamespace ++ translateName name
693 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
694 lookupTable aux var cases =
695 JSAlloc lookupTableName $ Just (
696 JSApp (JSFunction [] (
697 JSSeq $ [
698 JSAlloc "t" $ Just (JSArray [])
699 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
700 JSReturn (JSIdent "t")
701 ]
702 )) []
703 )
704 where
705 assignEntries :: [(Int, JS)] -> [JS]
706 assignEntries entries =
707 map (\(tag, fun) ->
708 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
709 ) entries
711 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
712 lookupEntry aux var alt = do
713 tag <- getTag alt
714 return (tag, caseFun aux var alt)
716 jsDecl :: JS -> JS
717 jsDecl = JSAlloc (path ++ translateName name) . Just
719 jsFun body = jsFunAux [] body
721 jsFunAux :: [(LVar, String)] -> JS -> JS
722 jsFunAux aux body =
723 JSFunction (p ++ map snd aux) (
724 JSSeq $
725 zipWith assignVar [0..] p ++
726 map allocVar [numP .. (numP + stackSize - 1)] ++
727 map assignAux aux ++
728 [JSReturn body]
729 )
730 where
731 numP :: Int
732 numP = length params
734 allocVar :: Int -> JS
735 allocVar n = JSAlloc (jsVar n) Nothing
737 assignVar :: Int -> String -> JS
738 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
740 assignAux :: (LVar, String) -> JS
741 assignAux (var, val) =
742 JSAssign (JSIdent $ translateVariableName var) (JSIdent val)
744 p :: [String]
745 p = map translateName params
747translateVariableName :: LVar -> String
748translateVariableName (Loc i) =
749 jsVar i
751translateExpression :: SExp -> JS
752translateExpression (SLet name value body) =
753 jsLet (translateVariableName name) (
754 translateExpression value
755 ) (translateExpression body)
757translateExpression (SConst cst) =
758 translateConstant cst
760translateExpression (SV var) =
761 JSVar var
763translateExpression (SApp tc name vars)
764 | False <- tc =
765 jsTailcall $ translateFunctionCall name vars
766 | True <- tc =
767 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
768 JSReturn $ translateFunctionCall name vars
769 )]
770 where
771 translateFunctionCall name vars =
772 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
774translateExpression (SOp op vars)
775 | LNoOp <- op = JSVar (last vars)
777 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
778 | (LPlus (ATInt ITBig)) <- op
779 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
780 | (LMinus (ATInt ITBig)) <- op
781 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
782 | (LTimes (ATInt ITBig)) <- op
783 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
784 | (LSDiv (ATInt ITBig)) <- op
785 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
786 | (LSRem (ATInt ITBig)) <- op
787 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
788 | (LEq (ATInt ITBig)) <- op
789 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
790 | (LSLt (ATInt ITBig)) <- op
791 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
792 | (LSLe (ATInt ITBig)) <- op
793 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
794 | (LSGt (ATInt ITBig)) <- op
795 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
796 | (LSGe (ATInt ITBig)) <- op
797 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
799 | (LPlus ATFloat) <- op
800 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
801 | (LMinus ATFloat) <- op
802 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
803 | (LTimes ATFloat) <- op
804 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
805 | (LSDiv ATFloat) <- op
806 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
807 | (LEq ATFloat) <- op
808 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
809 | (LSLt ATFloat) <- op
810 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
811 | (LSLe ATFloat) <- op
812 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
813 | (LSGt ATFloat) <- op
814 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
815 | (LSGe ATFloat) <- op
816 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
818 | (LPlus _) <- op
819 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
820 | (LMinus _) <- op
821 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
822 | (LTimes _) <- op
823 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
824 | (LSDiv _) <- op
825 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
826 | (LSRem _) <- op
827 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
828 | (LEq _) <- op
829 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
830 | (LSLt _) <- op
831 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
832 | (LSLe _) <- op
833 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
834 | (LSGt _) <- op
835 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
836 | (LSGe _) <- op
837 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
838 | (LAnd _) <- op
839 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
840 | (LOr _) <- op
841 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
842 | (LXOr _) <- op
843 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
844 | (LSHL _) <- op
845 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
846 | (LASHR _) <- op
847 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
848 | (LCompl _) <- op
849 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
851 | LStrConcat <- op
852 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
853 | LStrEq <- op
854 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
855 | LStrLt <- op
856 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
857 | LStrLen <- op
858 , (arg:_) <- vars = JSProj (JSVar arg) "length"
860 | (LStrInt ITNative) <- op
861 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
862 | (LIntStr ITNative) <- op
863 , (arg:_) <- vars = jsCall "String" [JSVar arg]
864 | (LSExt ITNative ITBig) <- op
865 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
866 | (LTrunc ITBig ITNative) <- op
867 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
868 | (LIntStr ITBig) <- op
869 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
870 | (LStrInt ITBig) <- op
871 , (arg:_) <- vars = jsBigInt $ JSVar arg
872 | LFloatStr <- op
873 , (arg:_) <- vars = jsCall "String" [JSVar arg]
874 | LStrFloat <- op
875 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
876 | (LIntFloat ITNative) <- op
877 , (arg:_) <- vars = JSVar arg
878 | (LFloatInt ITNative) <- op
879 , (arg:_) <- vars = JSVar arg
880 | (LChInt ITNative) <- op
881 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
882 | (LIntCh ITNative) <- op
883 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
885 | LFExp <- op
886 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
887 | LFLog <- op
888 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
889 | LFSin <- op
890 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
891 | LFCos <- op
892 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
893 | LFTan <- op
894 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
895 | LFASin <- op
896 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
897 | LFACos <- op
898 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
899 | LFATan <- op
900 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
901 | LFSqrt <- op
902 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
903 | LFFloor <- op
904 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
905 | LFCeil <- op
906 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
908 | LStrCons <- op
909 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
910 | LStrHead <- op
911 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
912 | LStrRev <- op
913 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
914 | LStrIndex <- op
915 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
916 | LStrTail <- op
917 , (arg:_) <- vars = let v = translateVariableName arg in
918 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
919 where
920 translateBinaryOp :: String -> LVar -> LVar -> JS
921 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
923 invokeMeth :: LVar -> String -> [LVar] -> JS
924 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
926translateExpression (SError msg) =
927 JSError msg
929translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
930 jsCall (idrRTNamespace ++ "print") [JSVar var]
932translateExpression (SForeign _ _ fun args) =
933 ffi fun (map generateWrapper args)
934 where
935 generateWrapper (ffunc, name)
936 | FFunction <- ffunc =
937 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
938 | FFunctionIO <- ffunc =
939 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
941 generateWrapper (_, name) =
942 translateVariableName name
944translateExpression patterncase
945 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
946 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
947 where
948 caseHelper var cases param =
949 JSApp (JSFunction [param] (
950 JSCond $ map (expandCase param . translateCaseCond param) cases
951 )) [JSVar var]
953 expandCase :: String -> (Cond, JS) -> (JS, JS)
954 expandCase _ (RawCond cond, branch) = (cond, branch)
955 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
956 expandCase var (CaseCond caseTy, branch)
957 | ConCase tag <- caseTy =
958 let checkCon = JSIdent var `jsInstanceOf` jsCon
959 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
960 (checkCon `jsAnd` checkTag, branch)
962 | TypeCase ty <- caseTy =
963 let checkTy = JSIdent var `jsInstanceOf` jsType
964 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
965 (checkTy `jsAnd` checkTag, branch)
967translateExpression (SCon i name vars) =
968 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
969 , JSArray $ map JSVar vars
970 ]
972translateExpression (SUpdate var e) =
973 JSAssign (JSVar var) (translateExpression e)
975translateExpression (SProj var i) =
976 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
978translateExpression SNothing = JSNull
980translateExpression e =
981 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
983data FFI = FFICode Char | FFIArg Int | FFIError String
985ffi :: String -> [String] -> JS
986ffi code args = let parsed = ffiParse code in
987 case ffiError parsed of
988 Just err -> JSError err
989 Nothing -> JSRaw $ renderFFI parsed args
990 where
991 ffiParse :: String -> [FFI]
992 ffiParse "" = []
993 ffiParse ['%'] = [FFIError "Invalid positional argument"]
994 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
995 ffiParse ('%':s:ss)
996 | isDigit s =
997 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
998 | otherwise =
999 [FFIError "Invalid positional argument"]
1000 ffiParse (s:ss) = FFICode s : ffiParse ss
1002 ffiError :: [FFI] -> Maybe String
1003 ffiError [] = Nothing
1004 ffiError ((FFIError s):xs) = Just s
1005 ffiError (x:xs) = ffiError xs
1007 renderFFI :: [FFI] -> [String] -> String
1008 renderFFI [] _ = ""
1009 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1010 renderFFI ((FFIArg i) : fs) args
1011 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1012 | otherwise = "Argument index out of bounds"
1014data CaseType = ConCase Int
1015 | TypeCase JSType
1016 | DefaultCase
1017 deriving Eq
1019data Cond = CaseCond CaseType
1020 | RawCond JS
1022translateCaseCond :: String -> SAlt -> (Cond, JS)
1023translateCaseCond _ cse@(SDefaultCase _) =
1024 (CaseCond DefaultCase, translateCase Nothing cse)
1026translateCaseCond var cse@(SConstCase ty _)
1027 | StrType <- ty = matchHelper JSStringTy
1028 | PtrType <- ty = matchHelper JSPtrTy
1029 | Forgot <- ty = matchHelper JSForgotTy
1030 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1031 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1032 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1033 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1034 where
1035 matchHelper :: JSType -> (Cond, JS)
1036 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1038translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1039 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1040 (RawCond cond, translateCase Nothing cse)
1042translateCaseCond var cse@(SConstCase cst _) =
1043 let cond = JSIdent var `jsEq` translateConstant cst in
1044 (RawCond cond, translateCase Nothing cse)
1046translateCaseCond var cse@(SConCase _ tag _ _ _) =
1047 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1049translateCase :: Maybe String -> SAlt -> JS
1050translateCase _ (SDefaultCase e) = translateExpression e
1051translateCase _ (SConstCase _ e) = translateExpression e
1052translateCase (Just var) (SConCase a _ _ vars e) =
1053 let params = map jsVar [a .. (a + length vars)] in
1054 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1055 JSThis, JSProj (JSIdent var) "vars"