git.iko.soy/Idris-dev
on 73ec76f help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
428 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 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]
88translateNamespace :: Name -> [String]
89translateNamespace (UN _) = [idrNamespace]
90translateNamespace (NS _ ns) = idrNamespace : map translateIdentifier ns
91translateNamespace (MN _ _) = [idrNamespace]
93translateName :: Name -> String
94translateName (UN name) = translateIdentifier name
95translateName (NS name _) = translateName name
96translateName (MN i name) = translateIdentifier name ++ show i
98translateConstant :: Const -> String
99translateConstant (I i) = show i
100translateConstant (BI i) = "__IDRRT__.bigInt('" ++ show i ++ "')"
101translateConstant (Fl f) = show f
102translateConstant (Ch c) = show c
103translateConstant (Str s) = show s
104translateConstant IType = "__IDRRT__.Int"
105translateConstant ChType = "__IDRRT__.Char"
106translateConstant StrType = "__IDRRT__.String"
107translateConstant BIType = "__IDRRT__.Integer"
108translateConstant FlType = "__IDRRT__.Float"
109translateConstant Forgot = "__IDRRT__.Forgot"
110translateConstant c =
111 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
113translateParameterlist =
114 map translateParameter
115 where translateParameter (MN i name) = name ++ show i
116 translateParameter (UN name) = name
118translateDeclaration :: ([String], SDecl) -> String
119translateDeclaration (path, SFun name params stackSize body) =
120 intercalate "." (path ++ [translateName name])
121 ++ " = function("
122 ++ intercalate "," p
123 ++ "){\n"
124 ++ concatMap assignVar (zip [0..] p)
125 ++ concatMap allocVar [numP..(numP+stackSize-1)]
126 ++ "return "
127 ++ translateExpression body
128 ++ ";\n};\n"
129 where
130 numP :: Int
131 numP = length params
133 allocVar :: Int -> String
134 allocVar n = "var __var_" ++ show n ++ ";\n"
136 assignVar :: (Int, String) -> String
137 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
139 p :: [String]
140 p = translateParameterlist params
142translateVariableName :: LVar -> String
143translateVariableName (Loc i) =
144 "__var_" ++ show i
146translateExpression :: SExp -> String
147translateExpression (SLet name value body) =
148 "(function("
149 ++ translateVariableName name
150 ++ "){\nreturn "
151 ++ translateExpression body
152 ++ ";\n})("
153 ++ translateExpression value
154 ++ ")"
156translateExpression (SConst cst) =
157 translateConstant cst
159translateExpression (SV var) =
160 translateVariableName var
162translateExpression (SApp False name vars) =
163 createTailcall $ translateFunctionCall name vars
165translateExpression (SApp True name vars) =
166 "new __IDRRT__.Tailcall("
167 ++ "function(){\n"
168 ++ "return " ++ translateFunctionCall name vars
169 ++ ";\n});"
171translateExpression (SOp op vars)
172 | LPlus <- op
173 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
174 | LMinus <- op
175 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
176 | LTimes <- op
177 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
178 | LDiv <- op
179 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
180 | LMod <- op
181 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
182 | LEq <- op
183 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
184 | LLt <- op
185 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
186 | LLe <- op
187 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
188 | LGt <- op
189 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
190 | LGe <- op
191 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
192 | LAnd <- op
193 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
194 | LOr <- op
195 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
196 | LXOr <- op
197 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
198 | LSHL <- op
199 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
200 | LSHR <- op
201 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
202 | LCompl <- op
203 , (arg:_) <- vars = '~' : translateVariableName arg
205 | LBPlus <- op
206 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
207 | LBMinus <- op
208 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
209 | LBTimes <- op
210 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
211 | LBDiv <- op
212 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
213 | LBMod <- op
214 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
215 | LBEq <- op
216 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
217 | LBLt <- op
218 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
219 | LBLe <- op
220 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
221 | LBGt <- op
222 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
223 | LBGe <- op
224 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
226 | LFPlus <- op
227 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
228 | LFMinus <- op
229 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
230 | LFTimes <- op
231 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
232 | LFDiv <- op
233 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
234 | LFEq <- op
235 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
236 | LFLt <- op
237 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
238 | LFLe <- op
239 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
240 | LFGt <- op
241 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
242 | LFGe <- op
243 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
245 | LStrConcat <- op
246 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
247 | LStrEq <- op
248 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
249 | LStrLt <- op
250 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
251 | LStrLen <- op
252 , (arg:_) <- vars = translateVariableName arg ++ ".length"
254 | LStrInt <- op
255 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
256 | LIntStr <- op
257 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
258 | LIntBig <- op
259 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
260 | LBigInt <- op
261 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
262 | LBigStr <- op
263 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
264 | LStrBig <- op
265 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"
266 | LFloatStr <- op
267 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
268 | LStrFloat <- op
269 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
270 | LIntFloat <- op
271 , (arg:_) <- vars = translateVariableName arg
272 | LFloatInt <- op
273 , (arg:_) <- vars = translateVariableName arg
274 | LChInt <- op
275 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
276 | LIntCh <- op
277 , (arg:_) <- vars =
278 "String.fromCharCode(" ++ translateVariableName arg ++ ")"
280 | LFExp <- op
281 , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
282 | LFLog <- op
283 , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
284 | LFSin <- op
285 , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
286 | LFCos <- op
287 , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
288 | LFTan <- op
289 , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
290 | LFASin <- op
291 , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
292 | LFACos <- op
293 , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
294 | LFATan <- op
295 , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
296 | LFSqrt <- op
297 , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
298 | LFFloor <- op
299 , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
300 | LFCeil <- op
301 , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
303 | LStrCons <- op
304 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
305 | LStrHead <- op
306 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
307 | LStrRev <- op
308 , (arg:_) <- vars = let v = translateVariableName arg in
309 v ++ "split('').reverse().join('')"
310 | LStrIndex <- op
311 , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
312 r = translateVariableName rhs in
313 l ++ "[" ++ r ++ "]"
314 | LStrTail <- op
315 , (arg:_) <- vars = let v = translateVariableName arg in
316 v ++ ".substr(1," ++ v ++ ".length-1)"
317 where
318 translateBinaryOp :: String -> LVar -> LVar -> String
319 translateBinaryOp f lhs rhs =
320 translateVariableName lhs
321 ++ f
322 ++ translateVariableName rhs
324translateExpression (SError msg) =
325 "(function(){throw \'" ++ msg ++ "\';})();"
327translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
328 "__IDRRT__.print(" ++ translateVariableName var ++ ");"
330translateExpression (SForeign _ _ fun args) =
331 fun
332 ++ "("
333 ++ intercalate "," (map (translateVariableName . snd) args)
334 ++ ");"
336translateExpression (SChkCase var cases) =
337 "(function(e){\n"
338 ++ intercalate " else " (map (translateCase "e") cases)
339 ++ "\n})("
340 ++ translateVariableName var
341 ++ ")"
343translateExpression (SCase var cases) =
344 "(function(e){\n"
345 ++ intercalate " else " (map (translateCase "e") cases)
346 ++ "\n})("
347 ++ translateVariableName var
348 ++ ")"
350translateExpression (SCon i name vars) =
351 concat [ "new __IDRRT__.Con("
352 , show i
353 , ",["
354 , intercalate "," $ map translateVariableName vars
355 , "])"
356 ]
358translateExpression (SUpdate var e) =
359 translateVariableName var ++ " = " ++ translateExpression e
361translateExpression (SProj var i) =
362 translateVariableName var ++ ".vars[" ++ show i ++"]"
364translateExpression SNothing = "null"
366translateExpression e =
367 "(function(){throw 'Not yet implemented: "
368 ++ filter (/= '\'') (show e)
369 ++ "';})()"
371translateCase :: String -> SAlt -> String
372translateCase _ (SDefaultCase e) =
373 createIfBlock "true" (translateExpression e)
375translateCase var (SConstCase ty e)
376 | ChType <- ty = matchHelper "Char"
377 | StrType <- ty = matchHelper "String"
378 | IType <- ty = matchHelper "Int"
379 | BIType <- ty = matchHelper "Integer"
380 | FlType <- ty = matchHelper "Float"
381 | PtrType <- ty = matchHelper "Pointer"
382 | Forgot <- ty = matchHelper "Forgot"
383 where
384 matchHelper tyName = translateTypeMatch var tyName e
386translateCase var (SConstCase cst@(BI _) e) =
387 let cond = var ++ ".equals(" ++ translateConstant cst ++ ")" in
388 createIfBlock cond (translateExpression e)
390translateCase var (SConstCase cst e) =
391 let cond = var ++ " == " ++ translateConstant cst in
392 createIfBlock cond (translateExpression e)
394translateCase var (SConCase a i name vars e) =
395 let isCon = var ++ " instanceof __IDRRT__.Con"
396 isI = show i ++ " == " ++ var ++ ".i"
397 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
398 args = ".apply(this," ++ var ++ ".vars)"
399 f b =
400 "(function("
401 ++ params
402 ++ "){\nreturn " ++ b ++ "\n})" ++ args
403 cond = intercalate " && " [isCon, isI] in
404 createIfBlock cond $ f (translateExpression e)
406translateTypeMatch :: String -> String -> SExp -> String
407translateTypeMatch var ty exp =
408 let e = translateExpression exp in
409 createIfBlock (var
410 ++ " instanceof __IDRRT__.Type && "
411 ++ var ++ ".type == '"++ ty ++"'") e
414createIfBlock cond e =
415 "if (" ++ cond ++") {\n"
416 ++ "return " ++ e
417 ++ ";\n}"
419createTailcall call =
420 "__IDRRT__.tailcall(function(){return " ++ call ++ "})"
422translateFunctionCall name vars =
423 concat (intersperse "." $ translateNamespace name)
424 ++ "."
425 ++ translateName name
426 ++ "("
427 ++ intercalate "," (map translateVariableName vars)
428 ++ ")"