git.iko.soy/Idris-dev
on 45adece help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
418 lines 13 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 System.IO
19type NamespaceName = String
21idrNamespace :: NamespaceName
22idrNamespace = "__IDR__"
24codegenJavaScript
25 :: [(Name, SDecl)]
26 -> FilePath
27 -> OutputType
28 -> IO ()
29codegenJavaScript definitions filename outputType =
30 writeFile filename output
31 where
32 def = map (first translateNamespace) definitions
34 mainLoop :: String
35 mainLoop = intercalate "\n" [ "\nfunction main() {"
36 , createTailcall "__IDR__.runMain0()"
37 , "}\n\nmain();\n"
38 ]
40 output :: String
41 output = concat [ idrRuntime
42 , concatMap (translateModule Nothing) def
43 , mainLoop
44 ]
46idrRuntime :: String
47idrRuntime =
48 createModule Nothing idrNamespace $ concat
49 [ "__IDR__.Type = function(type) { this.type = type; };"
50 , "__IDR__.Int = new __IDR__.Type('Int');"
51 , "__IDR__.Char = new __IDR__.Type('Char');"
52 , "__IDR__.String = new __IDR__.Type('String');"
53 , "__IDR__.Integer = new __IDR__.Type('Integer');"
54 , "__IDR__.Float = new __IDR__.Type('Float');"
55 , "__IDR__.Forgot = new __IDR__.Type('Forgot');"
57 , "__IDR__.Tailcall = function(f) { this.f = f };"
59 , "__IDR__.Con = function(i,name,vars)"
60 , "{this.i = i;this.name = name;this.vars = vars;};\n"
62 , "__IDR__.tailcall = function(f){\n"
63 ++ "var __f = f;\n"
64 ++ "while (__f) {\n"
65 ++ "var f = __f;\n"
66 ++ "__f = null;\n"
67 ++ "var ret = f();\n"
68 ++ "if (ret instanceof __IDR__.Tailcall) {\n"
69 ++ "__f = ret.f;"
70 ++ "\n} else {\n"
71 ++ "return ret;"
72 ++ "\n}"
73 ++ "\n}"
74 ++ "\n};\n"
76 , "var newline_regex =/(.*)\\n$/;\n"
78 , "__IDR__.print = function(s){\n"
79 ++ "var m = s.match(newline_regex);\n"
80 ++ "console.log(m ? m[1] : s);"
81 ++ "\n};\n"
82 ]
84createModule :: Maybe String -> NamespaceName -> String -> String
85createModule toplevel modname body =
86 concat [header modname, body, footer modname]
87 where
88 header :: NamespaceName -> String
89 header modname =
90 concatMap (++ "\n")
91 [ "\nvar " ++ modname ++ ";"
92 , "(function(" ++ modname ++ "){"
93 ]
95 footer :: NamespaceName -> String
96 footer modname =
97 let m = maybe "" (++ ".") toplevel ++ modname in
98 "\n})("
99 ++ m
100 ++ " || ("
101 ++ m
102 ++ " = {})"
103 ++ ");\n"
105translateModule :: Maybe String -> ([String], SDecl) -> String
106translateModule toplevel ([modname], decl) =
107 let body = translateDeclaration modname decl in
108 createModule toplevel modname body
109translateModule toplevel (n:ns, decl) =
110 createModule toplevel n $ translateModule (Just n) (ns, decl)
112translateIdentifier :: String -> String
113translateIdentifier =
114 concatMap replaceBadChars
115 where replaceBadChars :: Char -> String
116 replaceBadChars ' ' = "_"
117 replaceBadChars '_' = "__"
118 replaceBadChars '@' = "_at"
119 replaceBadChars '[' = "_OSB"
120 replaceBadChars ']' = "_CSB"
121 replaceBadChars '(' = "_OP"
122 replaceBadChars ')' = "_CP"
123 replaceBadChars '{' = "_OB"
124 replaceBadChars '}' = "_CB"
125 replaceBadChars '!' = "_bang"
126 replaceBadChars '#' = "_hash"
127 replaceBadChars '.' = "_dot"
128 replaceBadChars ',' = "_comma"
129 replaceBadChars ':' = "_colon"
130 replaceBadChars '+' = "_plus"
131 replaceBadChars '-' = "_minus"
132 replaceBadChars '*' = "_times"
133 replaceBadChars '<' = "_lt"
134 replaceBadChars '>' = "_gt"
135 replaceBadChars '=' = "_eq"
136 replaceBadChars '|' = "_pipe"
137 replaceBadChars '&' = "_amp"
138 replaceBadChars '\'' = "_apo"
139 replaceBadChars c
140 | isDigit c = "_" ++ [c] ++ "_"
141 | otherwise = [c]
143translateNamespace :: Name -> [String]
144translateNamespace (UN _) = [idrNamespace]
145translateNamespace (NS _ ns) = idrNamespace : map translateIdentifier ns
146translateNamespace (MN _ _) = [idrNamespace]
148translateName :: Name -> String
149translateName (UN name) = translateIdentifier name
150translateName (NS name _) = translateName name
151translateName (MN i name) = translateIdentifier name ++ show i
153translateQualifiedName :: Name -> String
154translateQualifiedName name =
155 intercalate "." (translateNamespace name) ++ "." ++ translateName name
157translateConstant :: Const -> String
158translateConstant (I i) = show i
159translateConstant (BI i) = show i
160translateConstant (Fl f) = show f
161translateConstant (Ch c) = show c
162translateConstant (Str s) = show s
163translateConstant IType = "__IDR__.Int"
164translateConstant ChType = "__IDR__.Char"
165translateConstant StrType = "__IDR__.String"
166translateConstant BIType = "__IDR__.Integer"
167translateConstant FlType = "__IDR__.Float"
168translateConstant Forgot = "__IDR__.Forgot"
169translateConstant c =
170 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
172translateParameterlist =
173 map translateParameter
174 where translateParameter (MN i name) = name ++ show i
175 translateParameter (UN name) = name
177translateDeclaration :: NamespaceName -> SDecl -> String
178translateDeclaration modname (SFun name params stackSize body) =
179 modname
180 ++ "."
181 ++ translateName name
182 ++ " = function("
183 ++ intercalate "," p
184 ++ "){\n"
185 ++ concatMap assignVar (zip [0..] p)
186 ++ concatMap allocVar [numP..(numP+stackSize-1)]
187 ++ "return "
188 ++ translateExpression modname body
189 ++ ";\n};\n"
190 where
191 numP :: Int
192 numP = length params
194 allocVar :: Int -> String
195 allocVar n = "var __var_" ++ show n ++ ";\n"
197 assignVar :: (Int, String) -> String
198 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
200 p :: [String]
201 p = translateParameterlist params
203translateVariableName :: LVar -> String
204translateVariableName (Loc i) =
205 "__var_" ++ show i
207translateExpression :: NamespaceName -> SExp -> String
208translateExpression modname (SLet name value body) =
209 "(function("
210 ++ translateVariableName name
211 ++ "){\nreturn "
212 ++ translateExpression modname body
213 ++ ";\n})("
214 ++ translateExpression modname value
215 ++ ")"
217translateExpression _ (SConst cst) =
218 translateConstant cst
220translateExpression _ (SV var) =
221 translateVariableName var
223translateExpression modname (SApp False name vars) =
224 createTailcall $ translateFunctionCall name vars
226translateExpression modname (SApp True name vars) =
227 "(function(){\n"
228 ++ "return new __IDR__.Tailcall("
229 ++ "function(){\n"
230 ++ "return " ++ translateFunctionCall name vars
231 ++ ";\n});"
232 ++ "\n})()"
234translateExpression _ (SOp op vars)
235 | LPlus <- op
236 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
237 | LMinus <- op
238 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
239 | LTimes <- op
240 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
241 | LDiv <- op
242 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
243 | LMod <- op
244 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
245 | LEq <- op
246 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
247 | LLt <- op
248 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
249 | LLe <- op
250 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
251 | LGt <- op
252 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
253 | LGe <- op
254 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
256 | LFPlus <- op
257 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
258 | LFMinus <- op
259 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
260 | LFTimes <- op
261 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
262 | LFDiv <- op
263 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
264 | LFEq <- op
265 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
266 | LFLt <- op
267 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
268 | LFLe <- op
269 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
270 | LFGt <- op
271 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
272 | LFGe <- op
273 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
275 | LBPlus <- op
276 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
277 | LBMinus <- op
278 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
279 | LBTimes <- op
280 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
281 | LBDiv <- op
282 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
283 | LBMod <- op
284 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
285 | LBEq <- op
286 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
287 | LBLt <- op
288 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
289 | LBLe <- op
290 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
291 | LBGt <- op
292 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
293 | LBGe <- op
294 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
296 | LStrHead <- op
297 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
298 | LStrTail <- op
299 , (arg:_) <- vars = let v = translateVariableName arg in
300 v ++ ".substr(1," ++ v ++ ".length-1)"
301 | LStrConcat <- op
302 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
303 | LStrEq <- op
304 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
305 | LStrCons <- op
306 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
308 | LIntStr <- op
309 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ");"
311 where
312 translateBinaryOp :: String -> LVar -> LVar -> String
313 translateBinaryOp f lhs rhs =
314 translateVariableName lhs
315 ++ f
316 ++ translateVariableName rhs
318translateExpression _ (SError msg) =
319 "(function(){throw \'" ++ msg ++ "\';})();"
321translateExpression _ (SForeign _ _ "putStr" [(FString, var)]) =
322 "__IDR__.print(" ++ translateVariableName var ++ ");"
324translateExpression _ (SForeign _ _ fun args) =
325 fun
326 ++ "("
327 ++ intercalate "," (map (translateVariableName . snd) args)
328 ++ ");"
330translateExpression modname (SChkCase var cases) =
331 "(function(e){\n"
332 ++ intercalate " else " (map (translateCase modname "e") cases)
333 ++ "\n})("
334 ++ translateVariableName var
335 ++ ")"
337translateExpression modname (SCase var cases) =
338 "(function(e){\n"
339 ++ intercalate " else " (map (translateCase modname "e") cases)
340 ++ "\n})("
341 ++ translateVariableName var
342 ++ ")"
344translateExpression _ (SCon i name vars) =
345 concat [ "new __IDR__.Con("
346 , show i
347 , ","
348 , '\'' : translateQualifiedName name ++ "\',["
349 , intercalate "," $ map translateVariableName vars
350 , "])"
351 ]
353translateExpression modname (SUpdate var e) =
354 translateVariableName var ++ " = " ++ translateExpression modname e
356translateExpression modname (SProj var i) =
357 translateVariableName var ++ ".vars[" ++ show i ++"]"
359translateExpression _ SNothing = "null"
361translateExpression _ e =
362 "(function(){throw 'Not yet implemented: "
363 ++ filter (/= '\'') (show e)
364 ++ "';})()"
366translateCase :: String -> String -> SAlt -> String
367translateCase modname _ (SDefaultCase e) =
368 createIfBlock "true" (translateExpression modname e)
370translateCase modname var (SConstCase ty e)
371 | ChType <- ty = matchHelper "Char"
372 | StrType <- ty = matchHelper "String"
373 | IType <- ty = matchHelper "Int"
374 | BIType <- ty = matchHelper "Integer"
375 | FlType <- ty = matchHelper "Float"
376 | Forgot <- ty = matchHelper "Forgot"
377 where
378 matchHelper tyName = translateTypeMatch modname var tyName e
380translateCase modname var (SConstCase cst e) =
381 let cond = var ++ " == " ++ translateConstant cst in
382 createIfBlock cond (translateExpression modname e)
384translateCase modname var (SConCase a i name vars e) =
385 let isCon = var ++ " instanceof __IDR__.Con"
386 isI = show i ++ " == " ++ var ++ ".i"
387 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
388 args = ".apply(this," ++ var ++ ".vars)"
389 f b =
390 "(function("
391 ++ params
392 ++ "){\nreturn " ++ b ++ "\n})" ++ args
393 cond = intercalate " && " [isCon, isI] in
394 createIfBlock cond $ f (translateExpression modname e)
396translateTypeMatch :: String -> String -> String -> SExp -> String
397translateTypeMatch modname var ty exp =
398 let e = translateExpression modname exp in
399 createIfBlock (var
400 ++ " instanceof __IDR__.Type && "
401 ++ var ++ ".type == '"++ ty ++"'") e
404createIfBlock cond e =
405 "if (" ++ cond ++") {\n"
406 ++ "return " ++ e
407 ++ ";\n}"
409createTailcall call =
410 "__IDR__.tailcall(function(){return " ++ call ++ "})"
412translateFunctionCall name vars =
413 concat (intersperse "." $ translateNamespace name)
414 ++ "."
415 ++ translateName name
416 ++ "("
417 ++ intercalate "," (map translateVariableName vars)
418 ++ ")"