git.iko.soy/Idris-dev
on 2407cbb help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
475 lines 16 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript) 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__"
23codegenJavaScript
24 :: [(Name, SDecl)]
25 -> FilePath
26 -> OutputType
27 -> IO ()
28codegenJavaScript definitions filename outputType = do
29 path <- getDataDir
30 idrRuntime <- readFile (path ++ "/js/Runtime.js")
31 writeFile filename (idrRuntime ++ modules ++ functions ++ mainLoop)
32 where
33 def = map (first translateNamespace) definitions
35 functions = concatMap translateDeclaration def
37 mainLoop :: String
38 mainLoop = intercalate "\n" [ "\nfunction main() {"
39 , createTailcall "__IDR__.runMain0()"
40 , "}\n\nmain();\n"
41 ]
43 modules =
44 concatMap allocMod mods
45 where
46 allocMod m = intercalate "." m ++ " = {};\n"
47 sortMods a b = compare (length a) (length b)
49 mods =
50 drop 1 $ sortBy sortMods $ nub $ concatMap (inits . fst) def
52translateIdentifier :: String -> String
53translateIdentifier =
54 replaceReserved . concatMap replaceBadChars
55 where replaceBadChars :: Char -> String
56 replaceBadChars ' ' = "_"
57 replaceBadChars '_' = "__"
58 replaceBadChars '@' = "_at"
59 replaceBadChars '[' = "_OSB"
60 replaceBadChars ']' = "_CSB"
61 replaceBadChars '(' = "_OP"
62 replaceBadChars ')' = "_CP"
63 replaceBadChars '{' = "_OB"
64 replaceBadChars '}' = "_CB"
65 replaceBadChars '!' = "_bang"
66 replaceBadChars '#' = "_hash"
67 replaceBadChars '.' = "_dot"
68 replaceBadChars ',' = "_comma"
69 replaceBadChars ':' = "_colon"
70 replaceBadChars '+' = "_plus"
71 replaceBadChars '-' = "_minus"
72 replaceBadChars '*' = "_times"
73 replaceBadChars '<' = "_lt"
74 replaceBadChars '>' = "_gt"
75 replaceBadChars '=' = "_eq"
76 replaceBadChars '|' = "_pipe"
77 replaceBadChars '&' = "_amp"
78 replaceBadChars '/' = "_SL"
79 replaceBadChars '\\' = "_BSL"
80 replaceBadChars '%' = "_per"
81 replaceBadChars '?' = "_que"
82 replaceBadChars '~' = "_til"
83 replaceBadChars '\'' = "_apo"
84 replaceBadChars c
85 | isDigit c = "_" ++ [c] ++ "_"
86 | otherwise = [c]
87 replaceReserved s
88 | s `elem` reserved = '_' : s
89 | otherwise = s
90 reserved = [ "break"
91 , "case"
92 , "catch"
93 , "continue"
94 , "debugger"
95 , "default"
96 , "delete"
97 , "do"
98 , "else"
99 , "finally"
100 , "for"
101 , "function"
102 , "if"
103 , "in"
104 , "instanceof"
105 , "new"
106 , "return"
107 , "switch"
108 , "this"
109 , "throw"
110 , "try"
111 , "typeof"
112 , "var"
113 , "void"
114 , "while"
115 , "with"
117 , "class"
118 , "enum"
119 , "export"
120 , "extends"
121 , "import"
122 , "super"
124 , "implements"
125 , "interface"
126 , "let"
127 , "package"
128 , "private"
129 , "protected"
130 , "public"
131 , "static"
132 , "yield"
133 ]
135translateNamespace :: Name -> [String]
136translateNamespace (UN _) = [idrNamespace]
137translateNamespace (NS _ ns) = idrNamespace : map translateIdentifier ns
138translateNamespace (MN _ _) = [idrNamespace]
140translateName :: Name -> String
141translateName (UN name) = translateIdentifier name
142translateName (NS name _) = translateName name
143translateName (MN i name) = translateIdentifier name ++ show i
145translateConstant :: Const -> String
146translateConstant (I i) = show i
147translateConstant (BI i) = "__IDRRT__.bigInt('" ++ show i ++ "')"
148translateConstant (Fl f) = show f
149translateConstant (Ch c) = show c
150translateConstant (Str s) = show s
151translateConstant IType = "__IDRRT__.Int"
152translateConstant ChType = "__IDRRT__.Char"
153translateConstant StrType = "__IDRRT__.String"
154translateConstant BIType = "__IDRRT__.Integer"
155translateConstant FlType = "__IDRRT__.Float"
156translateConstant Forgot = "__IDRRT__.Forgot"
157translateConstant c =
158 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
160translateParameterlist =
161 map translateParameter
162 where translateParameter (MN i name) = translateIdentifier name ++ show i
163 translateParameter (UN name) = translateIdentifier name
165translateDeclaration :: ([String], SDecl) -> String
166translateDeclaration (path, SFun name params stackSize body) =
167 intercalate "." (path ++ [translateName name])
168 ++ " = function("
169 ++ intercalate "," p
170 ++ "){\n"
171 ++ concatMap assignVar (zip [0..] p)
172 ++ concatMap allocVar [numP..(numP+stackSize-1)]
173 ++ "return "
174 ++ translateExpression body
175 ++ ";\n};\n"
176 where
177 numP :: Int
178 numP = length params
180 allocVar :: Int -> String
181 allocVar n = "var __var_" ++ show n ++ ";\n"
183 assignVar :: (Int, String) -> String
184 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
186 p :: [String]
187 p = translateParameterlist params
189translateVariableName :: LVar -> String
190translateVariableName (Loc i) =
191 "__var_" ++ show i
193translateExpression :: SExp -> String
194translateExpression (SLet name value body) =
195 "(function("
196 ++ translateVariableName name
197 ++ "){\nreturn "
198 ++ translateExpression body
199 ++ ";\n})("
200 ++ translateExpression value
201 ++ ")"
203translateExpression (SConst cst) =
204 translateConstant cst
206translateExpression (SV var) =
207 translateVariableName var
209translateExpression (SApp False name vars) =
210 createTailcall $ translateFunctionCall name vars
212translateExpression (SApp True name vars) =
213 "new __IDRRT__.Tailcall("
214 ++ "function(){\n"
215 ++ "return " ++ translateFunctionCall name vars
216 ++ ";\n});"
218translateExpression (SOp op vars)
219 | LPlus <- op
220 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
221 | LMinus <- op
222 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
223 | LTimes <- op
224 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
225 | LDiv <- op
226 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
227 | LMod <- op
228 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
229 | LEq <- op
230 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
231 | LLt <- op
232 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
233 | LLe <- op
234 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
235 | LGt <- op
236 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
237 | LGe <- op
238 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
239 | LAnd <- op
240 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
241 | LOr <- op
242 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
243 | LXOr <- op
244 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
245 | LSHL <- op
246 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
247 | LSHR <- op
248 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
249 | LCompl <- op
250 , (arg:_) <- vars = '~' : translateVariableName arg
252 | LBPlus <- op
253 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
254 | LBMinus <- op
255 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
256 | LBTimes <- op
257 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
258 | LBDiv <- op
259 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
260 | LBMod <- op
261 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
262 | LBEq <- op
263 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
264 | LBLt <- op
265 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
266 | LBLe <- op
267 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
268 | LBGt <- op
269 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
270 | LBGe <- op
271 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
273 | LFPlus <- op
274 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
275 | LFMinus <- op
276 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
277 | LFTimes <- op
278 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
279 | LFDiv <- op
280 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
281 | LFEq <- op
282 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
283 | LFLt <- op
284 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
285 | LFLe <- op
286 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
287 | LFGt <- op
288 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
289 | LFGe <- op
290 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
292 | LStrConcat <- op
293 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
294 | LStrEq <- op
295 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
296 | LStrLt <- op
297 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
298 | LStrLen <- op
299 , (arg:_) <- vars = translateVariableName arg ++ ".length"
301 | LStrInt <- op
302 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
303 | LIntStr <- op
304 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
305 | LIntBig <- op
306 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
307 | LBigInt <- op
308 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
309 | LBigStr <- op
310 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
311 | LStrBig <- op
312 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
313 | LFloatStr <- op
314 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
315 | LStrFloat <- op
316 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
317 | LIntFloat <- op
318 , (arg:_) <- vars = translateVariableName arg
319 | LFloatInt <- op
320 , (arg:_) <- vars = translateVariableName arg
321 | LChInt <- op
322 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
323 | LIntCh <- op
324 , (arg:_) <- vars =
325 "String.fromCharCode(" ++ translateVariableName arg ++ ")"
327 | LFExp <- op
328 , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
329 | LFLog <- op
330 , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
331 | LFSin <- op
332 , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
333 | LFCos <- op
334 , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
335 | LFTan <- op
336 , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
337 | LFASin <- op
338 , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
339 | LFACos <- op
340 , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
341 | LFATan <- op
342 , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
343 | LFSqrt <- op
344 , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
345 | LFFloor <- op
346 , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
347 | LFCeil <- op
348 , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
350 | LStrCons <- op
351 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
352 | LStrHead <- op
353 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
354 | LStrRev <- op
355 , (arg:_) <- vars = let v = translateVariableName arg in
356 v ++ "split('').reverse().join('')"
357 | LStrIndex <- op
358 , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
359 r = translateVariableName rhs in
360 l ++ "[" ++ r ++ "]"
361 | LStrTail <- op
362 , (arg:_) <- vars = let v = translateVariableName arg in
363 v ++ ".substr(1," ++ v ++ ".length-1)"
364 where
365 translateBinaryOp :: String -> LVar -> LVar -> String
366 translateBinaryOp f lhs rhs =
367 translateVariableName lhs
368 ++ f
369 ++ translateVariableName rhs
371translateExpression (SError msg) =
372 "(function(){throw \'" ++ msg ++ "\';})();"
374translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
375 "__IDRRT__.print(" ++ translateVariableName var ++ ");"
377translateExpression (SForeign _ _ fun args) =
378 fun
379 ++ "("
380 ++ intercalate "," (map (translateVariableName . snd) args)
381 ++ ");"
383translateExpression (SChkCase var cases) =
384 "(function(e){\n"
385 ++ intercalate " else " (map (translateCase "e") cases)
386 ++ "\n})("
387 ++ translateVariableName var
388 ++ ")"
390translateExpression (SCase var cases) =
391 "(function(e){\n"
392 ++ intercalate " else " (map (translateCase "e") cases)
393 ++ "\n})("
394 ++ translateVariableName var
395 ++ ")"
397translateExpression (SCon i name vars) =
398 concat [ "new __IDRRT__.Con("
399 , show i
400 , ",["
401 , intercalate "," $ map translateVariableName vars
402 , "])"
403 ]
405translateExpression (SUpdate var e) =
406 translateVariableName var ++ " = " ++ translateExpression e
408translateExpression (SProj var i) =
409 translateVariableName var ++ ".vars[" ++ show i ++"]"
411translateExpression SNothing = "null"
413translateExpression e =
414 "(function(){throw 'Not yet implemented: "
415 ++ filter (/= '\'') (show e)
416 ++ "';})()"
418translateCase :: String -> SAlt -> String
419translateCase _ (SDefaultCase e) =
420 createIfBlock "true" (translateExpression e)
422translateCase var (SConstCase ty e)
423 | ChType <- ty = matchHelper "Char"
424 | StrType <- ty = matchHelper "String"
425 | IType <- ty = matchHelper "Int"
426 | BIType <- ty = matchHelper "Integer"
427 | FlType <- ty = matchHelper "Float"
428 | PtrType <- ty = matchHelper "Pointer"
429 | Forgot <- ty = matchHelper "Forgot"
430 where
431 matchHelper tyName = translateTypeMatch var tyName e
433translateCase var (SConstCase cst@(BI _) e) =
434 let cond = var ++ ".equals(" ++ translateConstant cst ++ ")" in
435 createIfBlock cond (translateExpression e)
437translateCase var (SConstCase cst e) =
438 let cond = var ++ " == " ++ translateConstant cst in
439 createIfBlock cond (translateExpression e)
441translateCase var (SConCase a i name vars e) =
442 let isCon = var ++ " instanceof __IDRRT__.Con"
443 isI = show i ++ " == " ++ var ++ ".i"
444 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
445 args = ".apply(this," ++ var ++ ".vars)"
446 f b =
447 "(function("
448 ++ params
449 ++ "){\nreturn " ++ b ++ "\n})" ++ args
450 cond = intercalate " && " [isCon, isI] in
451 createIfBlock cond $ f (translateExpression e)
453translateTypeMatch :: String -> String -> SExp -> String
454translateTypeMatch var ty exp =
455 let e = translateExpression exp in
456 createIfBlock (var
457 ++ " instanceof __IDRRT__.Type && "
458 ++ var ++ ".type == '"++ ty ++"'") e
461createIfBlock cond e =
462 "if (" ++ cond ++") {\n"
463 ++ "return " ++ e
464 ++ ";\n}"
466createTailcall call =
467 "__IDRRT__.tailcall(function(){return " ++ call ++ "})"
469translateFunctionCall name vars =
470 concat (intersperse "." $ translateNamespace name)
471 ++ "."
472 ++ translateName name
473 ++ "("
474 ++ intercalate "," (map translateVariableName vars)
475 ++ ")"