git.iko.soy/Idris-dev
on 0efe215 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
976 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 Data.Char
16import Data.List
17import Data.Maybe
18import System.IO
19import System.Directory
21idrNamespace :: String
22idrNamespace = "__IDR__"
23idrRTNamespace = "__IDRRT__"
24idrLTNamespace = "__IDRLT__"
26data JSTarget = Node | JavaScript deriving Eq
28data JSType = JSIntTy
29 | JSStringTy
30 | JSIntegerTy
31 | JSFloatTy
32 | JSCharTy
33 | JSPtrTy
34 | JSForgotTy
35 deriving Eq
37data JSNum = JSInt Int
38 | JSFloat Double
39 | JSInteger Integer
40 deriving Eq
42data JS = JSRaw String
43 | JSFunction [String] JS
44 | JSType JSType
45 | JSSeq [JS]
46 | JSReturn JS
47 | JSApp JS [JS]
48 | JSNew String [JS]
49 | JSError String
50 | JSOp String JS JS
51 | JSProj JS String
52 | JSVar LVar
53 | JSNull
54 | JSThis
55 | JSTrue
56 | JSFalse
57 | JSArray [JS]
58 | JSObject [(String, JS)]
59 | JSString String
60 | JSNum JSNum
61 | JSAssign JS JS
62 | JSAlloc String (Maybe JS)
63 | JSIndex JS JS
64 | JSCond [(JS, JS)]
65 | JSTernary JS JS JS
66 deriving Eq
68compileJS :: JS -> String
69compileJS (JSRaw code) =
70 code
72compileJS (JSFunction args body) =
73 "function("
74 ++ intercalate "," args
75 ++ "){\n"
76 ++ compileJS body
77 ++ "\n}"
79compileJS (JSType ty)
80 | JSIntTy <- ty = idrRTNamespace ++ "Int"
81 | JSStringTy <- ty = idrRTNamespace ++ "String"
82 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
83 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
84 | JSCharTy <- ty = idrRTNamespace ++ "Char"
85 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
86 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
88compileJS (JSSeq seq) =
89 intercalate ";\n" (map compileJS seq)
91compileJS (JSReturn val) =
92 "return " ++ compileJS val
94compileJS (JSApp lhs rhs)
95 | JSFunction {} <- lhs =
96 concat ["(", compileJS lhs, ")(", args, ")"]
97 | otherwise =
98 concat [compileJS lhs, "(", args, ")"]
99 where args :: String
100 args = intercalate "," $ map compileJS rhs
102compileJS (JSNew name args) =
103 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
105compileJS (JSError exc) =
106 "(function(){throw '" ++ exc ++ "';})()"
108compileJS (JSOp op lhs rhs) =
109 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
111compileJS (JSProj obj field)
112 | JSFunction {} <- obj =
113 concat ["(", compileJS obj, ").", field]
114 | JSAssign {} <- obj =
115 concat ["(", compileJS obj, ").", field]
116 | otherwise =
117 compileJS obj ++ '.' : field
119compileJS (JSVar var) =
120 translateVariableName var
122compileJS JSNull =
123 "null"
125compileJS JSThis =
126 "this"
128compileJS JSTrue =
129 "true"
131compileJS JSFalse =
132 "false"
134compileJS (JSArray elems) =
135 "[" ++ intercalate "," (map compileJS elems) ++ "]"
137compileJS (JSObject fields) =
138 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
139 where
140 compileField :: (String, JS) -> String
141 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
143compileJS (JSString str) =
144 show str
146compileJS (JSNum num)
147 | JSInt i <- num = show i
148 | JSFloat f <- num = show f
149 | JSInteger i <- num = show i
151compileJS (JSAssign lhs rhs) =
152 compileJS lhs ++ "=" ++ compileJS rhs
154compileJS (JSAlloc name val) =
155 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
157compileJS (JSIndex lhs rhs) =
158 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
160compileJS (JSCond branches) =
161 intercalate " else " $ map createIfBlock branches
162 where
163 createIfBlock (cond, e) =
164 "if (" ++ compileJS cond ++") {\n"
165 ++ "return " ++ compileJS e
166 ++ ";\n}"
168compileJS (JSTernary cond true false) =
169 let c = compileJS cond
170 t = compileJS true
171 f = compileJS false in
172 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
174jsTailcall :: JS -> JS
175jsTailcall call =
176 jsCall (idrRTNamespace ++ "tailcall") [
177 JSFunction [] (JSReturn call)
178 ]
180jsCall :: String -> [JS] -> JS
181jsCall fun = JSApp (JSRaw fun)
183jsMeth :: JS -> String -> [JS] -> JS
184jsMeth obj meth =
185 JSApp (JSProj obj meth)
187jsInstanceOf :: JS -> JS -> JS
188jsInstanceOf = JSOp "instanceof"
190jsEq :: JS -> JS -> JS
191jsEq = JSOp "=="
193jsAnd :: JS -> JS -> JS
194jsAnd = JSOp "&&"
196jsType :: JS
197jsType = JSRaw $ idrRTNamespace ++ "Type"
199jsCon :: JS
200jsCon = JSRaw $ idrRTNamespace ++ "Con"
202jsTag :: JS -> JS
203jsTag obj = JSProj obj "tag"
205jsTypeTag :: JS -> JS
206jsTypeTag obj = JSProj obj "type"
208jsBigInt :: JS -> JS
209jsBigInt val =
210 JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]
212jsVar :: Int -> String
213jsVar = ("__var_" ++) . show
215jsLet :: String -> JS -> JS -> JS
216jsLet name value body =
217 JSApp (
218 JSFunction [name] (
219 JSReturn body
220 )
221 ) [value]
223jsSubst :: String -> JS -> JS -> JS
224jsSubst var new (JSVar old)
225 | var == translateVariableName old = new
227jsSubst var new (JSRaw old)
228 | var == old = new
230jsSubst var new (JSArray fields) =
231 JSArray (map (jsSubst var new) fields)
233jsSubst var new (JSNew con [tag, vals]) =
234 JSNew con [tag, jsSubst var new vals]
236jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
237 JSNew con [JSFunction [] (
238 JSReturn $ JSApp fun (map (jsSubst var new) vars)
239 )]
241jsSubst var new (JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
242 JSReturn (JSApp fun args)
243 )]) =
244 JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
245 JSReturn $ JSApp fun (map (jsSubst var new) args)
246 )]
248jsSubst var new (JSApp (JSFunction [arg] body) vals)
249 | var /= arg =
250 JSApp (JSFunction [arg] (
251 jsSubst var new body
252 )) $ map (jsSubst var new) vals
254jsSubst var new (JSReturn ret) =
255 JSReturn $ jsSubst var new ret
257jsSubst _ _ js = js
259inlineJS :: JS -> JS
260inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
261 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
263inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
264 | JSNew con [tag, vals] <- ret
265 , opt <- inlineJS val =
266 JSNew con [tag, jsSubst arg opt vals]
268 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
269 , opt <- inlineJS val =
270 JSNew con [JSFunction [] (
271 JSReturn $ JSApp fun (map (jsSubst arg opt) vars)
272 )]
274 | JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
275 JSReturn (JSApp fun args)
276 )] <- ret
277 , opt <- inlineJS val =
278 JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
279 JSReturn $ JSApp fun (map (jsSubst arg opt) args)
280 )]
282 | JSIndex (JSProj obj field) idx <- ret
283 , opt <- inlineJS val =
284 JSIndex (JSProj (
285 jsSubst arg opt obj
286 ) field
287 ) (jsSubst arg opt idx)
289 | JSOp op lhs rhs <- ret =
290 JSOp op (jsSubst arg (inlineJS val) lhs) $
291 (jsSubst arg (inlineJS val) rhs)
293inlineJS (JSApp fun args) =
294 JSApp (inlineJS fun) (map inlineJS args)
296inlineJS (JSNew con args) =
297 JSNew con $ map inlineJS args
299inlineJS (JSArray fields) =
300 JSArray (map inlineJS fields)
302inlineJS (JSAssign lhs rhs) =
303 JSAssign lhs (inlineJS rhs)
305inlineJS (JSSeq seq) =
306 JSSeq (map inlineJS seq)
308inlineJS (JSFunction args body) =
309 JSFunction args (inlineJS body)
311inlineJS (JSProj (JSFunction args body) "apply") =
312 JSProj (JSFunction args (inlineJS body)) "apply"
314inlineJS (JSReturn js) =
315 JSReturn $ inlineJS js
317inlineJS (JSAlloc name (Just js)) =
318 JSAlloc name (Just $ inlineJS js)
320inlineJS (JSCond cases) =
321 JSCond (map (second inlineJS) cases)
323inlineJS (JSObject fields) =
324 JSObject (map (second inlineJS) fields)
326inlineJS js = js
328reduceJS :: [JS] -> [JS]
329reduceJS program =
330 case partition findConstructors program of
331 (candidates, rest) ->
332 map reduce candidates ++ map (reduceCall (map funNames candidates)) rest
333 where findConstructors :: JS -> Bool
334 findConstructors js
335 | (JSAlloc fun (Just (JSFunction [] (JSSeq body)))) <- js =
336 reducable $ last body
337 | otherwise = False
338 where reducable :: JS -> Bool
339 reducable (JSReturn js) = reducable js
340 reducable (JSNew _ args) = and $ map reducable args
341 reducable (JSArray fields) = and $ map reducable fields
342 reducable (JSNum _) = True
343 reducable JSNull = True
344 reducable _ = False
346 reduce :: JS -> JS
347 reduce (JSAlloc fun (Just (JSFunction [] (JSSeq body))))
348 | JSReturn js <- last body = (JSAlloc fun (Just js))
349 | otherwise = error "this should not happen"
351 funNames :: JS -> String
352 funNames (JSAlloc fun _) = fun
353 funNames _ = error "WTF?"
355 reduceCall :: [String] -> JS -> JS
356 reduceCall funs (JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
357 JSReturn (JSApp (JSRaw ret) [])
358 )])
359 | ret `elem` funs = JSRaw ret
361 reduceCall funs js@(JSApp (JSRaw fun) [])
362 | fun `elem` funs = JSRaw fun
363 | otherwise = js
365 reduceCall funs (JSAlloc fun (Just body)) =
366 JSAlloc fun (Just $ reduceCall funs body)
368 reduceCall funs (JSReturn js) =
369 JSReturn $ reduceCall funs js
371 reduceCall funs (JSSeq js) =
372 JSSeq $ map (reduceCall funs) js
374 reduceCall funs (JSNew con args) =
375 JSNew con $ map (reduceCall funs) args
377 reduceCall funs (JSFunction args body) =
378 JSFunction args $ reduceCall funs body
380 reduceCall funs (JSApp fun args) =
381 JSApp (reduceCall funs fun) $ map (reduceCall funs) args
383 reduceCall funs (JSProj obj field) =
384 JSProj (reduceCall funs obj) field
386 reduceCall funs (JSCond conds) =
387 JSCond $ map (reduceCall funs *** reduceCall funs) conds
389 reduceCall funs (JSAssign lhs rhs) =
390 JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
392 reduceCall funs (JSArray fields) =
393 JSArray $ map (reduceCall funs) fields
395 reduceCall _ js = js
397optimizeJS :: JS -> JS
398optimizeJS = inlineLoop
399 where inlineLoop :: JS -> JS
400 inlineLoop js
401 | opt <- inlineJS js
402 , opt /= js = inlineLoop opt
403 | otherwise = js
405codegenJavaScript
406 :: JSTarget
407 -> [(Name, SDecl)]
408 -> FilePath
409 -> OutputType
410 -> IO ()
411codegenJavaScript target definitions filename outputType = do
412 let (header, runtime) = case target of
413 Node ->
414 ("#!/usr/bin/env node\n", "-node")
415 JavaScript ->
416 ("", "-browser")
417 path <- getDataDir
418 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
419 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
420 writeFile filename $ header ++ (
421 intercalate "\n" $ [ idrRuntime
422 , tgtRuntime
423 ] ++ functions ++ [mainLoop, invokeLoop]
424 )
426 setPermissions filename (emptyPermissions { readable = True
427 , executable = target == Node
428 , writable = True
429 })
430 where
431 def :: [(String, SDecl)]
432 def = map (first translateNamespace) definitions
434 functions :: [String]
435 functions =
436 map compileJS (reduceJS $ map (optimizeJS . translateDeclaration) def)
438 mainLoop :: String
439 mainLoop = compileJS $
440 JSAlloc "main" $ Just $ JSFunction [] (
441 case target of
442 Node -> mainFun
443 JavaScript -> jsMeth (JSRaw "window") "addEventListener" [
444 JSString "DOMContentLoaded", JSFunction [] (
445 mainFun
446 ), JSFalse
447 ]
448 )
449 where
450 mainFun :: JS
451 mainFun = jsTailcall $ jsCall runMain []
453 runMain :: String
454 runMain = idrNamespace ++ translateName (MN 0 "runMain")
456 invokeLoop :: String
457 invokeLoop = compileJS $ jsCall "main" []
459translateIdentifier :: String -> String
460translateIdentifier =
461 replaceReserved . concatMap replaceBadChars
462 where replaceBadChars :: Char -> String
463 replaceBadChars c
464 | ' ' <- c = "_"
465 | '_' <- c = "__"
466 | isDigit c = '_' : show (ord c)
467 | not (isLetter c && isAscii c) = '_' : show (ord c)
468 | otherwise = [c]
469 replaceReserved s
470 | s `elem` reserved = '_' : s
471 | otherwise = s
472 reserved = [ "break"
473 , "case"
474 , "catch"
475 , "continue"
476 , "debugger"
477 , "default"
478 , "delete"
479 , "do"
480 , "else"
481 , "finally"
482 , "for"
483 , "function"
484 , "if"
485 , "in"
486 , "instanceof"
487 , "new"
488 , "return"
489 , "switch"
490 , "this"
491 , "throw"
492 , "try"
493 , "typeof"
494 , "var"
495 , "void"
496 , "while"
497 , "with"
499 , "class"
500 , "enum"
501 , "export"
502 , "extends"
503 , "import"
504 , "super"
506 , "implements"
507 , "interface"
508 , "let"
509 , "package"
510 , "private"
511 , "protected"
512 , "public"
513 , "static"
514 , "yield"
515 ]
517translateNamespace :: Name -> String
518translateNamespace (UN _) = idrNamespace
519translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
520translateNamespace (MN _ _) = idrNamespace
521translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
522translateNamespace NErased = idrNamespace
524translateName :: Name -> String
525translateName (UN name) = 'u' : translateIdentifier name
526translateName (NS name _) = 'n' : translateName name
527translateName (MN i name) = 'm' : translateIdentifier name ++ show i
528translateName (SN name) = 's' : translateSpecialName name
529translateName NErased = "e"
531translateSpecialName :: SpecialName -> String
532translateSpecialName name
533 | WhereN i m n <- name =
534 'w' : translateName m ++ translateName n ++ show i
535 | InstanceN n s <- name =
536 'i' : translateName n ++ concatMap translateIdentifier s
537 | ParentN n s <- name =
538 'p' : translateName n ++ translateIdentifier s
539 | MethodN n <- name =
540 'm' : translateName n
541 | CaseN n <- name =
542 'c' : translateName n
544translateConstant :: Const -> JS
545translateConstant (I i) = JSNum (JSInt i)
546translateConstant (Fl f) = JSNum (JSFloat f)
547translateConstant (Ch c) = JSString [c]
548translateConstant (Str s) = JSString s
549translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
550translateConstant StrType = JSType JSStringTy
551translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
552translateConstant (AType ATFloat) = JSType JSFloatTy
553translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
554translateConstant PtrType = JSType JSPtrTy
555translateConstant Forgot = JSType JSForgotTy
556translateConstant (BI i) = jsBigInt $ JSString (show i)
557translateConstant c =
558 JSError $ "Unimplemented Constant: " ++ show c
560translateDeclaration :: (String, SDecl) -> JS
561translateDeclaration (path, SFun name params stackSize body)
562 | (MN _ "APPLY") <- name
563 , (SLet var val next) <- body
564 , (SChkCase cvar cases) <- next =
565 let lvar = translateVariableName var
566 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
567 JSSeq [ lookupTable [(var, "chk")] var cases
568 , jsDecl $ JSFunction ["fn0", "arg0"] (
569 JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
570 , JSReturn $ jsLet (translateVariableName var) (
571 translateExpression val
572 ) (JSTernary (
573 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
574 (hasProp lookupTableName (translateVariableName var))
575 ) (JSRaw $
576 lookupTableName ++ lookup
577 ) JSNull
578 )
579 ]
580 )
581 ]
583 | (MN _ "EVAL") <- name
584 , (SChkCase var cases) <- body =
585 JSSeq [ lookupTable [] var cases
586 , jsDecl $ JSFunction ["arg0"] (JSReturn $
587 JSTernary (
588 (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
589 (hasProp lookupTableName "arg0")
590 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
591 )
592 ]
593 | otherwise =
594 let fun = translateExpression body in
595 jsDecl $ jsFun fun
597 where
598 hasProp :: String -> String -> JS
599 hasProp table var =
600 JSIndex (JSRaw table) (JSProj (JSRaw var) "tag")
602 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
603 caseFun aux var cse =
604 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
606 getTag :: SAlt -> Maybe Int
607 getTag (SConCase _ tag _ _ _) = Just tag
608 getTag _ = Nothing
610 lookupTableName :: String
611 lookupTableName = idrLTNamespace ++ translateName name
613 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
614 lookupTable aux var cases =
615 JSAlloc lookupTableName $ Just (
616 JSApp (JSFunction [] (
617 JSSeq $ [
618 JSAlloc "t" $ Just (JSArray [])
619 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
620 JSReturn (JSRaw "t")
621 ]
622 )) []
623 )
624 where
625 assignEntries :: [(Int, JS)] -> [JS]
626 assignEntries entries =
627 map (\(tag, fun) ->
628 JSAssign (JSIndex (JSRaw "t") (JSNum $ JSInt tag)) fun
629 ) entries
631 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
632 lookupEntry aux var alt = do
633 tag <- getTag alt
634 return (tag, caseFun aux var alt)
636 jsDecl :: JS -> JS
637 jsDecl = JSAlloc (path ++ translateName name) . Just
639 jsFun body = jsFunAux [] body
641 jsFunAux :: [(LVar, String)] -> JS -> JS
642 jsFunAux aux body =
643 JSFunction (p ++ map snd aux) (
644 JSSeq $
645 zipWith assignVar [0..] p ++
646 map allocVar [numP .. (numP + stackSize - 1)] ++
647 map assignAux aux ++
648 [JSReturn body]
649 )
650 where
651 numP :: Int
652 numP = length params
654 allocVar :: Int -> JS
655 allocVar n = JSAlloc (jsVar n) Nothing
657 assignVar :: Int -> String -> JS
658 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
660 assignAux :: (LVar, String) -> JS
661 assignAux (var, val) =
662 JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
664 p :: [String]
665 p = map translateName params
667translateVariableName :: LVar -> String
668translateVariableName (Loc i) =
669 jsVar i
671translateExpression :: SExp -> JS
672translateExpression (SLet name value body) =
673 jsLet (translateVariableName name) (
674 translateExpression value
675 ) (translateExpression body)
677translateExpression (SConst cst) =
678 translateConstant cst
680translateExpression (SV var) =
681 JSVar var
683translateExpression (SApp tc name vars)
684 | False <- tc =
685 jsTailcall $ translateFunctionCall name vars
686 | True <- tc =
687 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
688 JSReturn $ translateFunctionCall name vars
689 )]
690 where
691 translateFunctionCall name vars =
692 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
694translateExpression (SOp op vars)
695 | LNoOp <- op = JSVar (last vars)
697 | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
698 | (LPlus (ATInt ITBig)) <- op
699 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
700 | (LMinus (ATInt ITBig)) <- op
701 , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
702 | (LTimes (ATInt ITBig)) <- op
703 , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
704 | (LSDiv (ATInt ITBig)) <- op
705 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
706 | (LSRem (ATInt ITBig)) <- op
707 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
708 | (LEq (ATInt ITBig)) <- op
709 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
710 | (LSLt (ATInt ITBig)) <- op
711 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
712 | (LSLe (ATInt ITBig)) <- op
713 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
714 | (LSGt (ATInt ITBig)) <- op
715 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
716 | (LSGe (ATInt ITBig)) <- op
717 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
719 | (LPlus ATFloat) <- op
720 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
721 | (LMinus ATFloat) <- op
722 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
723 | (LTimes ATFloat) <- op
724 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
725 | (LSDiv ATFloat) <- op
726 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
727 | (LEq ATFloat) <- op
728 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
729 | (LSLt ATFloat) <- op
730 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
731 | (LSLe ATFloat) <- op
732 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
733 | (LSGt ATFloat) <- op
734 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
735 | (LSGe ATFloat) <- op
736 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
738 | (LPlus _) <- op
739 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
740 | (LMinus _) <- op
741 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
742 | (LTimes _) <- op
743 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
744 | (LSDiv _) <- op
745 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
746 | (LSRem _) <- op
747 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
748 | (LEq _) <- op
749 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
750 | (LSLt _) <- op
751 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
752 | (LSLe _) <- op
753 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
754 | (LSGt _) <- op
755 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
756 | (LSGe _) <- op
757 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
758 | (LAnd _) <- op
759 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
760 | (LOr _) <- op
761 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
762 | (LXOr _) <- op
763 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
764 | (LSHL _) <- op
765 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
766 | (LASHR _) <- op
767 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
768 | (LCompl _) <- op
769 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
771 | LStrConcat <- op
772 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
773 | LStrEq <- op
774 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
775 | LStrLt <- op
776 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
777 | LStrLen <- op
778 , (arg:_) <- vars = JSProj (JSVar arg) "length"
780 | (LStrInt ITNative) <- op
781 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
782 | (LIntStr ITNative) <- op
783 , (arg:_) <- vars = jsCall "String" [JSVar arg]
784 | (LSExt ITNative ITBig) <- op
785 , (arg:_) <- vars = jsBigInt $ JSVar arg
786 | (LTrunc ITBig ITNative) <- op
787 , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
788 | (LIntStr ITBig) <- op
789 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
790 | (LStrInt ITBig) <- op
791 , (arg:_) <- vars = jsBigInt $ JSVar arg
792 | LFloatStr <- op
793 , (arg:_) <- vars = jsCall "String" [JSVar arg]
794 | LStrFloat <- op
795 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
796 | (LIntFloat ITNative) <- op
797 , (arg:_) <- vars = JSVar arg
798 | (LFloatInt ITNative) <- op
799 , (arg:_) <- vars = JSVar arg
800 | (LChInt ITNative) <- op
801 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
802 | (LIntCh ITNative) <- op
803 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
805 | LFExp <- op
806 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
807 | LFLog <- op
808 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
809 | LFSin <- op
810 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
811 | LFCos <- op
812 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
813 | LFTan <- op
814 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
815 | LFASin <- op
816 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
817 | LFACos <- op
818 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
819 | LFATan <- op
820 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
821 | LFSqrt <- op
822 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
823 | LFFloor <- op
824 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
825 | LFCeil <- op
826 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
828 | LStrCons <- op
829 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
830 | LStrHead <- op
831 , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
832 | LStrRev <- op
833 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
834 | LStrIndex <- op
835 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
836 | LStrTail <- op
837 , (arg:_) <- vars = let v = translateVariableName arg in
838 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
839 where
840 translateBinaryOp :: String -> LVar -> LVar -> JS
841 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
843 invokeMeth :: LVar -> String -> [LVar] -> JS
844 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
846translateExpression (SError msg) =
847 JSError msg
849translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
850 jsCall (idrRTNamespace ++ "print") [JSVar var]
852translateExpression (SForeign _ _ fun args) =
853 ffi fun (map generateWrapper args)
854 where
855 generateWrapper (ffunc, name)
856 | FFunction <- ffunc =
857 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
858 | FFunctionIO <- ffunc =
859 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
861 generateWrapper (_, name) =
862 translateVariableName name
864translateExpression patterncase
865 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
866 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
867 where
868 caseHelper var cases param =
869 JSApp (JSFunction [param] (
870 JSCond $ map (expandCase param . translateCaseCond param) cases
871 )) [JSVar var]
873 expandCase :: String -> (Cond, JS) -> (JS, JS)
874 expandCase _ (RawCond cond, branch) = (cond, branch)
875 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
876 expandCase var (CaseCond caseTy, branch)
877 | ConCase tag <- caseTy =
878 let checkCon = JSRaw var `jsInstanceOf` jsCon
879 checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
880 (checkCon `jsAnd` checkTag, branch)
882 | TypeCase ty <- caseTy =
883 let checkTy = JSRaw var `jsInstanceOf` jsType
884 checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in
885 (checkTy `jsAnd` checkTag, branch)
887translateExpression (SCon i name vars) =
888 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
889 , JSArray $ map JSVar vars
890 ]
892translateExpression (SUpdate var e) =
893 JSAssign (JSVar var) (translateExpression e)
895translateExpression (SProj var i) =
896 JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
898translateExpression SNothing = JSNull
900translateExpression e =
901 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
903data FFI = FFICode Char | FFIArg Int | FFIError String
905ffi :: String -> [String] -> JS
906ffi code args = let parsed = ffiParse code in
907 case ffiError parsed of
908 Just err -> JSError err
909 Nothing -> JSRaw $ renderFFI parsed args
910 where
911 ffiParse :: String -> [FFI]
912 ffiParse "" = []
913 ffiParse ['%'] = [FFIError "Invalid positional argument"]
914 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
915 ffiParse ('%':s:ss)
916 | isDigit s =
917 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
918 | otherwise =
919 [FFIError "Invalid positional argument"]
920 ffiParse (s:ss) = FFICode s : ffiParse ss
922 ffiError :: [FFI] -> Maybe String
923 ffiError [] = Nothing
924 ffiError ((FFIError s):xs) = Just s
925 ffiError (x:xs) = ffiError xs
927 renderFFI :: [FFI] -> [String] -> String
928 renderFFI [] _ = ""
929 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
930 renderFFI ((FFIArg i) : fs) args
931 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
932 | otherwise = "Argument index out of bounds"
934data CaseType = ConCase Int
935 | TypeCase JSType
936 | DefaultCase
937 deriving Eq
939data Cond = CaseCond CaseType
940 | RawCond JS
942translateCaseCond :: String -> SAlt -> (Cond, JS)
943translateCaseCond _ cse@(SDefaultCase _) =
944 (CaseCond DefaultCase, translateCase Nothing cse)
946translateCaseCond var cse@(SConstCase ty _)
947 | StrType <- ty = matchHelper JSStringTy
948 | PtrType <- ty = matchHelper JSPtrTy
949 | Forgot <- ty = matchHelper JSForgotTy
950 | (AType ATFloat) <- ty = matchHelper JSFloatTy
951 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
952 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
953 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
954 where
955 matchHelper :: JSType -> (Cond, JS)
956 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
958translateCaseCond var cse@(SConstCase cst@(BI _) _) =
959 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
960 (RawCond cond, translateCase Nothing cse)
962translateCaseCond var cse@(SConstCase cst _) =
963 let cond = JSRaw var `jsEq` translateConstant cst in
964 (RawCond cond, translateCase Nothing cse)
966translateCaseCond var cse@(SConCase _ tag _ _ _) =
967 (CaseCond $ ConCase tag, translateCase (Just var) cse)
969translateCase :: Maybe String -> SAlt -> JS
970translateCase _ (SDefaultCase e) = translateExpression e
971translateCase _ (SConstCase _ e) = translateExpression e
972translateCase (Just var) (SConCase a _ _ vars e) =
973 let params = map jsVar [a .. (a + length vars)] in
974 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
975 JSThis, JSProj (JSRaw var) "vars"
976 ]