git.iko.soy/Idris-dev
on 24fb370 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
991 lines 32 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)
337reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
338reduceLoop reduced (cons, program) =
339 case partition findConstructors program of
340 ([], js) -> cons ++ js
341 (candidates, rest) ->
342 let names = reduced ++ map funName candidates in
343 reduceLoop names (
344 cons ++ map reduce candidates, map (reduceCall names) rest
345 )
346 where findConstructors :: JS -> Bool
347 findConstructors js
348 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
349 reducable $ last body
350 | otherwise = False
351 where reducable :: JS -> Bool
352 reducable (JSReturn js) = reducable js
353 reducable (JSNew _ args) = and $ map reducable args
354 reducable (JSArray fields) = and $ map reducable fields
355 reducable (JSNum _) = True
356 reducable JSNull = True
357 reducable (JSIdent _) = True
358 reducable _ = False
360 reduce :: JS -> JS
361 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
362 | JSReturn js <- last body = (JSAlloc fun (Just js))
364 reduce js = js
366 funName :: JS -> String
367 funName (JSAlloc fun _) = fun
369 reduceCall :: [String] -> JS -> JS
370 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
371 JSReturn (JSApp id@(JSIdent ret) _)
372 )])
373 | ret `elem` funs = id
375 reduceCall funs js@(JSApp id@(JSIdent fun) _)
376 | fun `elem` funs = id
378 reduceCall funs (JSAlloc fun (Just body)) =
379 JSAlloc fun (Just $ reduceCall funs body)
381 reduceCall funs (JSReturn js) =
382 JSReturn $ reduceCall funs js
384 reduceCall funs (JSSeq js) =
385 JSSeq $ map (reduceCall funs) js
387 reduceCall funs (JSNew con args) =
388 JSNew con $ map (reduceCall funs) args
390 reduceCall funs (JSFunction args body) =
391 JSFunction args $ reduceCall funs body
393 reduceCall funs (JSApp fun args) =
394 JSApp (reduceCall funs fun) $ map (reduceCall funs) args
396 reduceCall funs (JSProj obj field) =
397 JSProj (reduceCall funs obj) field
399 reduceCall funs (JSCond conds) =
400 JSCond $ map (reduceCall funs *** reduceCall funs) conds
402 reduceCall funs (JSAssign lhs rhs) =
403 JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
405 reduceCall funs (JSArray fields) =
406 JSArray $ map (reduceCall funs) fields
408 reduceCall _ js = js
410optimizeJS :: JS -> JS
411optimizeJS = inlineLoop
412 where inlineLoop :: JS -> JS
413 inlineLoop js
414 | opt <- inlineJS js
415 , opt /= js = inlineLoop opt
416 | otherwise = js
418codegenJavaScript
419 :: JSTarget
420 -> [(Name, SDecl)]
421 -> FilePath
422 -> OutputType
423 -> IO ()
424codegenJavaScript target definitions filename outputType = do
425 let (header, runtime) = case target of
426 Node ->
427 ("#!/usr/bin/env node\n", "-node")
428 JavaScript ->
429 ("", "-browser")
430 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
431 idrRuntime <- readFile $ path ++ "Runtime-common.js"
432 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
433 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
434 writeFile filename $ header ++ (
435 intercalate "\n" $ [ jsbn
436 , idrRuntime
437 , tgtRuntime
438 ] ++ functions ++ [mainLoop, invokeLoop]
439 )
441 setPermissions filename (emptyPermissions { readable = True
442 , executable = target == Node
443 , writable = True
444 })
445 where
446 def :: [(String, SDecl)]
447 def = map (first translateNamespace) definitions
449 functions :: [String]
450 functions =
451 map compileJS (reduceJS $ map (optimizeJS . translateDeclaration) def)
453 mainLoop :: String
454 mainLoop = compileJS $
455 JSAlloc "main" $ Just $ JSFunction [] (
456 case target of
457 Node -> mainFun
458 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
459 JSString "DOMContentLoaded", JSFunction [] (
460 mainFun
461 ), JSFalse
462 ]
463 )
464 where
465 mainFun :: JS
466 mainFun = jsTailcall $ jsCall runMain []
468 runMain :: String
469 runMain = idrNamespace ++ translateName (MN 0 "runMain")
471 invokeLoop :: String
472 invokeLoop = compileJS $ jsCall "main" []
474translateIdentifier :: String -> String
475translateIdentifier =
476 replaceReserved . concatMap replaceBadChars
477 where replaceBadChars :: Char -> String
478 replaceBadChars c
479 | ' ' <- c = "_"
480 | '_' <- c = "__"
481 | isDigit c = '_' : show (ord c)
482 | not (isLetter c && isAscii c) = '_' : show (ord c)
483 | otherwise = [c]
484 replaceReserved s
485 | s `elem` reserved = '_' : s
486 | otherwise = s
487 reserved = [ "break"
488 , "case"
489 , "catch"
490 , "continue"
491 , "debugger"
492 , "default"
493 , "delete"
494 , "do"
495 , "else"
496 , "finally"
497 , "for"
498 , "function"
499 , "if"
500 , "in"
501 , "instanceof"
502 , "new"
503 , "return"
504 , "switch"
505 , "this"
506 , "throw"
507 , "try"
508 , "typeof"
509 , "var"
510 , "void"
511 , "while"
512 , "with"
514 , "class"
515 , "enum"
516 , "export"
517 , "extends"
518 , "import"
519 , "super"
521 , "implements"
522 , "interface"
523 , "let"
524 , "package"
525 , "private"
526 , "protected"
527 , "public"
528 , "static"
529 , "yield"
530 ]
532translateNamespace :: Name -> String
533translateNamespace (UN _) = idrNamespace
534translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
535translateNamespace (MN _ _) = idrNamespace
536translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
537translateNamespace NErased = idrNamespace
539translateName :: Name -> String
540translateName (UN name) = 'u' : translateIdentifier name
541translateName (NS name _) = 'n' : translateName name
542translateName (MN i name) = 'm' : translateIdentifier name ++ show i
543translateName (SN name) = 's' : translateSpecialName name
544translateName NErased = "e"
546translateSpecialName :: SpecialName -> String
547translateSpecialName name
548 | WhereN i m n <- name =
549 'w' : translateName m ++ translateName n ++ show i
550 | InstanceN n s <- name =
551 'i' : translateName n ++ concatMap translateIdentifier s
552 | ParentN n s <- name =
553 'p' : translateName n ++ translateIdentifier s
554 | MethodN n <- name =
555 'm' : translateName n
556 | CaseN n <- name =
557 'c' : translateName n
559translateConstant :: Const -> JS
560translateConstant (I i) = JSNum (JSInt i)
561translateConstant (Fl f) = JSNum (JSFloat f)
562translateConstant (Ch c) = JSString [c]
563translateConstant (Str s) = JSString s
564translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
565translateConstant StrType = JSType JSStringTy
566translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
567translateConstant (AType ATFloat) = JSType JSFloatTy
568translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
569translateConstant PtrType = JSType JSPtrTy
570translateConstant Forgot = JSType JSForgotTy
571translateConstant (BI i) = jsBigInt $ JSString (show i)
572translateConstant c =
573 JSError $ "Unimplemented Constant: " ++ show c
575translateDeclaration :: (String, SDecl) -> JS
576translateDeclaration (path, SFun name params stackSize body)
577 | (MN _ "APPLY") <- name
578 , (SLet var val next) <- body
579 , (SChkCase cvar cases) <- next =
580 let lvar = translateVariableName var
581 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
582 JSSeq [ lookupTable [(var, "chk")] var cases
583 , jsDecl $ JSFunction ["fn0", "arg0"] (
584 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
585 , JSReturn $ jsLet (translateVariableName var) (
586 translateExpression val
587 ) (JSTernary (
588 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
589 (hasProp lookupTableName (translateVariableName var))
590 ) (JSIdent $
591 lookupTableName ++ lookup
592 ) JSNull
593 )
594 ]
595 )
596 ]
598 | (MN _ "EVAL") <- name
599 , (SChkCase var cases) <- body =
600 JSSeq [ lookupTable [] var cases
601 , jsDecl $ JSFunction ["arg0"] (JSReturn $
602 JSTernary (
603 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
604 (hasProp lookupTableName "arg0")
605 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0")
606 )
607 ]
608 | otherwise =
609 let fun = translateExpression body in
610 jsDecl $ jsFun fun
612 where
613 hasProp :: String -> String -> JS
614 hasProp table var =
615 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
617 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
618 caseFun aux var cse =
619 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
621 getTag :: SAlt -> Maybe Int
622 getTag (SConCase _ tag _ _ _) = Just tag
623 getTag _ = Nothing
625 lookupTableName :: String
626 lookupTableName = idrLTNamespace ++ translateName name
628 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
629 lookupTable aux var cases =
630 JSAlloc lookupTableName $ Just (
631 JSApp (JSFunction [] (
632 JSSeq $ [
633 JSAlloc "t" $ Just (JSArray [])
634 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
635 JSReturn (JSIdent "t")
636 ]
637 )) []
638 )
639 where
640 assignEntries :: [(Int, JS)] -> [JS]
641 assignEntries entries =
642 map (\(tag, fun) ->
643 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
644 ) entries
646 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
647 lookupEntry aux var alt = do
648 tag <- getTag alt
649 return (tag, caseFun aux var alt)
651 jsDecl :: JS -> JS
652 jsDecl = JSAlloc (path ++ translateName name) . Just
654 jsFun body = jsFunAux [] body
656 jsFunAux :: [(LVar, String)] -> JS -> JS
657 jsFunAux aux body =
658 JSFunction (p ++ map snd aux) (
659 JSSeq $
660 zipWith assignVar [0..] p ++
661 map allocVar [numP .. (numP + stackSize - 1)] ++
662 map assignAux aux ++
663 [JSReturn body]
664 )
665 where
666 numP :: Int
667 numP = length params
669 allocVar :: Int -> JS
670 allocVar n = JSAlloc (jsVar n) Nothing
672 assignVar :: Int -> String -> JS
673 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
675 assignAux :: (LVar, String) -> JS
676 assignAux (var, val) =
677 JSAssign (JSIdent $ translateVariableName var) (JSIdent val)
679 p :: [String]
680 p = map translateName params
682translateVariableName :: LVar -> String
683translateVariableName (Loc i) =
684 jsVar i
686translateExpression :: SExp -> JS
687translateExpression (SLet name value body) =
688 jsLet (translateVariableName name) (
689 translateExpression value
690 ) (translateExpression body)
692translateExpression (SConst cst) =
693 translateConstant cst
695translateExpression (SV var) =
696 JSVar var
698translateExpression (SApp tc name vars)
699 | False <- tc =
700 jsTailcall $ translateFunctionCall name vars
701 | True <- tc =
702 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
703 JSReturn $ translateFunctionCall name vars
704 )]
705 where
706 translateFunctionCall name vars =
707 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
709translateExpression (SOp op vars)
710 | LNoOp <- op = JSVar (last vars)
712 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
713 | (LPlus (ATInt ITBig)) <- op
714 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
715 | (LMinus (ATInt ITBig)) <- op
716 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
717 | (LTimes (ATInt ITBig)) <- op
718 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
719 | (LSDiv (ATInt ITBig)) <- op
720 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
721 | (LSRem (ATInt ITBig)) <- op
722 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
723 | (LEq (ATInt ITBig)) <- op
724 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
725 | (LSLt (ATInt ITBig)) <- op
726 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
727 | (LSLe (ATInt ITBig)) <- op
728 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
729 | (LSGt (ATInt ITBig)) <- op
730 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
731 | (LSGe (ATInt ITBig)) <- op
732 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
734 | (LPlus ATFloat) <- op
735 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
736 | (LMinus ATFloat) <- op
737 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
738 | (LTimes ATFloat) <- op
739 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
740 | (LSDiv ATFloat) <- op
741 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
742 | (LEq ATFloat) <- op
743 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
744 | (LSLt ATFloat) <- op
745 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
746 | (LSLe ATFloat) <- op
747 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
748 | (LSGt ATFloat) <- op
749 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
750 | (LSGe ATFloat) <- op
751 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
753 | (LPlus _) <- op
754 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
755 | (LMinus _) <- op
756 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
757 | (LTimes _) <- op
758 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
759 | (LSDiv _) <- op
760 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
761 | (LSRem _) <- op
762 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
763 | (LEq _) <- op
764 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
765 | (LSLt _) <- op
766 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
767 | (LSLe _) <- op
768 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
769 | (LSGt _) <- op
770 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
771 | (LSGe _) <- op
772 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
773 | (LAnd _) <- op
774 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
775 | (LOr _) <- op
776 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
777 | (LXOr _) <- op
778 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
779 | (LSHL _) <- op
780 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
781 | (LASHR _) <- op
782 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
783 | (LCompl _) <- op
784 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
786 | LStrConcat <- op
787 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
788 | LStrEq <- op
789 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
790 | LStrLt <- op
791 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
792 | LStrLen <- op
793 , (arg:_) <- vars = JSProj (JSVar arg) "length"
795 | (LStrInt ITNative) <- op
796 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
797 | (LIntStr ITNative) <- op
798 , (arg:_) <- vars = jsCall "String" [JSVar arg]
799 | (LSExt ITNative ITBig) <- op
800 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
801 | (LTrunc ITBig ITNative) <- op
802 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
803 | (LIntStr ITBig) <- op
804 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
805 | (LStrInt ITBig) <- op
806 , (arg:_) <- vars = jsBigInt $ JSVar arg
807 | LFloatStr <- op
808 , (arg:_) <- vars = jsCall "String" [JSVar arg]
809 | LStrFloat <- op
810 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
811 | (LIntFloat ITNative) <- op
812 , (arg:_) <- vars = JSVar arg
813 | (LFloatInt ITNative) <- op
814 , (arg:_) <- vars = JSVar arg
815 | (LChInt ITNative) <- op
816 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
817 | (LIntCh ITNative) <- op
818 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
820 | LFExp <- op
821 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
822 | LFLog <- op
823 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
824 | LFSin <- op
825 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
826 | LFCos <- op
827 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
828 | LFTan <- op
829 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
830 | LFASin <- op
831 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
832 | LFACos <- op
833 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
834 | LFATan <- op
835 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
836 | LFSqrt <- op
837 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
838 | LFFloor <- op
839 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
840 | LFCeil <- op
841 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
843 | LStrCons <- op
844 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
845 | LStrHead <- op
846 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
847 | LStrRev <- op
848 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
849 | LStrIndex <- op
850 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
851 | LStrTail <- op
852 , (arg:_) <- vars = let v = translateVariableName arg in
853 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
854 where
855 translateBinaryOp :: String -> LVar -> LVar -> JS
856 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
858 invokeMeth :: LVar -> String -> [LVar] -> JS
859 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
861translateExpression (SError msg) =
862 JSError msg
864translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
865 jsCall (idrRTNamespace ++ "print") [JSVar var]
867translateExpression (SForeign _ _ fun args) =
868 ffi fun (map generateWrapper args)
869 where
870 generateWrapper (ffunc, name)
871 | FFunction <- ffunc =
872 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
873 | FFunctionIO <- ffunc =
874 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
876 generateWrapper (_, name) =
877 translateVariableName name
879translateExpression patterncase
880 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
881 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
882 where
883 caseHelper var cases param =
884 JSApp (JSFunction [param] (
885 JSCond $ map (expandCase param . translateCaseCond param) cases
886 )) [JSVar var]
888 expandCase :: String -> (Cond, JS) -> (JS, JS)
889 expandCase _ (RawCond cond, branch) = (cond, branch)
890 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
891 expandCase var (CaseCond caseTy, branch)
892 | ConCase tag <- caseTy =
893 let checkCon = JSIdent var `jsInstanceOf` jsCon
894 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
895 (checkCon `jsAnd` checkTag, branch)
897 | TypeCase ty <- caseTy =
898 let checkTy = JSIdent var `jsInstanceOf` jsType
899 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
900 (checkTy `jsAnd` checkTag, branch)
902translateExpression (SCon i name vars) =
903 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
904 , JSArray $ map JSVar vars
905 ]
907translateExpression (SUpdate var e) =
908 JSAssign (JSVar var) (translateExpression e)
910translateExpression (SProj var i) =
911 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
913translateExpression SNothing = JSNull
915translateExpression e =
916 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
918data FFI = FFICode Char | FFIArg Int | FFIError String
920ffi :: String -> [String] -> JS
921ffi code args = let parsed = ffiParse code in
922 case ffiError parsed of
923 Just err -> JSError err
924 Nothing -> JSRaw $ renderFFI parsed args
925 where
926 ffiParse :: String -> [FFI]
927 ffiParse "" = []
928 ffiParse ['%'] = [FFIError "Invalid positional argument"]
929 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
930 ffiParse ('%':s:ss)
931 | isDigit s =
932 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
933 | otherwise =
934 [FFIError "Invalid positional argument"]
935 ffiParse (s:ss) = FFICode s : ffiParse ss
937 ffiError :: [FFI] -> Maybe String
938 ffiError [] = Nothing
939 ffiError ((FFIError s):xs) = Just s
940 ffiError (x:xs) = ffiError xs
942 renderFFI :: [FFI] -> [String] -> String
943 renderFFI [] _ = ""
944 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
945 renderFFI ((FFIArg i) : fs) args
946 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
947 | otherwise = "Argument index out of bounds"
949data CaseType = ConCase Int
950 | TypeCase JSType
951 | DefaultCase
952 deriving Eq
954data Cond = CaseCond CaseType
955 | RawCond JS
957translateCaseCond :: String -> SAlt -> (Cond, JS)
958translateCaseCond _ cse@(SDefaultCase _) =
959 (CaseCond DefaultCase, translateCase Nothing cse)
961translateCaseCond var cse@(SConstCase ty _)
962 | StrType <- ty = matchHelper JSStringTy
963 | PtrType <- ty = matchHelper JSPtrTy
964 | Forgot <- ty = matchHelper JSForgotTy
965 | (AType ATFloat) <- ty = matchHelper JSFloatTy
966 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
967 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
968 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
969 where
970 matchHelper :: JSType -> (Cond, JS)
971 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
973translateCaseCond var cse@(SConstCase cst@(BI _) _) =
974 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
975 (RawCond cond, translateCase Nothing cse)
977translateCaseCond var cse@(SConstCase cst _) =
978 let cond = JSIdent var `jsEq` translateConstant cst in
979 (RawCond cond, translateCase Nothing cse)
981translateCaseCond var cse@(SConCase _ tag _ _ _) =
982 (CaseCond $ ConCase tag, translateCase (Just var) cse)
984translateCase :: Maybe String -> SAlt -> JS
985translateCase _ (SDefaultCase e) = translateExpression e
986translateCase _ (SConstCase _ e) = translateExpression e
987translateCase (Just var) (SConCase a _ _ vars e) =
988 let params = map jsVar [a .. (a + length vars)] in
989 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
990 JSThis, JSProj (JSIdent var) "vars"
991 ]