git.iko.soy/Idris-dev
on d5c8aec help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
825 lines 27 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
41data JS = JSRaw String
42 | JSFunction [String] JS
43 | JSType JSType
44 | JSSeq [JS]
45 | JSReturn JS
46 | JSApp JS [JS]
47 | JSNew String [JS]
48 | JSError String
49 | JSOp String JS JS
50 | JSProj JS String
51 | JSVar LVar
52 | JSNull
53 | JSThis
54 | JSTrue
55 | JSFalse
56 | JSArray [JS]
57 | JSObject [(String, JS)]
58 | JSString String
59 | JSNum JSNum
60 | JSAssign JS JS
61 | JSAlloc String (Maybe JS)
62 | JSIndex JS JS
63 | JSCond [(JS, JS)]
64 | JSTernary JS JS JS
66compileJS :: JS -> String
67compileJS (JSRaw code) =
68 code
70compileJS (JSFunction args body) =
71 "function("
72 ++ intercalate "," args
73 ++ "){\n"
74 ++ compileJS body
75 ++ "\n}"
77compileJS (JSType ty)
78 | JSIntTy <- ty = idrRTNamespace ++ "Int"
79 | JSStringTy <- ty = idrRTNamespace ++ "String"
80 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
81 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
82 | JSCharTy <- ty = idrRTNamespace ++ "Char"
83 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
84 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
86compileJS (JSSeq seq) =
87 intercalate ";\n" (map compileJS seq)
89compileJS (JSReturn val) =
90 "return " ++ compileJS val
92compileJS (JSApp lhs rhs)
93 | JSFunction {} <- lhs =
94 concat ["(", compileJS lhs, ")(", args, ")"]
95 | otherwise =
96 concat [compileJS lhs, "(", args, ")"]
97 where args :: String
98 args = intercalate "," $ map compileJS rhs
100compileJS (JSNew name args) =
101 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
103compileJS (JSError exc) =
104 "(function(){throw '" ++ exc ++ "';})()"
106compileJS (JSOp op lhs rhs) =
107 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
109compileJS (JSProj obj field)
110 | JSFunction {} <- obj =
111 concat ["(", compileJS obj, ").", field]
112 | otherwise =
113 compileJS obj ++ '.' : field
115compileJS (JSVar var) =
116 translateVariableName var
118compileJS JSNull =
119 "null"
121compileJS JSThis =
122 "this"
124compileJS JSTrue =
125 "true"
127compileJS JSFalse =
128 "false"
130compileJS (JSArray elems) =
131 "[" ++ intercalate "," (map compileJS elems) ++ "]"
133compileJS (JSObject fields) =
134 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
135 where
136 compileField :: (String, JS) -> String
137 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
139compileJS (JSString str) =
140 show str
142compileJS (JSNum num)
143 | JSInt i <- num = show i
144 | JSFloat f <- num = show f
145 | JSInteger i <- num = show i
147compileJS (JSAssign lhs rhs) =
148 compileJS lhs ++ "=" ++ compileJS rhs
150compileJS (JSAlloc name val) =
151 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
153compileJS (JSIndex lhs rhs) =
154 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
156compileJS (JSCond branches) =
157 intercalate " else " $ map createIfBlock branches
158 where
159 createIfBlock (cond, e) =
160 "if (" ++ compileJS cond ++") {\n"
161 ++ "return " ++ compileJS e
162 ++ ";\n}"
164compileJS (JSTernary cond true false) =
165 let c = compileJS cond
166 t = compileJS true
167 f = compileJS false in
168 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
170jsTailcall :: JS -> JS
171jsTailcall call =
172 jsCall (idrRTNamespace ++ "tailcall") [
173 JSFunction [] (JSReturn call)
174 ]
176jsCall :: String -> [JS] -> JS
177jsCall fun = JSApp (JSRaw fun)
179jsMeth :: JS -> String -> [JS] -> JS
180jsMeth obj meth =
181 JSApp (JSProj obj meth)
183jsInstanceOf :: JS -> JS -> JS
184jsInstanceOf = JSOp "instanceof"
186jsEq :: JS -> JS -> JS
187jsEq = JSOp "=="
189jsAnd :: JS -> JS -> JS
190jsAnd = JSOp "&&"
192jsType :: JS
193jsType = JSRaw $ idrRTNamespace ++ "Type"
195jsCon :: JS
196jsCon = JSRaw $ idrRTNamespace ++ "Con"
198jsTag :: JS -> JS
199jsTag obj = JSProj obj "tag"
201jsTypeTag :: JS -> JS
202jsTypeTag obj = JSProj obj "type"
204jsBigInt :: JS -> JS
205jsBigInt val =
206 JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]
208jsVar :: Int -> String
209jsVar = ("__var_" ++) . show
211jsLet :: String -> JS -> JS -> JS
212jsLet name value body =
213 JSApp (
214 JSFunction [name] (
215 JSReturn body
216 )
217 ) [value]
219jsSubst :: String -> [JS] -> JS -> [JS]
220jsSubst _ [] _ = []
221jsSubst var (x@(JSVar old) : xs) new
222 | var == translateVariableName old = new : xs
223 | otherwise = x : jsSubst var xs new
224jsSubst _ xs _ = xs
226optimizeJS :: JS -> JS
227optimizeJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
228 | JSNew con [tag, JSArray vals] <- ret =
229 JSNew con [tag, JSArray $ jsSubst arg vals (optimizeJS val)]
231 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret =
232 JSNew con [JSFunction [] (
233 JSReturn $ JSApp fun (jsSubst arg vars (optimizeJS val))
234 )]
236 | JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
237 JSReturn (JSApp fun args)
238 )] <- ret =
239 JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
240 JSReturn $ JSApp fun (jsSubst arg args (optimizeJS val))
241 )]
243 | JSOp op lhs rhs <- ret =
244 JSOp op (head $ jsSubst arg [lhs] (optimizeJS val)) $
245 (head $ jsSubst arg [rhs] (optimizeJS val))
247optimizeJS (JSSeq seq) =
248 JSSeq (map optimizeJS seq)
250optimizeJS (JSFunction args body) =
251 JSFunction args (optimizeJS body)
253optimizeJS (JSApp fun args) =
254 JSApp (optimizeJS fun) (map optimizeJS args)
256optimizeJS (JSReturn js) =
257 JSReturn $ optimizeJS js
259optimizeJS (JSAlloc name (Just js)) =
260 JSAlloc name (Just $ optimizeJS js)
262optimizeJS js = js
264optJS :: Int -> JS -> JS
265optJS c = foldr (.) id $ take c $ repeat optimizeJS
267codegenJavaScript
268 :: JSTarget
269 -> [(Name, SDecl)]
270 -> FilePath
271 -> OutputType
272 -> IO ()
273codegenJavaScript target definitions filename outputType = do
274 let (header, runtime) = case target of
275 Node ->
276 ("#!/usr/bin/env node\n", "-node")
277 JavaScript ->
278 ("", "-browser")
279 path <- getDataDir
280 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
281 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
282 writeFile filename $ header ++ (
283 intercalate "\n" $ [ idrRuntime
284 , tgtRuntime
285 ] ++ functions ++ [mainLoop, invokeLoop]
286 )
288 setPermissions filename (emptyPermissions { readable = True
289 , executable = target == Node
290 , writable = True
291 })
292 where
293 def :: [(String, SDecl)]
294 def = map (first translateNamespace) definitions
296 functions :: [String]
297 functions = map (compileJS . optJS 1 . translateDeclaration) def
299 mainLoop :: String
300 mainLoop = compileJS $
301 JSAlloc "main" $ Just $ JSFunction [] (
302 case target of
303 Node -> mainFun
304 JavaScript -> jsMeth (JSRaw "window") "addEventListener" [
305 JSString "DOMContentLoaded", JSFunction [] (
306 mainFun
307 ), JSFalse
308 ]
309 )
310 where
311 mainFun :: JS
312 mainFun = jsTailcall $ jsCall runMain []
314 runMain :: String
315 runMain = idrNamespace ++ translateName (MN 0 "runMain")
317 invokeLoop :: String
318 invokeLoop = compileJS $ jsCall "main" []
320translateIdentifier :: String -> String
321translateIdentifier =
322 replaceReserved . concatMap replaceBadChars
323 where replaceBadChars :: Char -> String
324 replaceBadChars c
325 | ' ' <- c = "_"
326 | '_' <- c = "__"
327 | isDigit c = '_' : show (ord c)
328 | not (isLetter c && isAscii c) = '_' : show (ord c)
329 | otherwise = [c]
330 replaceReserved s
331 | s `elem` reserved = '_' : s
332 | otherwise = s
333 reserved = [ "break"
334 , "case"
335 , "catch"
336 , "continue"
337 , "debugger"
338 , "default"
339 , "delete"
340 , "do"
341 , "else"
342 , "finally"
343 , "for"
344 , "function"
345 , "if"
346 , "in"
347 , "instanceof"
348 , "new"
349 , "return"
350 , "switch"
351 , "this"
352 , "throw"
353 , "try"
354 , "typeof"
355 , "var"
356 , "void"
357 , "while"
358 , "with"
360 , "class"
361 , "enum"
362 , "export"
363 , "extends"
364 , "import"
365 , "super"
367 , "implements"
368 , "interface"
369 , "let"
370 , "package"
371 , "private"
372 , "protected"
373 , "public"
374 , "static"
375 , "yield"
376 ]
378translateNamespace :: Name -> String
379translateNamespace (UN _) = idrNamespace
380translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
381translateNamespace (MN _ _) = idrNamespace
382translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
383translateNamespace NErased = idrNamespace
385translateName :: Name -> String
386translateName (UN name) = 'u' : translateIdentifier name
387translateName (NS name _) = 'n' : translateName name
388translateName (MN i name) = 'm' : translateIdentifier name ++ show i
389translateName (SN name) = 's' : translateSpecialName name
390translateName NErased = "e"
392translateSpecialName :: SpecialName -> String
393translateSpecialName name
394 | WhereN i m n <- name =
395 'w' : translateName m ++ translateName n ++ show i
396 | InstanceN n s <- name =
397 'i' : translateName n ++ concatMap translateIdentifier s
398 | ParentN n s <- name =
399 'p' : translateName n ++ translateIdentifier s
400 | MethodN n <- name =
401 'm' : translateName n
402 | CaseN n <- name =
403 'c' : translateName n
405translateConstant :: Const -> JS
406translateConstant (I i) = JSNum (JSInt i)
407translateConstant (Fl f) = JSNum (JSFloat f)
408translateConstant (Ch c) = JSString [c]
409translateConstant (Str s) = JSString s
410translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
411translateConstant StrType = JSType JSStringTy
412translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
413translateConstant (AType ATFloat) = JSType JSFloatTy
414translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
415translateConstant PtrType = JSType JSPtrTy
416translateConstant Forgot = JSType JSForgotTy
417translateConstant (BI i) = jsBigInt $ JSNum (JSInteger i)
418translateConstant c =
419 JSError $ "Unimplemented Constant: " ++ show c
421translateDeclaration :: (String, SDecl) -> JS
422translateDeclaration (path, SFun name params stackSize body)
423 | (MN _ "APPLY") <- name
424 , (SLet var val next) <- body
425 , (SChkCase cvar cases) <- next =
426 let lvar = translateVariableName var
427 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
428 JSSeq [ lookupTable [(var, "chk")] var cases
429 , jsDecl $ JSFunction ["fn0", "arg0"] (
430 JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
431 , JSReturn $ jsLet (translateVariableName var) (
432 translateExpression val
433 ) (JSTernary (
434 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
435 (hasProp lookupTableName (translateVariableName var))
436 ) (JSRaw $
437 lookupTableName ++ lookup
438 ) JSNull
439 )
440 ]
441 )
442 ]
444 | (MN _ "EVAL") <- name
445 , (SChkCase var cases) <- body =
446 JSSeq [ lookupTable [] var cases
447 , jsDecl $ JSFunction ["arg0"] (JSReturn $
448 JSTernary (
449 (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
450 (hasProp lookupTableName "arg0")
451 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
452 )
453 ]
454 | otherwise =
455 let fun = translateExpression body in
456 jsDecl $ jsFun fun
458 where
459 hasProp :: String -> String -> JS
460 hasProp table var =
461 jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]
463 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
464 caseFun aux var cse =
465 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
467 getTag :: SAlt -> Maybe String
468 getTag (SConCase _ tag _ _ _) = Just $ show tag
469 getTag _ = Nothing
471 lookupTableName :: String
472 lookupTableName = idrLTNamespace ++ translateName name
474 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
475 lookupTable aux var cases =
476 JSAlloc lookupTableName $ Just (
477 JSObject $ catMaybes $ map (lookupEntry aux var) cases
478 )
479 where
480 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)
481 lookupEntry aux var alt = do
482 tag <- getTag alt
483 return (tag, caseFun aux var alt)
485 jsDecl :: JS -> JS
486 jsDecl = JSAlloc (path ++ translateName name) . Just
488 jsFun body = jsFunAux [] body
490 jsFunAux :: [(LVar, String)] -> JS -> JS
491 jsFunAux aux body =
492 JSFunction (p ++ map snd aux) (
493 JSSeq $
494 zipWith assignVar [0..] p ++
495 map allocVar [numP .. (numP + stackSize - 1)] ++
496 map assignAux aux ++
497 [JSReturn body]
498 )
499 where
500 numP :: Int
501 numP = length params
503 allocVar :: Int -> JS
504 allocVar n = JSAlloc (jsVar n) Nothing
506 assignVar :: Int -> String -> JS
507 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
509 assignAux :: (LVar, String) -> JS
510 assignAux (var, val) =
511 JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
513 p :: [String]
514 p = map translateName params
516translateVariableName :: LVar -> String
517translateVariableName (Loc i) =
518 jsVar i
520translateExpression :: SExp -> JS
521translateExpression (SLet name value body) =
522 jsLet (translateVariableName name) (
523 translateExpression value
524 ) (translateExpression body)
526translateExpression (SConst cst) =
527 translateConstant cst
529translateExpression (SV var) =
530 JSVar var
532translateExpression (SApp tc name vars)
533 | False <- tc =
534 jsTailcall $ translateFunctionCall name vars
535 | True <- tc =
536 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
537 JSReturn $ translateFunctionCall name vars
538 )]
539 where
540 translateFunctionCall name vars =
541 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
543translateExpression (SOp op vars)
544 | LNoOp <- op = JSVar (last vars)
546 | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
547 | (LPlus (ATInt ITBig)) <- op
548 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
549 | (LMinus (ATInt ITBig)) <- op
550 , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
551 | (LTimes (ATInt ITBig)) <- op
552 , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
553 | (LSDiv (ATInt ITBig)) <- op
554 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
555 | (LSRem (ATInt ITBig)) <- op
556 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
557 | (LEq (ATInt ITBig)) <- op
558 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
559 | (LSLt (ATInt ITBig)) <- op
560 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
561 | (LSLe (ATInt ITBig)) <- op
562 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
563 | (LSGt (ATInt ITBig)) <- op
564 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
565 | (LSGe (ATInt ITBig)) <- op
566 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
568 | (LPlus ATFloat) <- op
569 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
570 | (LMinus ATFloat) <- op
571 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
572 | (LTimes ATFloat) <- op
573 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
574 | (LSDiv ATFloat) <- op
575 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
576 | (LEq ATFloat) <- op
577 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
578 | (LSLt ATFloat) <- op
579 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
580 | (LSLe ATFloat) <- op
581 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
582 | (LSGt ATFloat) <- op
583 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
584 | (LSGe ATFloat) <- op
585 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
587 | (LPlus _) <- op
588 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
589 | (LMinus _) <- op
590 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
591 | (LTimes _) <- op
592 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
593 | (LSDiv _) <- op
594 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
595 | (LSRem _) <- op
596 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
597 | (LEq _) <- op
598 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
599 | (LSLt _) <- op
600 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
601 | (LSLe _) <- op
602 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
603 | (LSGt _) <- op
604 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
605 | (LSGe _) <- op
606 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
607 | (LAnd _) <- op
608 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
609 | (LOr _) <- op
610 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
611 | (LXOr _) <- op
612 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
613 | (LSHL _) <- op
614 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
615 | (LASHR _) <- op
616 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
617 | (LCompl _) <- op
618 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
620 | LStrConcat <- op
621 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
622 | LStrEq <- op
623 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
624 | LStrLt <- op
625 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
626 | LStrLen <- op
627 , (arg:_) <- vars = JSProj (JSVar arg) "length"
629 | (LStrInt ITNative) <- op
630 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
631 | (LIntStr ITNative) <- op
632 , (arg:_) <- vars = jsCall "String" [JSVar arg]
633 | (LSExt ITNative ITBig) <- op
634 , (arg:_) <- vars = jsBigInt $ JSVar arg
635 | (LTrunc ITBig ITNative) <- op
636 , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
637 | (LIntStr ITBig) <- op
638 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
639 | (LStrInt ITBig) <- op
640 , (arg:_) <- vars = jsBigInt $ JSVar arg
641 | LFloatStr <- op
642 , (arg:_) <- vars = jsCall "String" [JSVar arg]
643 | LStrFloat <- op
644 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
645 | (LIntFloat ITNative) <- op
646 , (arg:_) <- vars = JSVar arg
647 | (LFloatInt ITNative) <- op
648 , (arg:_) <- vars = JSVar arg
649 | (LChInt ITNative) <- op
650 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
651 | (LIntCh ITNative) <- op
652 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
654 | LFExp <- op
655 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
656 | LFLog <- op
657 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
658 | LFSin <- op
659 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
660 | LFCos <- op
661 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
662 | LFTan <- op
663 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
664 | LFASin <- op
665 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
666 | LFACos <- op
667 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
668 | LFATan <- op
669 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
670 | LFSqrt <- op
671 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
672 | LFFloor <- op
673 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
674 | LFCeil <- op
675 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
677 | LStrCons <- op
678 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
679 | LStrHead <- op
680 , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
681 | LStrRev <- op
682 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
683 | LStrIndex <- op
684 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
685 | LStrTail <- op
686 , (arg:_) <- vars = let v = translateVariableName arg in
687 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
688 where
689 translateBinaryOp :: String -> LVar -> LVar -> JS
690 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
692 invokeMeth :: LVar -> String -> [LVar] -> JS
693 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
695translateExpression (SError msg) =
696 JSError msg
698translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
699 jsCall (idrRTNamespace ++ "print") [JSVar var]
701translateExpression (SForeign _ _ fun args) =
702 ffi fun (map generateWrapper args)
703 where
704 generateWrapper (ffunc, name)
705 | FFunction <- ffunc =
706 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
707 | FFunctionIO <- ffunc =
708 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
710 generateWrapper (_, name) =
711 translateVariableName name
713translateExpression patterncase
714 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
715 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
716 where
717 caseHelper var cases param =
718 JSApp (JSFunction [param] (
719 JSCond $ map (expandCase param . translateCaseCond param) cases
720 )) [JSVar var]
722 expandCase :: String -> (Cond, JS) -> (JS, JS)
723 expandCase _ (RawCond cond, branch) = (cond, branch)
724 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
725 expandCase var (CaseCond caseTy, branch)
726 | ConCase tag <- caseTy =
727 let checkCon = JSRaw var `jsInstanceOf` jsCon
728 checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
729 (checkCon `jsAnd` checkTag, branch)
731 | TypeCase ty <- caseTy =
732 let checkTy = JSRaw var `jsInstanceOf` jsType
733 checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in
734 (checkTy `jsAnd` checkTag, branch)
736translateExpression (SCon i name vars) =
737 JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
738 , JSArray $ map JSVar vars
739 ]
741translateExpression (SUpdate var e) =
742 JSAssign (JSVar var) (translateExpression e)
744translateExpression (SProj var i) =
745 JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
747translateExpression SNothing = JSNull
749translateExpression e =
750 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
752data FFI = FFICode Char | FFIArg Int | FFIError String
754ffi :: String -> [String] -> JS
755ffi code args = let parsed = ffiParse code in
756 case ffiError parsed of
757 Just err -> JSError err
758 Nothing -> JSRaw $ renderFFI parsed args
759 where
760 ffiParse :: String -> [FFI]
761 ffiParse "" = []
762 ffiParse ['%'] = [FFIError "Invalid positional argument"]
763 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
764 ffiParse ('%':s:ss)
765 | isDigit s =
766 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
767 | otherwise =
768 [FFIError "Invalid positional argument"]
769 ffiParse (s:ss) = FFICode s : ffiParse ss
771 ffiError :: [FFI] -> Maybe String
772 ffiError [] = Nothing
773 ffiError ((FFIError s):xs) = Just s
774 ffiError (x:xs) = ffiError xs
776 renderFFI :: [FFI] -> [String] -> String
777 renderFFI [] _ = ""
778 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
779 renderFFI ((FFIArg i) : fs) args
780 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
781 | otherwise = "Argument index out of bounds"
783data CaseType = ConCase Int
784 | TypeCase JSType
785 | DefaultCase
786 deriving Eq
788data Cond = CaseCond CaseType
789 | RawCond JS
791translateCaseCond :: String -> SAlt -> (Cond, JS)
792translateCaseCond _ cse@(SDefaultCase _) =
793 (CaseCond DefaultCase, translateCase Nothing cse)
795translateCaseCond var cse@(SConstCase ty _)
796 | StrType <- ty = matchHelper JSStringTy
797 | PtrType <- ty = matchHelper JSPtrTy
798 | Forgot <- ty = matchHelper JSForgotTy
799 | (AType ATFloat) <- ty = matchHelper JSFloatTy
800 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
801 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
802 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
803 where
804 matchHelper :: JSType -> (Cond, JS)
805 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
807translateCaseCond var cse@(SConstCase cst@(BI _) _) =
808 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
809 (RawCond cond, translateCase Nothing cse)
811translateCaseCond var cse@(SConstCase cst _) =
812 let cond = JSRaw var `jsEq` translateConstant cst in
813 (RawCond cond, translateCase Nothing cse)
815translateCaseCond var cse@(SConCase _ tag _ _ _) =
816 (CaseCond $ ConCase tag, translateCase (Just var) cse)
818translateCase :: Maybe String -> SAlt -> JS
819translateCase _ (SDefaultCase e) = translateExpression e
820translateCase _ (SConstCase _ e) = translateExpression e
821translateCase (Just var) (SConCase a _ _ vars e) =
822 let params = map jsVar [a .. (a + length vars)] in
823 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
824 JSThis, JSProj (JSRaw var) "vars"
825 ]