git.iko.soy/Idris-dev
on 4dddfaf help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
520 lines 18 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where
5import Idris.AbsSyntax
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 qualified Data.Map as Map
18import System.IO
19import System.Directory
21idrNamespace :: String
22idrNamespace = "__IDR__"
23idrRTNamespace = "__IDRRT__"
25data JSTarget = Node | JavaScript deriving Eq
27codegenJavaScript
28 :: JSTarget
29 -> [(Name, SDecl)]
30 -> FilePath
31 -> OutputType
32 -> IO ()
33codegenJavaScript target definitions filename outputType = do
34 let (header, runtime) = case target of
35 Node ->
36 ("#!/usr/bin/env node\n", "-node")
37 JavaScript ->
38 ("", "-browser")
39 path <- getDataDir
40 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
41 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
42 writeFile filename ( header
43 ++ idrRuntime
44 ++ tgtRuntime
45 ++ functions
46 ++ mainLoop)
48 setPermissions filename (emptyPermissions { readable = True
49 , executable = target == Node
50 , writable = True
51 })
52 where
53 def = map (first translateNamespace) definitions
55 functions = concatMap translateDeclaration def
57 mainLoop :: String
58 mainLoop = intercalate "\n" [ "\nfunction main() {"
59 , createTailcall "__IDR__runMain0()"
60 , "}\n\nmain();\n"
61 ]
63translateIdentifier :: String -> String
64translateIdentifier =
65 replaceReserved . concatMap replaceBadChars
66 where replaceBadChars :: Char -> String
67 replaceBadChars c
68 | ' ' <- c = "_"
69 | '_' <- c = "__"
70 | isDigit c = "_" ++ [c] ++ "_"
71 | not (isLetter c && isAscii c) = '_' : show (ord c)
72 | otherwise = [c]
73 replaceReserved s
74 | s `elem` reserved = '_' : s
75 | otherwise = s
76 reserved = [ "break"
77 , "case"
78 , "catch"
79 , "continue"
80 , "debugger"
81 , "default"
82 , "delete"
83 , "do"
84 , "else"
85 , "finally"
86 , "for"
87 , "function"
88 , "if"
89 , "in"
90 , "instanceof"
91 , "new"
92 , "return"
93 , "switch"
94 , "this"
95 , "throw"
96 , "try"
97 , "typeof"
98 , "var"
99 , "void"
100 , "while"
101 , "with"
103 , "class"
104 , "enum"
105 , "export"
106 , "extends"
107 , "import"
108 , "super"
110 , "implements"
111 , "interface"
112 , "let"
113 , "package"
114 , "private"
115 , "protected"
116 , "public"
117 , "static"
118 , "yield"
119 ]
121translateNamespace :: Name -> String
122translateNamespace (UN _) = idrNamespace
123translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
124translateNamespace (MN _ _) = idrNamespace
126translateName :: Name -> String
127translateName (UN name) = translateIdentifier name
128translateName (NS name _) = translateName name
129translateName (MN i name) = translateIdentifier name ++ show i
131translateConstant :: Const -> String
132translateConstant (I i) = show i
133translateConstant (BI i) = idrRTNamespace ++ "bigInt('" ++ show i ++ "')"
134translateConstant (Fl f) = show f
135translateConstant (Ch c) = show c
136translateConstant (Str s) = show s
137translateConstant (AType (ATInt ITNative)) = idrRTNamespace ++ "Int"
138translateConstant StrType = idrRTNamespace ++ "String"
139translateConstant (AType (ATInt ITBig)) = idrRTNamespace ++ "Integer"
140translateConstant (AType ATFloat) = idrRTNamespace ++ "Float"
141translateConstant (AType (ATInt ITChar)) = idrRTNamespace ++ "Char"
142translateConstant PtrType = idrRTNamespace ++ "Ptr"
143translateConstant Forgot = idrRTNamespace ++ "Forgot"
144translateConstant c =
145 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
147translateParameterlist =
148 map translateParameter
149 where translateParameter (MN i name) = translateIdentifier name ++ show i
150 translateParameter (UN name) = translateIdentifier name
152translateDeclaration :: (String, SDecl) -> String
153translateDeclaration (path, SFun name params stackSize body) =
154 "var " ++ path ++ translateName name
155 ++ " = function("
156 ++ intercalate "," p
157 ++ "){\n"
158 ++ concatMap assignVar (zip [0..] p)
159 ++ concatMap allocVar [numP..(numP+stackSize-1)]
160 ++ "return "
161 ++ translateExpression body
162 ++ ";\n};\n"
163 where
164 numP :: Int
165 numP = length params
167 allocVar :: Int -> String
168 allocVar n = "var __var_" ++ show n ++ ";\n"
170 assignVar :: (Int, String) -> String
171 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
173 p :: [String]
174 p = translateParameterlist params
176translateVariableName :: LVar -> String
177translateVariableName (Loc i) =
178 "__var_" ++ show i
180translateExpression :: SExp -> String
181translateExpression (SLet name value body) =
182 "(function("
183 ++ translateVariableName name
184 ++ "){\nreturn "
185 ++ translateExpression body
186 ++ ";\n})("
187 ++ translateExpression value
188 ++ ")"
190translateExpression (SConst cst) =
191 translateConstant cst
193translateExpression (SV var) =
194 translateVariableName var
196translateExpression (SApp False name vars) =
197 createTailcall $ translateFunctionCall name vars
199translateExpression (SApp True name vars) =
200 "new " ++ idrRTNamespace ++ "Tailcall("
201 ++ "function(){\n"
202 ++ "return " ++ translateFunctionCall name vars
203 ++ ";\n})"
205translateExpression (SOp op vars)
206 | LNoOp <- op = translateVariableName (last vars)
208 | (LZExt _ ITBig) <- op =
209 idrRTNamespace ++ "bigInt(" ++ translateVariableName (last vars) ++ ")"
211 | (LPlus (ATInt ITBig)) <- op
212 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
213 | (LMinus (ATInt ITBig)) <- op
214 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
215 | (LTimes (ATInt ITBig)) <- op
216 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
217 | (LSDiv (ATInt ITBig)) <- op
218 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
219 | (LSRem (ATInt ITBig)) <- op
220 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
221 | (LEq (ATInt ITBig)) <- op
222 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
223 | (LLt (ATInt ITBig)) <- op
224 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
225 | (LLe (ATInt ITBig)) <- op
226 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
227 | (LGt (ATInt ITBig)) <- op
228 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
229 | (LGe (ATInt ITBig)) <- op
230 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
232 | (LPlus ATFloat) <- op
233 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
234 | (LMinus ATFloat) <- op
235 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
236 | (LTimes ATFloat) <- op
237 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
238 | (LSDiv ATFloat) <- op
239 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
240 | (LEq ATFloat) <- op
241 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
242 | (LLt ATFloat) <- op
243 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
244 | (LLe ATFloat) <- op
245 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
246 | (LGt ATFloat) <- op
247 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
248 | (LGe ATFloat) <- op
249 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
251 | (LPlus _) <- op
252 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
253 | (LMinus _) <- op
254 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
255 | (LTimes _) <- op
256 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
257 | (LSDiv _) <- op
258 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
259 | (LSRem _) <- op
260 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
261 | (LEq _) <- op
262 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
263 | (LLt _) <- op
264 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
265 | (LLe _) <- op
266 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
267 | (LGt _) <- op
268 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
269 | (LGe _) <- op
270 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
271 | (LAnd _) <- op
272 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
273 | (LOr _) <- op
274 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
275 | (LXOr _) <- op
276 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
277 | (LSHL _) <- op
278 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
279 | (LASHR _) <- op
280 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
281 | (LCompl _) <- op
282 , (arg:_) <- vars = '~' : translateVariableName arg
284 | LStrConcat <- op
285 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
286 | LStrEq <- op
287 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
288 | LStrLt <- op
289 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
290 | LStrLen <- op
291 , (arg:_) <- vars = translateVariableName arg ++ ".length"
293 | (LStrInt ITNative) <- op
294 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
295 | (LIntStr ITNative) <- op
296 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
297 | (LSExt ITNative ITBig) <- op
298 , (arg:_) <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")"
299 | (LTrunc ITBig ITNative) <- op
300 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
301 | (LIntStr ITBig) <- op
302 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
303 | (LStrInt ITBig) <- op
304 , (arg:_) <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")"
305 | LFloatStr <- op
306 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
307 | LStrFloat <- op
308 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
309 | (LIntFloat ITNative) <- op
310 , (arg:_) <- vars = translateVariableName arg
311 | (LFloatInt ITNative) <- op
312 , (arg:_) <- vars = translateVariableName arg
313 | (LChInt ITNative) <- op
314 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
315 | (LIntCh ITNative) <- op
316 , (arg:_) <- vars =
317 "String.fromCharCode(" ++ translateVariableName arg ++ ")"
319 | LFExp <- op
320 , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
321 | LFLog <- op
322 , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
323 | LFSin <- op
324 , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
325 | LFCos <- op
326 , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
327 | LFTan <- op
328 , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
329 | LFASin <- op
330 , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
331 | LFACos <- op
332 , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
333 | LFATan <- op
334 , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
335 | LFSqrt <- op
336 , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
337 | LFFloor <- op
338 , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
339 | LFCeil <- op
340 , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
342 | LStrCons <- op
343 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
344 | LStrHead <- op
345 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
346 | LStrRev <- op
347 , (arg:_) <- vars = let v = translateVariableName arg in
348 v ++ ".split('').reverse().join('')"
349 | LStrIndex <- op
350 , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
351 r = translateVariableName rhs in
352 l ++ "[" ++ r ++ "]"
353 | LStrTail <- op
354 , (arg:_) <- vars = let v = translateVariableName arg in
355 v ++ ".substr(1," ++ v ++ ".length-1)"
356 where
357 translateBinaryOp :: String -> LVar -> LVar -> String
358 translateBinaryOp f lhs rhs =
359 translateVariableName lhs
360 ++ f
361 ++ translateVariableName rhs
363translateExpression (SError msg) =
364 "(function(){throw \'" ++ msg ++ "\';})()"
366translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
367 idrRTNamespace ++ "print(" ++ translateVariableName var ++ ")"
369translateExpression (SForeign _ _ fun args)
370 | "[]=" `isSuffixOf` fun
371 , (obj:idx:val:[]) <- args =
372 concat [object obj, index idx, assign val]
374 | "[]" `isSuffixOf` fun
375 , (obj:idx:[]) <- args =
376 object obj ++ index idx
378 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
379 , (obj:val:[]) <- args =
380 concat [object obj, '[' : name ++ "]", assign val]
382 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
383 , (obj:[]) <- args =
384 object obj ++ '[' : name ++ "]"
386 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
387 , (obj:val:[]) <- args =
388 concat [object obj, field, assign val]
390 | "." `isPrefixOf` fun
391 , (obj:[]) <- args =
392 object obj ++ field
394 | "." `isPrefixOf` fun
395 , (obj:[(FUnit, _)]) <- args =
396 concat [object obj, method, "()"]
398 | "." `isPrefixOf` fun
399 , (obj:as) <- args =
400 concat [object obj, method, arguments as]
402 | "[]=" `isSuffixOf` fun
403 , (idx:val:[]) <- args =
404 concat [array, index idx, assign val]
406 | "[]" `isSuffixOf` fun
407 , (idx:[]) <- args =
408 array ++ index idx
410 | otherwise = fun ++ arguments args
411 where
412 name = filter (`notElem` "[]=") fun
413 method = name
414 field = name
415 array = name
416 object o = translateVariableName (snd o)
417 index i = "[" ++ translateVariableName (snd i) ++ "]"
418 assign v = '=' : generateWrapper v
419 arguments as =
420 '(' : intercalate "," (map generateWrapper as) ++ ")"
422 generateWrapper (ffunc, name)
423 | FFunction <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
424 | FFunctionIO <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
426 generateWrapper (_, name) =
427 translateVariableName name
429translateExpression (SChkCase var cases) =
430 "(function(e){\n"
431 ++ intercalate " else " (map (translateCase "e") cases)
432 ++ "\n})("
433 ++ translateVariableName var
434 ++ ")"
436translateExpression (SCase var cases) =
437 "(function(e){\n"
438 ++ intercalate " else " (map (translateCase "e") cases)
439 ++ "\n})("
440 ++ translateVariableName var
441 ++ ")"
443translateExpression (SCon i name vars) =
444 concat [ "new " ++ idrRTNamespace ++ "Con("
445 , show i
446 , ",["
447 , intercalate "," $ map translateVariableName vars
448 , "])"
449 ]
451translateExpression (SUpdate var e) =
452 translateVariableName var ++ " = " ++ translateExpression e
454translateExpression (SProj var i) =
455 translateVariableName var ++ ".vars[" ++ show i ++"]"
457translateExpression SNothing = "null"
459translateExpression e =
460 "(function(){throw 'Not yet implemented: "
461 ++ filter (/= '\'') (show e)
462 ++ "';})()"
464translateCase :: String -> SAlt -> String
465translateCase _ (SDefaultCase e) =
466 createIfBlock "true" (translateExpression e)
468translateCase var (SConstCase ty e)
469 | StrType <- ty = matchHelper "String"
470 | PtrType <- ty = matchHelper "Ptr"
471 | Forgot <- ty = matchHelper "Forgot"
472 | (AType ATFloat) <- ty = matchHelper "Float"
473 | (AType (ATInt ITBig)) <- ty = matchHelper "Integer"
474 | (AType (ATInt ITNative)) <- ty = matchHelper "Int"
475 | (AType (ATInt ITChar)) <- ty = matchHelper "Char"
476 where
477 matchHelper tyName = translateTypeMatch var tyName e
479translateCase var (SConstCase cst@(BI _) e) =
480 let cond = idrRTNamespace ++ "bigInt(" ++ var ++ ").equals(" ++ translateConstant cst ++ ")" in
481 createIfBlock cond (translateExpression e)
483translateCase var (SConstCase cst e) =
484 let cond = var ++ " == " ++ translateConstant cst in
485 createIfBlock cond (translateExpression e)
487translateCase var (SConCase a i name vars e) =
488 let isCon = var ++ " instanceof " ++ idrRTNamespace ++ "Con"
489 isI = show i ++ " == " ++ var ++ ".i"
490 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
491 args = ".apply(this," ++ var ++ ".vars)"
492 f b =
493 "(function("
494 ++ params
495 ++ "){\nreturn " ++ b ++ "\n})" ++ args
496 cond = intercalate " && " [isCon, isI] in
497 createIfBlock cond $ f (translateExpression e)
499translateTypeMatch :: String -> String -> SExp -> String
500translateTypeMatch var ty exp =
501 let e = translateExpression exp in
502 createIfBlock (var
503 ++ " instanceof " ++ idrRTNamespace ++ "Type && "
504 ++ var ++ ".type == '"++ ty ++"'") e
507createIfBlock cond e =
508 "if (" ++ cond ++") {\n"
509 ++ "return " ++ e
510 ++ ";\n}"
512createTailcall call =
513 idrRTNamespace ++ "tailcall(function(){return " ++ call ++ "})"
515translateFunctionCall name vars =
516 translateNamespace name
517 ++ translateName name
518 ++ "("
519 ++ intercalate "," (map translateVariableName vars)
520 ++ ")"