git.iko.soy/Idris-dev
on fc79985 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
516 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
20idrNamespace :: String
21idrNamespace = "__IDR__"
23data JSTarget = Node | JavaScript
25codegenJavaScript
26 :: JSTarget
27 -> [(Name, SDecl)]
28 -> FilePath
29 -> OutputType
30 -> IO ()
31codegenJavaScript target definitions filename outputType = do
32 let runtime = case target of
33 Node -> "-node"
34 JavaScript -> "-browser"
35 path <- getDataDir
36 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
37 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
38 writeFile filename (idrRuntime
39 ++ tgtRuntime
40 ++ modules
41 ++ functions
42 ++ mainLoop)
43 where
44 def = map (first translateNamespace) definitions
46 functions = concatMap translateDeclaration def
48 mainLoop :: String
49 mainLoop = intercalate "\n" [ "\nfunction main() {"
50 , createTailcall "__IDR__.runMain0()"
51 , "}\n\nmain();\n"
52 ]
54 modules =
55 concatMap allocMod mods
56 where
57 allocMod m = intercalate "." m ++ " = {};\n"
58 sortMods a b = compare (length a) (length b)
60 mods =
61 drop 1 $ sortBy sortMods $ nub $ concatMap (inits . fst) def
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 : map 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) = "__IDRRT__.bigInt('" ++ show i ++ "')"
134translateConstant (Fl f) = show f
135translateConstant (Ch c) = show c
136translateConstant (Str s) = show s
137translateConstant IType = "__IDRRT__.Int"
138translateConstant ChType = "__IDRRT__.Char"
139translateConstant StrType = "__IDRRT__.String"
140translateConstant BIType = "__IDRRT__.Integer"
141translateConstant FlType = "__IDRRT__.Float"
142translateConstant PtrType = "__IDRRT__.Ptr"
143translateConstant Forgot = "__IDRRT__.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 intercalate "." (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 __IDRRT__.Tailcall("
201 ++ "function(){\n"
202 ++ "return " ++ translateFunctionCall name vars
203 ++ ";\n})"
205translateExpression (SOp op vars)
206 | (LPlus _) <- op
207 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
208 | (LMinus _) <- op
209 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
210 | (LTimes _) <- op
211 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
212 | (LSDiv _) <- op
213 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
214 | (LSRem _) <- op
215 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
216 | (LEq _) <- op
217 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
218 | (LLt _) <- op
219 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
220 | (LLe _) <- op
221 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
222 | (LGt _) <- op
223 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
224 | (LGe _) <- op
225 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
226 | (LAnd _) <- op
227 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
228 | (LOr _) <- op
229 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
230 | (LXOr _) <- op
231 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
232 | (LSHL _) <- op
233 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
234 | (LASHR _) <- op
235 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
236 | (LCompl _) <- op
237 , (arg:_) <- vars = '~' : translateVariableName arg
239 | (LPlus ITBig) <- op
240 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
241 | (LMinus ITBig) <- op
242 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
243 | (LTimes ITBig) <- op
244 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
245 | (LSDiv ITBig) <- op
246 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
247 | (LSRem ITBig) <- op
248 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
249 | (LEq ITBig) <- op
250 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
251 | (LLt ITBig) <- op
252 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
253 | (LLe ITBig) <- op
254 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
255 | (LGt ITBig) <- op
256 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
257 | (LGe ITBig) <- op
258 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
260 | LFPlus <- op
261 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
262 | LFMinus <- op
263 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
264 | LFTimes <- op
265 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
266 | LFDiv <- op
267 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
268 | LFEq <- op
269 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
270 | LFLt <- op
271 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
272 | LFLe <- op
273 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
274 | LFGt <- op
275 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
276 | LFGe <- op
277 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
279 | LStrConcat <- op
280 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
281 | LStrEq <- op
282 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
283 | LStrLt <- op
284 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
285 | LStrLen <- op
286 , (arg:_) <- vars = translateVariableName arg ++ ".length"
288 | (LStrInt ITNative) <- op
289 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
290 | (LIntStr ITNative) <- op
291 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
292 | (LSExt ITNative ITBig) <- op
293 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
294 | (LTrunc ITBig ITNative) <- op
295 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
296 | (LIntStr ITBig) <- op
297 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
298 | (LStrInt ITBig) <- op
299 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
300 | LFloatStr <- op
301 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
302 | LStrFloat <- op
303 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
304 | (LIntFloat ITNative) <- op
305 , (arg:_) <- vars = translateVariableName arg
306 | (LFloatInt ITNative) <- op
307 , (arg:_) <- vars = translateVariableName arg
308 | (LChInt ITNative) <- op
309 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
310 | (LIntCh ITNative) <- op
311 , (arg:_) <- vars =
312 "String.fromCharCode(" ++ translateVariableName arg ++ ")"
314 | LFExp <- op
315 , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
316 | LFLog <- op
317 , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
318 | LFSin <- op
319 , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
320 | LFCos <- op
321 , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
322 | LFTan <- op
323 , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
324 | LFASin <- op
325 , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
326 | LFACos <- op
327 , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
328 | LFATan <- op
329 , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
330 | LFSqrt <- op
331 , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
332 | LFFloor <- op
333 , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
334 | LFCeil <- op
335 , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
337 | LStrCons <- op
338 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
339 | LStrHead <- op
340 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
341 | LStrRev <- op
342 , (arg:_) <- vars = let v = translateVariableName arg in
343 v ++ "split('').reverse().join('')"
344 | LStrIndex <- op
345 , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
346 r = translateVariableName rhs in
347 l ++ "[" ++ r ++ "]"
348 | LStrTail <- op
349 , (arg:_) <- vars = let v = translateVariableName arg in
350 v ++ ".substr(1," ++ v ++ ".length-1)"
351 where
352 translateBinaryOp :: String -> LVar -> LVar -> String
353 translateBinaryOp f lhs rhs =
354 translateVariableName lhs
355 ++ f
356 ++ translateVariableName rhs
358translateExpression (SError msg) =
359 "(function(){throw \'" ++ msg ++ "\';})()"
361translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
362 "__IDRRT__.print(" ++ translateVariableName var ++ ")"
364translateExpression (SForeign _ _ fun args)
365 | "[]=" `isSuffixOf` fun
366 , (obj:idx:val:[]) <- args =
367 concat [object obj, index idx, assign val]
369 | "[]" `isSuffixOf` fun
370 , (obj:idx:[]) <- args =
371 object obj ++ index idx
373 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
374 , (obj:val:[]) <- args =
375 concat [object obj, '[' : name ++ "]", assign val]
377 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
378 , (obj:[]) <- args =
379 object obj ++ '[' : name ++ "]"
381 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
382 , (obj:val:[]) <- args =
383 concat [object obj, field, assign val]
385 | "." `isPrefixOf` fun
386 , (obj:[]) <- args =
387 object obj ++ field
389 | "." `isPrefixOf` fun
390 , (obj:[(FUnit, _)]) <- args =
391 concat [object obj, method, "()"]
393 | "." `isPrefixOf` fun
394 , (obj:as) <- args =
395 concat [object obj, method, arguments as]
397 | "[]=" `isSuffixOf` fun
398 , (idx:val:[]) <- args =
399 concat [array, index idx, assign val]
401 | "[]" `isSuffixOf` fun
402 , (idx:[]) <- args =
403 array ++ index idx
405 | otherwise = fun ++ arguments args
406 where
407 name = filter (`notElem` "[]=") fun
408 method = name
409 field = name
410 array = name
411 object o = translateVariableName (snd o)
412 index i = "[" ++ translateVariableName (snd i) ++ "]"
413 assign v = '=' : generateWrapper v
414 arguments as =
415 '(' : intercalate "," (map generateWrapper as) ++ ")"
417 generateWrapper (ffunc, name)
418 | FFunction <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"
419 | FFunctionIO <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"
421 generateWrapper (_, name) =
422 translateVariableName name
424translateExpression (SChkCase var cases) =
425 "(function(e){\n"
426 ++ intercalate " else " (map (translateCase "e") cases)
427 ++ "\n})("
428 ++ translateVariableName var
429 ++ ")"
431translateExpression (SCase var cases) =
432 "(function(e){\n"
433 ++ intercalate " else " (map (translateCase "e") cases)
434 ++ "\n})("
435 ++ translateVariableName var
436 ++ ")"
438translateExpression (SCon i name vars) =
439 concat [ "new __IDRRT__.Con("
440 , show i
441 , ",["
442 , intercalate "," $ map translateVariableName vars
443 , "])"
444 ]
446translateExpression (SUpdate var e) =
447 translateVariableName var ++ " = " ++ translateExpression e
449translateExpression (SProj var i) =
450 translateVariableName var ++ ".vars[" ++ show i ++"]"
452translateExpression SNothing = "null"
454translateExpression e =
455 "(function(){throw 'Not yet implemented: "
456 ++ filter (/= '\'') (show e)
457 ++ "';})()"
459translateCase :: String -> SAlt -> String
460translateCase _ (SDefaultCase e) =
461 createIfBlock "true" (translateExpression e)
463translateCase var (SConstCase ty e)
464 | ChType <- ty = matchHelper "Char"
465 | StrType <- ty = matchHelper "String"
466 | IType <- ty = matchHelper "Int"
467 | BIType <- ty = matchHelper "Integer"
468 | FlType <- ty = matchHelper "Float"
469 | PtrType <- ty = matchHelper "Ptr"
470 | Forgot <- ty = matchHelper "Forgot"
471 where
472 matchHelper tyName = translateTypeMatch var tyName e
474translateCase var (SConstCase cst@(BI _) e) =
475 let cond = var ++ ".equals(" ++ translateConstant cst ++ ")" in
476 createIfBlock cond (translateExpression e)
478translateCase var (SConstCase cst e) =
479 let cond = var ++ " == " ++ translateConstant cst in
480 createIfBlock cond (translateExpression e)
482translateCase var (SConCase a i name vars e) =
483 let isCon = var ++ " instanceof __IDRRT__.Con"
484 isI = show i ++ " == " ++ var ++ ".i"
485 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
486 args = ".apply(this," ++ var ++ ".vars)"
487 f b =
488 "(function("
489 ++ params
490 ++ "){\nreturn " ++ b ++ "\n})" ++ args
491 cond = intercalate " && " [isCon, isI] in
492 createIfBlock cond $ f (translateExpression e)
494translateTypeMatch :: String -> String -> SExp -> String
495translateTypeMatch var ty exp =
496 let e = translateExpression exp in
497 createIfBlock (var
498 ++ " instanceof __IDRRT__.Type && "
499 ++ var ++ ".type == '"++ ty ++"'") e
502createIfBlock cond e =
503 "if (" ++ cond ++") {\n"
504 ++ "return " ++ e
505 ++ ";\n}"
507createTailcall call =
508 "__IDRRT__.tailcall(function(){return " ++ call ++ "})"
510translateFunctionCall name vars =
511 concat (intersperse "." $ translateNamespace name)
512 ++ "."
513 ++ translateName name
514 ++ "("
515 ++ intercalate "," (map translateVariableName vars)
516 ++ ")"