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