git.iko.soy/Idris-dev
on 57628ff help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
326 lines 10 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 = do
30 let def = map (first translateNamespace) definitions
31 let output = idrRuntime ++ concatMap (translateModule Nothing) def ++ "\nMain.main()"
32 writeFile filename output
34idrRuntime :: String
35idrRuntime =
36 createModule Nothing idrNamespace $ concat
37 [ "__IDR__.IntType = { type: 'IntType' };"
38 , "__IDR__.Con = function(i,name,vars)"
39 , "{this.i = i;this.name = name;this.vars = vars;};"
40 ]
42createModule :: Maybe String -> NamespaceName -> String -> String
43createModule toplevel modname body =
44 concat [header modname, body, footer modname]
45 where
46 header :: NamespaceName -> String
47 header modname =
48 concatMap (++ "\n")
49 [ "\nvar " ++ modname ++ ";"
50 , "(function(" ++ modname ++ "){"
51 ]
53 footer :: NamespaceName -> String
54 footer modname =
55 let m = maybe "" (++ ".") toplevel ++ modname in
56 "\n})("
57 ++ m
58 ++ " || ("
59 ++ m
60 ++ " = {})"
61 ++ ");\n"
63translateModule :: Maybe String -> ([String], SDecl) -> String
64translateModule toplevel ([modname], decl) =
65 let body = translateDeclaration modname decl in
66 createModule toplevel modname body
67translateModule toplevel (n:ns, decl) =
68 createModule toplevel n $ translateModule (Just n) (ns, decl)
70translateIdentifier :: String -> String
71translateIdentifier =
72 concatMap replaceBadChars
73 where replaceBadChars :: Char -> String
74 replaceBadChars ' ' = "_"
75 replaceBadChars '@' = "__at__"
76 replaceBadChars '[' = "__OSB__"
77 replaceBadChars ']' = "__CSB__"
78 replaceBadChars '{' = "__OB__"
79 replaceBadChars '}' = "__CB__"
80 replaceBadChars '!' = "__bang__"
81 replaceBadChars '#' = "__hash__"
82 replaceBadChars '.' = "__dot__"
83 replaceBadChars ':' = "__colon__"
84 replaceBadChars '+' = "__plus__"
85 replaceBadChars '-' = "__minus__"
86 replaceBadChars '<' = "__lt__"
87 replaceBadChars '>' = "__gt__"
88 replaceBadChars '=' = "__eq__"
89 replaceBadChars '|' = "__pipe__"
90 replaceBadChars '\'' = "__apo__"
91 replaceBadChars c
92 | isDigit c = "__" ++ [c] ++ "__"
93 | otherwise = [c]
95translateNamespace :: Name -> [String]
96translateNamespace (UN _) = [idrNamespace]
97translateNamespace (NS _ ns) = map translateIdentifier ns
98translateNamespace (MN _ _) = [idrNamespace]
100translateName :: Name -> String
101translateName (UN name) = translateIdentifier name
102translateName (NS name _) = translateName name
103translateName (MN i name) = translateIdentifier name ++ show i
105translateQualifiedName :: Name -> String
106translateQualifiedName name =
107 intercalate "." (translateNamespace name) ++ "." ++ translateName name
109translateConstant :: Const -> String
110translateConstant (I i) = show i
111translateConstant (BI i) = show i
112translateConstant (Fl f) = show f
113translateConstant (Ch c) = show c
114translateConstant (Str s) = show s
115translateConstant IType = "__IDR__.IntType"
116translateConstant c =
117 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
119translateParameterlist =
120 map (\(MN i name) -> name ++ show i)
122translateDeclaration :: NamespaceName -> SDecl -> String
123translateDeclaration modname (SFun name params stackSize body) =
124 modname
125 ++ "."
126 ++ translateName name
127 ++ " = function("
128 ++ intercalate "," p
129 ++ "){\n"
130 ++ concatMap assignVar (zip [0..] p)
131 ++ concatMap allocVar [numP..(numP+stackSize-1)]
132 ++ "return "
133 ++ translateExpression modname body
134 ++ ";\n};\n"
135 where
136 numP :: Int
137 numP = length params
139 allocVar :: Int -> String
140 allocVar n = "var __var_" ++ show n ++ ";\n"
142 assignVar :: (Int, String) -> String
143 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
145 p :: [String]
146 p = translateParameterlist params
148translateVariableName :: LVar -> String
149translateVariableName (Loc i) =
150 "__var_" ++ show i
152translateExpression :: NamespaceName -> SExp -> String
153translateExpression modname (SLet name value body) =
154 "(function("
155 ++ translateVariableName name
156 ++ "){\nreturn "
157 ++ translateExpression modname body
158 ++ ";\n})("
159 ++ translateExpression modname value
160 ++ ")"
162translateExpression _ (SConst cst) =
163 translateConstant cst
165translateExpression _ (SV var) =
166 translateVariableName var
168translateExpression modname (SApp tc name vars) =
169 concat (intersperse "." $ translateNamespace name)
170 ++ "."
171 ++ translateName name
172 ++ "("
173 ++ intercalate "," (map translateVariableName vars)
174 ++ ")"
176translateExpression _ (SOp op vars)
177 | LPlus <- op
178 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
179 | LMinus <- op
180 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
181 | LTimes <- op
182 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
183 | LDiv <- op
184 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
185 | LMod <- op
186 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
187 | LEq <- op
188 , (lhs:rhs:_) <- vars = translateBinaryOp "===" lhs rhs
189 | LLt <- op
190 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
191 | LLe <- op
192 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
193 | LGt <- op
194 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
195 | LGe <- op
196 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
198 | LFPlus <- op
199 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
200 | LFMinus <- op
201 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
202 | LFTimes <- op
203 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
204 | LFDiv <- op
205 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
206 | LFEq <- op
207 , (lhs:rhs:_) <- vars = translateBinaryOp "===" lhs rhs
208 | LFLt <- op
209 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
210 | LFLe <- op
211 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
212 | LFGt <- op
213 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
214 | LFGe <- op
215 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
217 | LBPlus <- op
218 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
219 | LBMinus <- op
220 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
221 | LBTimes <- op
222 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
223 | LBDiv <- op
224 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
225 | LBMod <- op
226 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
227 | LBEq <- op
228 , (lhs:rhs:_) <- vars = translateBinaryOp "===" lhs rhs
229 | LBLt <- op
230 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
231 | LBLe <- op
232 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
233 | LBGt <- op
234 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
235 | LBGe <- op
236 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
238 | LStrConcat <- op
239 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
241 | LIntStr <- op
242 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ");"
244 where
245 translateBinaryOp :: String -> LVar -> LVar -> String
246 translateBinaryOp f lhs rhs =
247 translateVariableName lhs
248 ++ f
249 ++ translateVariableName rhs
251translateExpression _ (SError msg) =
252 "(function(){throw \'" ++ msg ++ "\';})();"
254translateExpression _ (SForeign _ _ "putStr" [(FString, var)]) =
255 "console.log(" ++ translateVariableName var ++ ");"
257translateExpression _ (SForeign _ _ fun args) =
258 fun
259 ++ "("
260 ++ intercalate "," (map (translateVariableName . snd) args)
261 ++ ");"
263translateExpression modname (SChkCase var cases) =
264 "(function(e){\n"
265 ++ intercalate " else " (map (translateCase modname "e") cases)
266 ++ "\n})("
267 ++ translateVariableName var
268 ++ ")"
270translateExpression modname (SCase var cases) =
271 "(function(e){\n"
272 ++ intercalate " else " (map (translateCase modname "e") cases)
273 ++ "\n})("
274 ++ translateVariableName var
275 ++ ")"
277translateExpression _ (SCon i name vars) =
278 concat [ "new __IDR__.Con("
279 , show i
280 , ","
281 , '\'' : translateQualifiedName name ++ "\',["
282 , intercalate "," $ map translateVariableName vars
283 , "])"
284 ]
286translateExpression modname (SUpdate var e) =
287 "(function(){\nreturn ("
288 ++ translateVariableName var
289 ++ " = " ++ translateExpression modname e
290 ++ ");\n})()"
292translateExpression modname (SProj var i) =
293 "(function(){\nreturn "
294 ++ translateVariableName var ++ ".vars[" ++ show i ++"];\n})()"
296translateExpression _ SNothing = "null"
298translateExpression _ e =
299 "(function(){throw 'Not yet implemented: "
300 ++ filter (/= '\'') (show e)
301 ++ "';})()"
303translateCase :: String -> String -> SAlt -> String
304translateCase modname _ (SDefaultCase e) =
305 createIfBlock "true" (translateExpression modname e)
307translateCase modname var (SConstCase cst e) =
308 let cond = var ++ " === " ++ translateConstant cst in
309 createIfBlock cond (translateExpression modname e)
311translateCase modname var (SConCase a i name vars e) =
312 let isCon = var ++ " instanceof __IDR__.Con"
313 isI = show i ++ " === " ++ var ++ ".i"
314 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
315 args = ".apply(this," ++ var ++ ".vars)"
316 f b =
317 "(function("
318 ++ params
319 ++ "){\nreturn " ++ b ++ "\n})" ++ args
320 cond = intercalate " && " [isCon, isI] in
321 createIfBlock cond $ f (translateExpression modname e)
323createIfBlock cond e =
324 "if (" ++ cond ++") {\n"
325 ++ "return " ++ e
326 ++ ";\n}"