git.iko.soy/Idris-dev
on 228ffdb help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
500 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 Forgot = "__IDRRT__.Forgot"
143translateConstant c =
144 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
146translateParameterlist =
147 map translateParameter
148 where translateParameter (MN i name) = translateIdentifier name ++ show i
149 translateParameter (UN name) = translateIdentifier name
151translateDeclaration :: ([String], SDecl) -> String
152translateDeclaration (path, SFun name params stackSize body) =
153 intercalate "." (path ++ [translateName name])
154 ++ " = function("
155 ++ intercalate "," p
156 ++ "){\n"
157 ++ concatMap assignVar (zip [0..] p)
158 ++ concatMap allocVar [numP..(numP+stackSize-1)]
159 ++ "return "
160 ++ translateExpression body
161 ++ ";\n};\n"
162 where
163 numP :: Int
164 numP = length params
166 allocVar :: Int -> String
167 allocVar n = "var __var_" ++ show n ++ ";\n"
169 assignVar :: (Int, String) -> String
170 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
172 p :: [String]
173 p = translateParameterlist params
175translateVariableName :: LVar -> String
176translateVariableName (Loc i) =
177 "__var_" ++ show i
179translateExpression :: SExp -> String
180translateExpression (SLet name value body) =
181 "(function("
182 ++ translateVariableName name
183 ++ "){\nreturn "
184 ++ translateExpression body
185 ++ ";\n})("
186 ++ translateExpression value
187 ++ ")"
189translateExpression (SConst cst) =
190 translateConstant cst
192translateExpression (SV var) =
193 translateVariableName var
195translateExpression (SApp False name vars) =
196 createTailcall $ translateFunctionCall name vars
198translateExpression (SApp True name vars) =
199 "new __IDRRT__.Tailcall("
200 ++ "function(){\n"
201 ++ "return " ++ translateFunctionCall name vars
202 ++ ";\n});"
204translateExpression (SOp op vars)
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 | LDiv <- op
212 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
213 | LMod <- 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 | LSHR <- op
234 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
235 | LCompl <- op
236 , (arg:_) <- vars = '~' : translateVariableName arg
238 | LBPlus <- op
239 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
240 | LBMinus <- op
241 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
242 | LBTimes <- op
243 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
244 | LBDiv <- op
245 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
246 | LBMod <- op
247 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
248 | LBEq <- op
249 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
250 | LBLt <- op
251 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
252 | LBLe <- op
253 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
254 | LBGt <- op
255 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
256 | LBGe <- op
257 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
259 | LFPlus <- op
260 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
261 | LFMinus <- op
262 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
263 | LFTimes <- op
264 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
265 | LFDiv <- op
266 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
267 | LFEq <- op
268 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
269 | LFLt <- op
270 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
271 | LFLe <- op
272 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
273 | LFGt <- op
274 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
275 | LFGe <- 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 <- op
288 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
289 | LIntStr <- op
290 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
291 | LIntBig <- op
292 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
293 | LBigInt <- op
294 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
295 | LBigStr <- op
296 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
297 | LStrBig <- 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 <- op
304 , (arg:_) <- vars = translateVariableName arg
305 | LFloatInt <- op
306 , (arg:_) <- vars = translateVariableName arg
307 | LChInt <- op
308 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
309 | LIntCh <- 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 | "." `isPrefixOf` fun, "[]=" `isSuffixOf` fun
365 , (obj:idx:val:[]) <- args =
366 concat [object obj, field, index idx, assign val]
368 | "." `isPrefixOf` fun, "[]" `isSuffixOf` fun
369 , (obj:idx:[]) <- args =
370 concat [object obj, field, index idx]
372 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
373 , (obj:val:[]) <- args =
374 concat [object obj, field, assign val]
376 | "." `isPrefixOf` fun
377 , (obj:[]) <- args =
378 object obj ++ field
380 | "." `isPrefixOf` fun
381 , (obj:[(FUnit, _)]) <- args =
382 concat [object obj, method, "()"]
384 | "." `isPrefixOf` fun
385 , (obj:as) <- args =
386 concat [object obj, method, arguments as]
388 | "[]=" `isSuffixOf` fun
389 , (idx:val:[]) <- args =
390 concat [array, index idx, assign val]
392 | "[]" `isSuffixOf` fun
393 , (idx:[]) <- args =
394 array ++ index idx
396 | otherwise = fun ++ arguments args
397 where
398 name = filter (`notElem` "[]=") fun
399 method = name
400 field = name
401 array = name
402 object o = translateVariableName (snd o)
403 index i = "[" ++ translateVariableName (snd i) ++ "]"
404 assign v = '=' : translateVariableName (snd v)
405 arguments as =
406 '(' : intercalate "," (map (translateVariableName . snd) as) ++ ")"
408translateExpression (SChkCase var cases) =
409 "(function(e){\n"
410 ++ intercalate " else " (map (translateCase "e") cases)
411 ++ "\n})("
412 ++ translateVariableName var
413 ++ ")"
415translateExpression (SCase var cases) =
416 "(function(e){\n"
417 ++ intercalate " else " (map (translateCase "e") cases)
418 ++ "\n})("
419 ++ translateVariableName var
420 ++ ")"
422translateExpression (SCon i name vars) =
423 concat [ "new __IDRRT__.Con("
424 , show i
425 , ",["
426 , intercalate "," $ map translateVariableName vars
427 , "])"
428 ]
430translateExpression (SUpdate var e) =
431 translateVariableName var ++ " = " ++ translateExpression e
433translateExpression (SProj var i) =
434 translateVariableName var ++ ".vars[" ++ show i ++"]"
436translateExpression SNothing = "null"
438translateExpression e =
439 "(function(){throw 'Not yet implemented: "
440 ++ filter (/= '\'') (show e)
441 ++ "';})()"
443translateCase :: String -> SAlt -> String
444translateCase _ (SDefaultCase e) =
445 createIfBlock "true" (translateExpression e)
447translateCase var (SConstCase ty e)
448 | ChType <- ty = matchHelper "Char"
449 | StrType <- ty = matchHelper "String"
450 | IType <- ty = matchHelper "Int"
451 | BIType <- ty = matchHelper "Integer"
452 | FlType <- ty = matchHelper "Float"
453 | PtrType <- ty = matchHelper "Pointer"
454 | Forgot <- ty = matchHelper "Forgot"
455 where
456 matchHelper tyName = translateTypeMatch var tyName e
458translateCase var (SConstCase cst@(BI _) e) =
459 let cond = var ++ ".equals(" ++ translateConstant cst ++ ")" in
460 createIfBlock cond (translateExpression e)
462translateCase var (SConstCase cst e) =
463 let cond = var ++ " == " ++ translateConstant cst in
464 createIfBlock cond (translateExpression e)
466translateCase var (SConCase a i name vars e) =
467 let isCon = var ++ " instanceof __IDRRT__.Con"
468 isI = show i ++ " == " ++ var ++ ".i"
469 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
470 args = ".apply(this," ++ var ++ ".vars)"
471 f b =
472 "(function("
473 ++ params
474 ++ "){\nreturn " ++ b ++ "\n})" ++ args
475 cond = intercalate " && " [isCon, isI] in
476 createIfBlock cond $ f (translateExpression e)
478translateTypeMatch :: String -> String -> SExp -> String
479translateTypeMatch var ty exp =
480 let e = translateExpression exp in
481 createIfBlock (var
482 ++ " instanceof __IDRRT__.Type && "
483 ++ var ++ ".type == '"++ ty ++"'") e
486createIfBlock cond e =
487 "if (" ++ cond ++") {\n"
488 ++ "return " ++ e
489 ++ ";\n}"
491createTailcall call =
492 "__IDRRT__.tailcall(function(){return " ++ call ++ "})"
494translateFunctionCall name vars =
495 concat (intersperse "." $ translateNamespace name)
496 ++ "."
497 ++ translateName name
498 ++ "("
499 ++ intercalate "," (map translateVariableName vars)
500 ++ ")"