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