git.iko.soy/Idris-dev
on 340beed help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
525 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 IType = "__IDRRT__.Int"
147translateConstant ChType = "__IDRRT__.Char"
148translateConstant StrType = "__IDRRT__.String"
149translateConstant BIType = "__IDRRT__.Integer"
150translateConstant FlType = "__IDRRT__.Float"
151translateConstant PtrType = "__IDRRT__.Ptr"
152translateConstant Forgot = "__IDRRT__.Forgot"
153translateConstant c =
154 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
156translateParameterlist =
157 map translateParameter
158 where translateParameter (MN i name) = translateIdentifier name ++ show i
159 translateParameter (UN name) = translateIdentifier name
161translateDeclaration :: ([String], SDecl) -> String
162translateDeclaration (path, SFun name params stackSize body) =
163 intercalate "." (path ++ [translateName name])
164 ++ " = function("
165 ++ intercalate "," p
166 ++ "){\n"
167 ++ concatMap assignVar (zip [0..] p)
168 ++ concatMap allocVar [numP..(numP+stackSize-1)]
169 ++ "return "
170 ++ translateExpression body
171 ++ ";\n};\n"
172 where
173 numP :: Int
174 numP = length params
176 allocVar :: Int -> String
177 allocVar n = "var __var_" ++ show n ++ ";\n"
179 assignVar :: (Int, String) -> String
180 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
182 p :: [String]
183 p = translateParameterlist params
185translateVariableName :: LVar -> String
186translateVariableName (Loc i) =
187 "__var_" ++ show i
189translateExpression :: SExp -> String
190translateExpression (SLet name value body) =
191 "(function("
192 ++ translateVariableName name
193 ++ "){\nreturn "
194 ++ translateExpression body
195 ++ ";\n})("
196 ++ translateExpression value
197 ++ ")"
199translateExpression (SConst cst) =
200 translateConstant cst
202translateExpression (SV var) =
203 translateVariableName var
205translateExpression (SApp False name vars) =
206 createTailcall $ translateFunctionCall name vars
208translateExpression (SApp True name vars) =
209 "new __IDRRT__.Tailcall("
210 ++ "function(){\n"
211 ++ "return " ++ translateFunctionCall name vars
212 ++ ";\n})"
214translateExpression (SOp op vars)
215 | (LPlus _) <- op
216 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
217 | (LMinus _) <- op
218 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
219 | (LTimes _) <- op
220 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
221 | (LSDiv _) <- op
222 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
223 | (LSRem _) <- op
224 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
225 | (LEq _) <- op
226 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
227 | (LLt _) <- op
228 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
229 | (LLe _) <- op
230 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
231 | (LGt _) <- op
232 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
233 | (LGe _) <- op
234 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
235 | (LAnd _) <- op
236 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
237 | (LOr _) <- op
238 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
239 | (LXOr _) <- op
240 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
241 | (LSHL _) <- op
242 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
243 | (LASHR _) <- op
244 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
245 | (LCompl _) <- op
246 , (arg:_) <- vars = '~' : translateVariableName arg
248 | (LPlus ITBig) <- op
249 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
250 | (LMinus ITBig) <- op
251 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
252 | (LTimes ITBig) <- op
253 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
254 | (LSDiv ITBig) <- op
255 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
256 | (LSRem ITBig) <- op
257 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
258 | (LEq ITBig) <- op
259 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
260 | (LLt ITBig) <- op
261 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
262 | (LLe ITBig) <- op
263 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
264 | (LGt ITBig) <- op
265 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
266 | (LGe ITBig) <- op
267 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
269 | LFPlus <- op
270 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
271 | LFMinus <- op
272 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
273 | LFTimes <- op
274 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
275 | LFDiv <- op
276 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
277 | LFEq <- op
278 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
279 | LFLt <- op
280 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
281 | LFLe <- op
282 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
283 | LFGt <- op
284 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
285 | LFGe <- op
286 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
288 | LStrConcat <- op
289 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
290 | LStrEq <- op
291 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
292 | LStrLt <- op
293 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
294 | LStrLen <- op
295 , (arg:_) <- vars = translateVariableName arg ++ ".length"
297 | (LStrInt ITNative) <- op
298 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
299 | (LIntStr ITNative) <- op
300 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
301 | (LSExt ITNative ITBig) <- op
302 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
303 | (LTrunc ITBig ITNative) <- op
304 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
305 | (LIntStr ITBig) <- op
306 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
307 | (LStrInt ITBig) <- op
308 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
309 | LFloatStr <- op
310 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
311 | LStrFloat <- op
312 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
313 | (LIntFloat ITNative) <- op
314 , (arg:_) <- vars = translateVariableName arg
315 | (LFloatInt ITNative) <- op
316 , (arg:_) <- vars = translateVariableName arg
317 | (LChInt ITNative) <- op
318 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
319 | (LIntCh ITNative) <- op
320 , (arg:_) <- vars =
321 "String.fromCharCode(" ++ translateVariableName arg ++ ")"
323 | LFExp <- op
324 , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
325 | LFLog <- op
326 , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
327 | LFSin <- op
328 , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
329 | LFCos <- op
330 , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
331 | LFTan <- op
332 , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
333 | LFASin <- op
334 , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
335 | LFACos <- op
336 , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
337 | LFATan <- op
338 , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
339 | LFSqrt <- op
340 , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
341 | LFFloor <- op
342 , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
343 | LFCeil <- op
344 , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
346 | LStrCons <- op
347 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
348 | LStrHead <- op
349 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
350 | LStrRev <- op
351 , (arg:_) <- vars = let v = translateVariableName arg in
352 v ++ ".split('').reverse().join('')"
353 | LStrIndex <- op
354 , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
355 r = translateVariableName rhs in
356 l ++ "[" ++ r ++ "]"
357 | LStrTail <- op
358 , (arg:_) <- vars = let v = translateVariableName arg in
359 v ++ ".substr(1," ++ v ++ ".length-1)"
360 where
361 translateBinaryOp :: String -> LVar -> LVar -> String
362 translateBinaryOp f lhs rhs =
363 translateVariableName lhs
364 ++ f
365 ++ translateVariableName rhs
367translateExpression (SError msg) =
368 "(function(){throw \'" ++ msg ++ "\';})()"
370translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
371 "__IDRRT__.print(" ++ translateVariableName var ++ ")"
373translateExpression (SForeign _ _ fun args)
374 | "[]=" `isSuffixOf` fun
375 , (obj:idx:val:[]) <- args =
376 concat [object obj, index idx, assign val]
378 | "[]" `isSuffixOf` fun
379 , (obj:idx:[]) <- args =
380 object obj ++ index idx
382 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
383 , (obj:val:[]) <- args =
384 concat [object obj, '[' : name ++ "]", assign val]
386 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
387 , (obj:[]) <- args =
388 object obj ++ '[' : name ++ "]"
390 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
391 , (obj:val:[]) <- args =
392 concat [object obj, field, assign val]
394 | "." `isPrefixOf` fun
395 , (obj:[]) <- args =
396 object obj ++ field
398 | "." `isPrefixOf` fun
399 , (obj:[(FUnit, _)]) <- args =
400 concat [object obj, method, "()"]
402 | "." `isPrefixOf` fun
403 , (obj:as) <- args =
404 concat [object obj, method, arguments as]
406 | "[]=" `isSuffixOf` fun
407 , (idx:val:[]) <- args =
408 concat [array, index idx, assign val]
410 | "[]" `isSuffixOf` fun
411 , (idx:[]) <- args =
412 array ++ index idx
414 | otherwise = fun ++ arguments args
415 where
416 name = filter (`notElem` "[]=") fun
417 method = name
418 field = name
419 array = name
420 object o = translateVariableName (snd o)
421 index i = "[" ++ translateVariableName (snd i) ++ "]"
422 assign v = '=' : generateWrapper v
423 arguments as =
424 '(' : intercalate "," (map generateWrapper as) ++ ")"
426 generateWrapper (ffunc, name)
427 | FFunction <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"
428 | FFunctionIO <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"
430 generateWrapper (_, name) =
431 translateVariableName name
433translateExpression (SChkCase var cases) =
434 "(function(e){\n"
435 ++ intercalate " else " (map (translateCase "e") cases)
436 ++ "\n})("
437 ++ translateVariableName var
438 ++ ")"
440translateExpression (SCase var cases) =
441 "(function(e){\n"
442 ++ intercalate " else " (map (translateCase "e") cases)
443 ++ "\n})("
444 ++ translateVariableName var
445 ++ ")"
447translateExpression (SCon i name vars) =
448 concat [ "new __IDRRT__.Con("
449 , show i
450 , ",["
451 , intercalate "," $ map translateVariableName vars
452 , "])"
453 ]
455translateExpression (SUpdate var e) =
456 translateVariableName var ++ " = " ++ translateExpression e
458translateExpression (SProj var i) =
459 translateVariableName var ++ ".vars[" ++ show i ++"]"
461translateExpression SNothing = "null"
463translateExpression e =
464 "(function(){throw 'Not yet implemented: "
465 ++ filter (/= '\'') (show e)
466 ++ "';})()"
468translateCase :: String -> SAlt -> String
469translateCase _ (SDefaultCase e) =
470 createIfBlock "true" (translateExpression e)
472translateCase var (SConstCase ty e)
473 | ChType <- ty = matchHelper "Char"
474 | StrType <- ty = matchHelper "String"
475 | IType <- ty = matchHelper "Int"
476 | BIType <- ty = matchHelper "Integer"
477 | FlType <- ty = matchHelper "Float"
478 | PtrType <- ty = matchHelper "Ptr"
479 | Forgot <- ty = matchHelper "Forgot"
480 where
481 matchHelper tyName = translateTypeMatch var tyName e
483translateCase var (SConstCase cst@(BI _) e) =
484 let cond = "__IDRRT__.bigInt(" ++ var ++ ").equals(" ++ translateConstant cst ++ ")" in
485 createIfBlock cond (translateExpression e)
487translateCase var (SConstCase cst e) =
488 let cond = var ++ " == " ++ translateConstant cst in
489 createIfBlock cond (translateExpression e)
491translateCase var (SConCase a i name vars e) =
492 let isCon = var ++ " instanceof __IDRRT__.Con"
493 isI = show i ++ " == " ++ var ++ ".i"
494 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
495 args = ".apply(this," ++ var ++ ".vars)"
496 f b =
497 "(function("
498 ++ params
499 ++ "){\nreturn " ++ b ++ "\n})" ++ args
500 cond = intercalate " && " [isCon, isI] in
501 createIfBlock cond $ f (translateExpression e)
503translateTypeMatch :: String -> String -> SExp -> String
504translateTypeMatch var ty exp =
505 let e = translateExpression exp in
506 createIfBlock (var
507 ++ " instanceof __IDRRT__.Type && "
508 ++ var ++ ".type == '"++ ty ++"'") e
511createIfBlock cond e =
512 "if (" ++ cond ++") {\n"
513 ++ "return " ++ e
514 ++ ";\n}"
516createTailcall call =
517 "__IDRRT__.tailcall(function(){return " ++ call ++ "})"
519translateFunctionCall name vars =
520 concat (intersperse "." $ translateNamespace name)
521 ++ "."
522 ++ translateName name
523 ++ "("
524 ++ intercalate "," (map translateVariableName vars)
525 ++ ")"