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