@@ -1,4 +1,6 @@
1−module IRTS.CodegenJavaScript (codegenJavaScript ) where
1+{-# LANGUAGE PatternGuards #-}
2+
3+module IRTS.CodegenJavaScript (codegenJavaScript) where
24
35import Idris.AbsSyntax
46import IRTS.Bytecode
@@ -9,51 +11,316 @@ import Core.TT
911import Paths_idris
1012import Util.System
1113
14+import Control.Arrow
1215import Data.Char
1316import Data.List
1417import System.IO
1518
19+type NamespaceName = String
20+
21+idrNamespace :: NamespaceName
22+idrNamespace = "__IDR__"
23+
1624codegenJavaScript
1725 :: [(Name, SDecl)]
1826 -> FilePath
1927 -> OutputType
2028 -> IO ()
2129codegenJavaScript definitions filename outputType = do
22− let body = concat $ map (translateDeclaration . snd) definitions
23− output = concat [header, body, footer]
30+ let def = map (first translateNamespace) definitions
31+ let output = idrRuntime ++ concatMap (translateModule Nothing) def ++ "\nMain.main()"
2432 writeFile filename output
2533
34+idrRuntime :: String
35+idrRuntime =
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+ ]
41+
42+createModule :: Maybe String -> NamespaceName -> String -> String
43+createModule 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+ ]
2652
27−header :: String
28−header =
29− concat $ map (\line -> line ++ "\n")
30− ["define(function(require) {",
31− "var m = {};"]
53+ footer :: NamespaceName -> String
54+ footer modname =
55+ let m = maybe "" (++ ".") toplevel ++ modname in
56+ "\n})("
57+ ++ m
58+ ++ " || ("
59+ ++ m
60+ ++ " = {})"
61+ ++ ");\n"
3262
63+translateModule :: Maybe String -> ([String], SDecl) -> String
64+translateModule toplevel ([modname], decl) =
65+ let body = translateDeclaration modname decl in
66+ createModule toplevel modname body
67+translateModule toplevel (n:ns, decl) =
68+ createModule toplevel n $ translateModule (Just n) (ns, decl)
3369
34−footer :: String
35−footer =
36− concat $ map (\line -> line ++ "\n")
37− ["return m;",
38− "});"]
70+translateIdentifier :: String -> String
71+translateIdentifier =
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]
3994
95+translateNamespace :: Name -> [String]
96+translateNamespace (UN _) = [idrNamespace]
97+translateNamespace (NS _ ns) = map translateIdentifier ns
98+translateNamespace (MN _ _) = [idrNamespace]
4099
41100translateName :: Name -> String
42−translateName = show
101+translateName (UN name) = translateIdentifier name
102+translateName (NS name _) = translateName name
103+translateName (MN i name) = translateIdentifier name ++ show i
104+
105+translateQualifiedName :: Name -> String
106+translateQualifiedName name =
107+ intercalate "." (translateNamespace name) ++ "." ++ translateName name
108+
109+translateConstant :: Const -> String
110+translateConstant (I i) = show i
111+translateConstant (BI i) = show i
112+translateConstant (Fl f) = show f
113+translateConstant (Ch c) = show c
114+translateConstant (Str s) = show s
115+translateConstant IType = "__IDR__.IntType"
116+translateConstant c =
117+ "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
118+
119+translateParameterlist =
120+ map (\(MN i name) -> name ++ show i)
121+
122+translateDeclaration :: NamespaceName -> SDecl -> String
123+translateDeclaration 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
138+
139+ allocVar :: Int -> String
140+ allocVar n = "var __var_" ++ show n ++ ";\n"
141+
142+ assignVar :: (Int, String) -> String
143+ assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
144+
145+ p :: [String]
146+ p = translateParameterlist params
147+
148+translateVariableName :: LVar -> String
149+translateVariableName (Loc i) =
150+ "__var_" ++ show i
151+
152+translateExpression :: NamespaceName -> SExp -> String
153+translateExpression modname (SLet name value body) =
154+ "(function("
155+ ++ translateVariableName name
156+ ++ "){\nreturn "
157+ ++ translateExpression modname body
158+ ++ ";\n})("
159+ ++ translateExpression modname value
160+ ++ ")"
161+
162+translateExpression _ (SConst cst) =
163+ translateConstant cst
164+
165+translateExpression _ (SV var) =
166+ translateVariableName var
167+
168+translateExpression modname (SApp tc name vars) =
169+ concat (intersperse "." $ translateNamespace name)
170+ ++ "."
171+ ++ translateName name
172+ ++ "("
173+ ++ intercalate "," (map translateVariableName vars)
174+ ++ ")"
175+
176+translateExpression _ (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
197+
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
216+
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
237+
238+ | LStrConcat <- op
239+ , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
240+
241+ | LIntStr <- op
242+ , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ");"
243+
244+ where
245+ translateBinaryOp :: String -> LVar -> LVar -> String
246+ translateBinaryOp f lhs rhs =
247+ translateVariableName lhs
248+ ++ f
249+ ++ translateVariableName rhs
250+
251+translateExpression _ (SError msg) =
252+ "(function(){throw \'" ++ msg ++ "\';})();"
253+
254+translateExpression _ (SForeign _ _ "putStr" [(FString, var)]) =
255+ "console.log(" ++ translateVariableName var ++ ");"
256+
257+translateExpression _ (SForeign _ _ fun args) =
258+ fun
259+ ++ "("
260+ ++ intercalate "," (map (translateVariableName . snd) args)
261+ ++ ");"
262+
263+translateExpression modname (SChkCase var cases) =
264+ "(function(e){\n"
265+ ++ intercalate " else " (map (translateCase modname "e") cases)
266+ ++ "\n})("
267+ ++ translateVariableName var
268+ ++ ")"
269+
270+translateExpression modname (SCase var cases) =
271+ "(function(e){\n"
272+ ++ intercalate " else " (map (translateCase modname "e") cases)
273+ ++ "\n})("
274+ ++ translateVariableName var
275+ ++ ")"
276+
277+translateExpression _ (SCon i name vars) =
278+ concat [ "new __IDR__.Con("
279+ , show i
280+ , ","
281+ , '\'' : translateQualifiedName name ++ "\',["
282+ , intercalate "," $ map translateVariableName vars
283+ , "])"
284+ ]
285+
286+translateExpression modname (SUpdate var e) =
287+ "(function(){\nreturn ("
288+ ++ translateVariableName var
289+ ++ " = " ++ translateExpression modname e
290+ ++ ");\n})()"
291+
292+translateExpression modname (SProj var i) =
293+ "(function(){\nreturn "
294+ ++ translateVariableName var ++ ".vars[" ++ show i ++"];\n})()"
295+
296+translateExpression _ SNothing = "null"
297+
298+translateExpression _ e =
299+ "(function(){throw 'Not yet implemented: "
300+ ++ filter (/= '\'') (show e)
301+ ++ "';})()"
43302
303+translateCase :: String -> String -> SAlt -> String
304+translateCase modname _ (SDefaultCase e) =
305+ createIfBlock "true" (translateExpression modname e)
44306
45−translateDeclaration :: SDecl -> String
46−translateDeclaration (SFun name parameterNames stackSize body) =
47− concat ["m[\"", translateName name, "\"] = function(s) { ",
48− translateExpression body, " ",
49− intercalate " " $ take (length parameterNames) $ repeat "s.pop();",
50− " };\n"]
307+translateCase modname var (SConstCase cst e) =
308+ let cond = var ++ " === " ++ translateConstant cst in
309+ createIfBlock cond (translateExpression modname e)
51310
311+translateCase 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)
52322
53−translateExpression :: SExp -> String
54−translateExpression (SLet name value body) =
55− intercalate " "
56− $ [translateExpression value,
57− translateExpression body,
58− "s.pop();", "s.pop();"]
59−translateExpression _ = "..."
323+createIfBlock cond e =
324+ "if (" ++ cond ++") {\n"
325+ ++ "return " ++ e
326+ ++ ";\n}"