git.iko.soy/Idris-dev
on 5242001 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
524 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__"
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 ++ modules
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 ]
63 modules =
64 concatMap allocMod mods
65 where
66 allocMod m = intercalate "." m ++ " = {};\n"
67 sortMods a b = compare (length a) (length b)
69 mods =
70 drop 1 $ sortBy sortMods $ nub $ concatMap (inits . fst) def
72translateIdentifier :: String -> String
73translateIdentifier =
74 replaceReserved . concatMap replaceBadChars
75 where replaceBadChars :: Char -> String
76 replaceBadChars c
77 | ' ' <- c = "_"
78 | '_' <- c = "__"
79 | isDigit c = "_" ++ [c] ++ "_"
80 | not (isLetter c && isAscii c) = '_' : show (ord c)
81 | otherwise = [c]
82 replaceReserved s
83 | s `elem` reserved = '_' : s
84 | otherwise = s
85 reserved = [ "break"
86 , "case"
87 , "catch"
88 , "continue"
89 , "debugger"
90 , "default"
91 , "delete"
92 , "do"
93 , "else"
94 , "finally"
95 , "for"
96 , "function"
97 , "if"
98 , "in"
99 , "instanceof"
100 , "new"
101 , "return"
102 , "switch"
103 , "this"
104 , "throw"
105 , "try"
106 , "typeof"
107 , "var"
108 , "void"
109 , "while"
110 , "with"
112 , "class"
113 , "enum"
114 , "export"
115 , "extends"
116 , "import"
117 , "super"
119 , "implements"
120 , "interface"
121 , "let"
122 , "package"
123 , "private"
124 , "protected"
125 , "public"
126 , "static"
127 , "yield"
128 ]
130translateNamespace :: Name -> [String]
131translateNamespace (UN _) = [idrNamespace]
132translateNamespace (NS _ ns) = idrNamespace : map translateIdentifier ns
133translateNamespace (MN _ _) = [idrNamespace]
135translateName :: Name -> String
136translateName (UN name) = translateIdentifier name
137translateName (NS name _) = translateName name
138translateName (MN i name) = translateIdentifier name ++ show i
140translateConstant :: Const -> String
141translateConstant (I i) = show i
142translateConstant (BI i) = "__IDRRT__.bigInt('" ++ show i ++ "')"
143translateConstant (Fl f) = show f
144translateConstant (Ch c) = show c
145translateConstant (Str s) = show s
146translateConstant (AType (ATInt ITNative)) = "__IDRRT__.Int"
147translateConstant StrType = "__IDRRT__.String"
148translateConstant (AType (ATInt ITBig)) = "__IDRRT__.Integer"
149translateConstant (AType ATFloat) = "__IDRRT__.Float"
150translateConstant PtrType = "__IDRRT__.Ptr"
151translateConstant Forgot = "__IDRRT__.Forgot"
152translateConstant c =
153 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
155translateParameterlist =
156 map translateParameter
157 where translateParameter (MN i name) = translateIdentifier name ++ show i
158 translateParameter (UN name) = translateIdentifier name
160translateDeclaration :: ([String], SDecl) -> String
161translateDeclaration (path, SFun name params stackSize body) =
162 intercalate "." (path ++ [translateName name])
163 ++ " = function("
164 ++ intercalate "," p
165 ++ "){\n"
166 ++ concatMap assignVar (zip [0..] p)
167 ++ concatMap allocVar [numP..(numP+stackSize-1)]
168 ++ "return "
169 ++ translateExpression body
170 ++ ";\n};\n"
171 where
172 numP :: Int
173 numP = length params
175 allocVar :: Int -> String
176 allocVar n = "var __var_" ++ show n ++ ";\n"
178 assignVar :: (Int, String) -> String
179 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
181 p :: [String]
182 p = translateParameterlist params
184translateVariableName :: LVar -> String
185translateVariableName (Loc i) =
186 "__var_" ++ show i
188translateExpression :: SExp -> String
189translateExpression (SLet name value body) =
190 "(function("
191 ++ translateVariableName name
192 ++ "){\nreturn "
193 ++ translateExpression body
194 ++ ";\n})("
195 ++ translateExpression value
196 ++ ")"
198translateExpression (SConst cst) =
199 translateConstant cst
201translateExpression (SV var) =
202 translateVariableName var
204translateExpression (SApp False name vars) =
205 createTailcall $ translateFunctionCall name vars
207translateExpression (SApp True name vars) =
208 "new __IDRRT__.Tailcall("
209 ++ "function(){\n"
210 ++ "return " ++ translateFunctionCall name vars
211 ++ ";\n})"
213translateExpression (SOp op vars)
214 | (LPlus _) <- op
215 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
216 | (LMinus _) <- op
217 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
218 | (LTimes _) <- op
219 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
220 | (LSDiv _) <- op
221 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
222 | (LSRem _) <- op
223 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
224 | (LEq _) <- op
225 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
226 | (LLt _) <- op
227 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
228 | (LLe _) <- op
229 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
230 | (LGt _) <- op
231 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
232 | (LGe _) <- op
233 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
234 | (LAnd _) <- op
235 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
236 | (LOr _) <- op
237 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
238 | (LXOr _) <- op
239 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
240 | (LSHL _) <- op
241 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
242 | (LASHR _) <- op
243 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
244 | (LCompl _) <- op
245 , (arg:_) <- vars = '~' : translateVariableName arg
247 | (LPlus (ATInt ITBig)) <- op
248 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
249 | (LMinus (ATInt ITBig)) <- op
250 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
251 | (LTimes (ATInt ITBig)) <- op
252 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
253 | (LSDiv (ATInt ITBig)) <- op
254 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
255 | (LSRem (ATInt ITBig)) <- op
256 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
257 | (LEq (ATInt ITBig)) <- op
258 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
259 | (LLt (ATInt ITBig)) <- op
260 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
261 | (LLe (ATInt ITBig)) <- op
262 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
263 | (LGt (ATInt ITBig)) <- op
264 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
265 | (LGe (ATInt ITBig)) <- op
266 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
268 | (LPlus ATFloat) <- op
269 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
270 | (LMinus ATFloat) <- op
271 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
272 | (LTimes ATFloat) <- op
273 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
274 | (LSDiv ATFloat) <- op
275 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
276 | (LEq ATFloat) <- op
277 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
278 | (LLt ATFloat) <- op
279 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
280 | (LLe ATFloat) <- op
281 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
282 | (LGt ATFloat) <- op
283 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
284 | (LGe ATFloat) <- op
285 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
287 | LStrConcat <- op
288 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
289 | LStrEq <- op
290 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
291 | LStrLt <- op
292 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
293 | LStrLen <- op
294 , (arg:_) <- vars = translateVariableName arg ++ ".length"
296 | (LStrInt ITNative) <- op
297 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
298 | (LIntStr ITNative) <- op
299 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
300 | (LSExt ITNative ITBig) <- op
301 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
302 | (LTrunc ITBig ITNative) <- op
303 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
304 | (LIntStr ITBig) <- op
305 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
306 | (LStrInt ITBig) <- op
307 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
308 | LFloatStr <- op
309 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
310 | LStrFloat <- op
311 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
312 | (LIntFloat ITNative) <- op
313 , (arg:_) <- vars = translateVariableName arg
314 | (LFloatInt ITNative) <- op
315 , (arg:_) <- vars = translateVariableName arg
316 | (LChInt ITNative) <- op
317 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
318 | (LIntCh ITNative) <- op
319 , (arg:_) <- vars =
320 "String.fromCharCode(" ++ translateVariableName arg ++ ")"
322 | LFExp <- op
323 , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
324 | LFLog <- op
325 , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
326 | LFSin <- op
327 , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
328 | LFCos <- op
329 , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
330 | LFTan <- op
331 , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
332 | LFASin <- op
333 , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
334 | LFACos <- op
335 , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
336 | LFATan <- op
337 , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
338 | LFSqrt <- op
339 , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
340 | LFFloor <- op
341 , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
342 | LFCeil <- op
343 , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
345 | LStrCons <- op
346 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
347 | LStrHead <- op
348 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
349 | LStrRev <- op
350 , (arg:_) <- vars = let v = translateVariableName arg in
351 v ++ ".split('').reverse().join('')"
352 | LStrIndex <- op
353 , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
354 r = translateVariableName rhs in
355 l ++ "[" ++ r ++ "]"
356 | LStrTail <- op
357 , (arg:_) <- vars = let v = translateVariableName arg in
358 v ++ ".substr(1," ++ v ++ ".length-1)"
359 where
360 translateBinaryOp :: String -> LVar -> LVar -> String
361 translateBinaryOp f lhs rhs =
362 translateVariableName lhs
363 ++ f
364 ++ translateVariableName rhs
366translateExpression (SError msg) =
367 "(function(){throw \'" ++ msg ++ "\';})()"
369translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
370 "__IDRRT__.print(" ++ translateVariableName var ++ ")"
372translateExpression (SForeign _ _ fun args)
373 | "[]=" `isSuffixOf` fun
374 , (obj:idx:val:[]) <- args =
375 concat [object obj, index idx, assign val]
377 | "[]" `isSuffixOf` fun
378 , (obj:idx:[]) <- args =
379 object obj ++ index idx
381 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
382 , (obj:val:[]) <- args =
383 concat [object obj, '[' : name ++ "]", assign val]
385 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
386 , (obj:[]) <- args =
387 object obj ++ '[' : name ++ "]"
389 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
390 , (obj:val:[]) <- args =
391 concat [object obj, field, assign val]
393 | "." `isPrefixOf` fun
394 , (obj:[]) <- args =
395 object obj ++ field
397 | "." `isPrefixOf` fun
398 , (obj:[(FUnit, _)]) <- args =
399 concat [object obj, method, "()"]
401 | "." `isPrefixOf` fun
402 , (obj:as) <- args =
403 concat [object obj, method, arguments as]
405 | "[]=" `isSuffixOf` fun
406 , (idx:val:[]) <- args =
407 concat [array, index idx, assign val]
409 | "[]" `isSuffixOf` fun
410 , (idx:[]) <- args =
411 array ++ index idx
413 | otherwise = fun ++ arguments args
414 where
415 name = filter (`notElem` "[]=") fun
416 method = name
417 field = name
418 array = name
419 object o = translateVariableName (snd o)
420 index i = "[" ++ translateVariableName (snd i) ++ "]"
421 assign v = '=' : generateWrapper v
422 arguments as =
423 '(' : intercalate "," (map generateWrapper as) ++ ")"
425 generateWrapper (ffunc, name)
426 | FFunction <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"
427 | FFunctionIO <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"
429 generateWrapper (_, name) =
430 translateVariableName name
432translateExpression (SChkCase var cases) =
433 "(function(e){\n"
434 ++ intercalate " else " (map (translateCase "e") cases)
435 ++ "\n})("
436 ++ translateVariableName var
437 ++ ")"
439translateExpression (SCase var cases) =
440 "(function(e){\n"
441 ++ intercalate " else " (map (translateCase "e") cases)
442 ++ "\n})("
443 ++ translateVariableName var
444 ++ ")"
446translateExpression (SCon i name vars) =
447 concat [ "new __IDRRT__.Con("
448 , show i
449 , ",["
450 , intercalate "," $ map translateVariableName vars
451 , "])"
452 ]
454translateExpression (SUpdate var e) =
455 translateVariableName var ++ " = " ++ translateExpression e
457translateExpression (SProj var i) =
458 translateVariableName var ++ ".vars[" ++ show i ++"]"
460translateExpression SNothing = "null"
462translateExpression e =
463 "(function(){throw 'Not yet implemented: "
464 ++ filter (/= '\'') (show e)
465 ++ "';})()"
467translateCase :: String -> SAlt -> String
468translateCase _ (SDefaultCase e) =
469 createIfBlock "true" (translateExpression e)
471translateCase var (SConstCase ty e)
472 | StrType <- ty = matchHelper "String"
473 | PtrType <- ty = matchHelper "Ptr"
474 | Forgot <- ty = matchHelper "Forgot"
475 | (AType ATFloat) <- ty = matchHelper "Float"
476 | (AType (ATInt ITBig)) <- ty = matchHelper "Integer"
477 | (AType (ATInt ITNative)) <- ty = matchHelper "Int"
478 | (AType (ATInt ITChar)) <- ty = matchHelper "Char"
479 where
480 matchHelper tyName = translateTypeMatch var tyName e
482translateCase var (SConstCase cst@(BI _) e) =
483 let cond = "__IDRRT__.bigInt(" ++ var ++ ").equals(" ++ translateConstant cst ++ ")" in
484 createIfBlock cond (translateExpression e)
486translateCase var (SConstCase cst e) =
487 let cond = var ++ " == " ++ translateConstant cst in
488 createIfBlock cond (translateExpression e)
490translateCase var (SConCase a i name vars e) =
491 let isCon = var ++ " instanceof __IDRRT__.Con"
492 isI = show i ++ " == " ++ var ++ ".i"
493 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
494 args = ".apply(this," ++ var ++ ".vars)"
495 f b =
496 "(function("
497 ++ params
498 ++ "){\nreturn " ++ b ++ "\n})" ++ args
499 cond = intercalate " && " [isCon, isI] in
500 createIfBlock cond $ f (translateExpression e)
502translateTypeMatch :: String -> String -> SExp -> String
503translateTypeMatch var ty exp =
504 let e = translateExpression exp in
505 createIfBlock (var
506 ++ " instanceof __IDRRT__.Type && "
507 ++ var ++ ".type == '"++ ty ++"'") e
510createIfBlock cond e =
511 "if (" ++ cond ++") {\n"
512 ++ "return " ++ e
513 ++ ";\n}"
515createTailcall call =
516 "__IDRRT__.tailcall(function(){return " ++ call ++ "})"
518translateFunctionCall name vars =
519 concat (intersperse "." $ translateNamespace name)
520 ++ "."
521 ++ translateName name
522 ++ "("
523 ++ intercalate "," (map translateVariableName vars)
524 ++ ")"