git.iko.soy/Idris-dev
on 3dd89eb help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
489 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 c
57 | ' ' <- c = "_"
58 | '_' <- c = "__"
59 | isDigit c = "_" ++ [c] ++ "_"
60 | not (isLetter c && isAscii c) = '_' : show (ord c)
61 | otherwise = [c]
62 replaceReserved s
63 | s `elem` reserved = '_' : s
64 | otherwise = s
65 reserved = [ "break"
66 , "case"
67 , "catch"
68 , "continue"
69 , "debugger"
70 , "default"
71 , "delete"
72 , "do"
73 , "else"
74 , "finally"
75 , "for"
76 , "function"
77 , "if"
78 , "in"
79 , "instanceof"
80 , "new"
81 , "return"
82 , "switch"
83 , "this"
84 , "throw"
85 , "try"
86 , "typeof"
87 , "var"
88 , "void"
89 , "while"
90 , "with"
92 , "class"
93 , "enum"
94 , "export"
95 , "extends"
96 , "import"
97 , "super"
99 , "implements"
100 , "interface"
101 , "let"
102 , "package"
103 , "private"
104 , "protected"
105 , "public"
106 , "static"
107 , "yield"
108 ]
110translateNamespace :: Name -> [String]
111translateNamespace (UN _) = [idrNamespace]
112translateNamespace (NS _ ns) = idrNamespace : map translateIdentifier ns
113translateNamespace (MN _ _) = [idrNamespace]
115translateName :: Name -> String
116translateName (UN name) = translateIdentifier name
117translateName (NS name _) = translateName name
118translateName (MN i name) = translateIdentifier name ++ show i
120translateConstant :: Const -> String
121translateConstant (I i) = show i
122translateConstant (BI i) = "__IDRRT__.bigInt('" ++ show i ++ "')"
123translateConstant (Fl f) = show f
124translateConstant (Ch c) = show c
125translateConstant (Str s) = show s
126translateConstant IType = "__IDRRT__.Int"
127translateConstant ChType = "__IDRRT__.Char"
128translateConstant StrType = "__IDRRT__.String"
129translateConstant BIType = "__IDRRT__.Integer"
130translateConstant FlType = "__IDRRT__.Float"
131translateConstant Forgot = "__IDRRT__.Forgot"
132translateConstant c =
133 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
135translateParameterlist =
136 map translateParameter
137 where translateParameter (MN i name) = translateIdentifier name ++ show i
138 translateParameter (UN name) = translateIdentifier name
140translateDeclaration :: ([String], SDecl) -> String
141translateDeclaration (path, SFun name params stackSize body) =
142 intercalate "." (path ++ [translateName name])
143 ++ " = function("
144 ++ intercalate "," p
145 ++ "){\n"
146 ++ concatMap assignVar (zip [0..] p)
147 ++ concatMap allocVar [numP..(numP+stackSize-1)]
148 ++ "return "
149 ++ translateExpression body
150 ++ ";\n};\n"
151 where
152 numP :: Int
153 numP = length params
155 allocVar :: Int -> String
156 allocVar n = "var __var_" ++ show n ++ ";\n"
158 assignVar :: (Int, String) -> String
159 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
161 p :: [String]
162 p = translateParameterlist params
164translateVariableName :: LVar -> String
165translateVariableName (Loc i) =
166 "__var_" ++ show i
168translateExpression :: SExp -> String
169translateExpression (SLet name value body) =
170 "(function("
171 ++ translateVariableName name
172 ++ "){\nreturn "
173 ++ translateExpression body
174 ++ ";\n})("
175 ++ translateExpression value
176 ++ ")"
178translateExpression (SConst cst) =
179 translateConstant cst
181translateExpression (SV var) =
182 translateVariableName var
184translateExpression (SApp False name vars) =
185 createTailcall $ translateFunctionCall name vars
187translateExpression (SApp True name vars) =
188 "new __IDRRT__.Tailcall("
189 ++ "function(){\n"
190 ++ "return " ++ translateFunctionCall name vars
191 ++ ";\n});"
193translateExpression (SOp op vars)
194 | LPlus <- op
195 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
196 | LMinus <- op
197 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
198 | LTimes <- op
199 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
200 | LDiv <- op
201 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
202 | LMod <- op
203 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
204 | LEq <- op
205 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
206 | LLt <- op
207 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
208 | LLe <- op
209 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
210 | LGt <- op
211 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
212 | LGe <- op
213 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
214 | LAnd <- op
215 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
216 | LOr <- op
217 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
218 | LXOr <- op
219 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
220 | LSHL <- op
221 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
222 | LSHR <- op
223 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
224 | LCompl <- op
225 , (arg:_) <- vars = '~' : translateVariableName arg
227 | LBPlus <- op
228 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
229 | LBMinus <- op
230 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
231 | LBTimes <- op
232 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
233 | LBDiv <- op
234 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
235 | LBMod <- op
236 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
237 | LBEq <- op
238 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
239 | LBLt <- op
240 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
241 | LBLe <- op
242 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
243 | LBGt <- op
244 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
245 | LBGe <- op
246 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
248 | LFPlus <- op
249 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
250 | LFMinus <- op
251 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
252 | LFTimes <- op
253 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
254 | LFDiv <- op
255 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
256 | LFEq <- op
257 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
258 | LFLt <- op
259 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
260 | LFLe <- op
261 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
262 | LFGt <- op
263 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
264 | LFGe <- op
265 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
267 | LStrConcat <- op
268 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
269 | LStrEq <- op
270 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
271 | LStrLt <- op
272 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
273 | LStrLen <- op
274 , (arg:_) <- vars = translateVariableName arg ++ ".length"
276 | LStrInt <- op
277 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
278 | LIntStr <- op
279 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
280 | LIntBig <- op
281 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
282 | LBigInt <- op
283 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
284 | LBigStr <- op
285 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
286 | LStrBig <- op
287 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
288 | LFloatStr <- op
289 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
290 | LStrFloat <- op
291 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
292 | LIntFloat <- op
293 , (arg:_) <- vars = translateVariableName arg
294 | LFloatInt <- op
295 , (arg:_) <- vars = translateVariableName arg
296 | LChInt <- op
297 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
298 | LIntCh <- op
299 , (arg:_) <- vars =
300 "String.fromCharCode(" ++ translateVariableName arg ++ ")"
302 | LFExp <- op
303 , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
304 | LFLog <- op
305 , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
306 | LFSin <- op
307 , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
308 | LFCos <- op
309 , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
310 | LFTan <- op
311 , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
312 | LFASin <- op
313 , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
314 | LFACos <- op
315 , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
316 | LFATan <- op
317 , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
318 | LFSqrt <- op
319 , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
320 | LFFloor <- op
321 , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
322 | LFCeil <- op
323 , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
325 | LStrCons <- op
326 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
327 | LStrHead <- op
328 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
329 | LStrRev <- op
330 , (arg:_) <- vars = let v = translateVariableName arg in
331 v ++ "split('').reverse().join('')"
332 | LStrIndex <- op
333 , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
334 r = translateVariableName rhs in
335 l ++ "[" ++ r ++ "]"
336 | LStrTail <- op
337 , (arg:_) <- vars = let v = translateVariableName arg in
338 v ++ ".substr(1," ++ v ++ ".length-1)"
339 where
340 translateBinaryOp :: String -> LVar -> LVar -> String
341 translateBinaryOp f lhs rhs =
342 translateVariableName lhs
343 ++ f
344 ++ translateVariableName rhs
346translateExpression (SError msg) =
347 "(function(){throw \'" ++ msg ++ "\';})();"
349translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
350 "__IDRRT__.print(" ++ translateVariableName var ++ ");"
352translateExpression (SForeign _ _ fun args)
353 | "." `isPrefixOf` fun, "[]=" `isSuffixOf` fun
354 , (obj:idx:val:[]) <- args =
355 concat [object obj, field, index idx, assign val]
357 | "." `isPrefixOf` fun, "[]" `isSuffixOf` fun
358 , (obj:idx:[]) <- args =
359 concat [object obj, field, index idx]
361 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
362 , (obj:val:[]) <- args =
363 concat [object obj, field, assign val]
365 | "." `isPrefixOf` fun
366 , (obj:[]) <- args =
367 object obj ++ field
369 | "." `isPrefixOf` fun
370 , (obj:[(FUnit, _)]) <- args =
371 concat [object obj, method, "()"]
373 | "." `isPrefixOf` fun
374 , (obj:as) <- args =
375 concat [object obj, method, arguments as]
377 | "[]=" == fun
378 , (idx:val:[]) <- args =
379 concat [array, index idx, assign val]
381 | "[]" == fun
382 , (idx:[]) <- args =
383 array ++ index idx
385 | otherwise = fun ++ arguments args
386 where
387 name = filter (`notElem` "[]=") fun
388 method = name
389 field = name
390 array = name
391 object o = translateVariableName (snd o)
392 index i = "[" ++ translateVariableName (snd i) ++ "]"
393 assign v = '=' : translateVariableName (snd v)
394 arguments as =
395 '(' : intercalate "," (map (translateVariableName . snd) as) ++ ")"
397translateExpression (SChkCase var cases) =
398 "(function(e){\n"
399 ++ intercalate " else " (map (translateCase "e") cases)
400 ++ "\n})("
401 ++ translateVariableName var
402 ++ ")"
404translateExpression (SCase var cases) =
405 "(function(e){\n"
406 ++ intercalate " else " (map (translateCase "e") cases)
407 ++ "\n})("
408 ++ translateVariableName var
409 ++ ")"
411translateExpression (SCon i name vars) =
412 concat [ "new __IDRRT__.Con("
413 , show i
414 , ",["
415 , intercalate "," $ map translateVariableName vars
416 , "])"
417 ]
419translateExpression (SUpdate var e) =
420 translateVariableName var ++ " = " ++ translateExpression e
422translateExpression (SProj var i) =
423 translateVariableName var ++ ".vars[" ++ show i ++"]"
425translateExpression SNothing = "null"
427translateExpression e =
428 "(function(){throw 'Not yet implemented: "
429 ++ filter (/= '\'') (show e)
430 ++ "';})()"
432translateCase :: String -> SAlt -> String
433translateCase _ (SDefaultCase e) =
434 createIfBlock "true" (translateExpression e)
436translateCase var (SConstCase ty e)
437 | ChType <- ty = matchHelper "Char"
438 | StrType <- ty = matchHelper "String"
439 | IType <- ty = matchHelper "Int"
440 | BIType <- ty = matchHelper "Integer"
441 | FlType <- ty = matchHelper "Float"
442 | PtrType <- ty = matchHelper "Pointer"
443 | Forgot <- ty = matchHelper "Forgot"
444 where
445 matchHelper tyName = translateTypeMatch var tyName e
447translateCase var (SConstCase cst@(BI _) e) =
448 let cond = var ++ ".equals(" ++ translateConstant cst ++ ")" in
449 createIfBlock cond (translateExpression e)
451translateCase var (SConstCase cst e) =
452 let cond = var ++ " == " ++ translateConstant cst in
453 createIfBlock cond (translateExpression e)
455translateCase var (SConCase a i name vars e) =
456 let isCon = var ++ " instanceof __IDRRT__.Con"
457 isI = show i ++ " == " ++ var ++ ".i"
458 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
459 args = ".apply(this," ++ var ++ ".vars)"
460 f b =
461 "(function("
462 ++ params
463 ++ "){\nreturn " ++ b ++ "\n})" ++ args
464 cond = intercalate " && " [isCon, isI] in
465 createIfBlock cond $ f (translateExpression e)
467translateTypeMatch :: String -> String -> SExp -> String
468translateTypeMatch var ty exp =
469 let e = translateExpression exp in
470 createIfBlock (var
471 ++ " instanceof __IDRRT__.Type && "
472 ++ var ++ ".type == '"++ ty ++"'") e
475createIfBlock cond e =
476 "if (" ++ cond ++") {\n"
477 ++ "return " ++ e
478 ++ ";\n}"
480createTailcall call =
481 "__IDRRT__.tailcall(function(){return " ++ call ++ "})"
483translateFunctionCall name vars =
484 concat (intersperse "." $ translateNamespace name)
485 ++ "."
486 ++ translateName name
487 ++ "("
488 ++ intercalate "," (map translateVariableName vars)
489 ++ ")"