@@ -1,6 +1,9 @@
11{-# LANGUAGE PatternGuards #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
34
5+import IRTS.JavaScript.AST
6+
47import Idris.AbsSyntax hiding (TypeCase)
58import IRTS.Bytecode
69import IRTS.Lang
@@ -25,6 +28,8 @@ import System.IO
2528import System.Directory
2629
2730import qualified Data.Map.Strict as M
31+import qualified Data.Text as T
32+import qualified Data.Text.IO as TIO
2833
2934
3035data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
@@ -79,290 +84,6 @@ initCompileInfo bc =
7984data JSTarget = Node | JavaScript deriving Eq
8085
8186
82−data JSType = JSIntTy
83− | JSStringTy
84− | JSIntegerTy
85− | JSFloatTy
86− | JSCharTy
87− | JSPtrTy
88− | JSForgotTy
89− deriving Eq
90−
91−
92−data JSInteger = JSBigZero
93− | JSBigOne
94− | JSBigInt Integer
95− | JSBigIntExpr JS
96− deriving Eq
97−
98−
99−data JSNum = JSInt Int
100− | JSFloat Double
101− | JSInteger JSInteger
102− deriving Eq
103−
104−
105−data JSWord = JSWord8 Word8
106− | JSWord16 Word16
107− | JSWord32 Word32
108− | JSWord64 Word64
109− deriving Eq
110−
111−
112−data JSAnnotation = JSConstructor deriving Eq
113−
114−
115−instance Show JSAnnotation where
116− show JSConstructor = "constructor"
117−
118−
119−data JS = JSRaw String
120− | JSIdent String
121− | JSFunction [String] JS
122− | JSType JSType
123− | JSSeq [JS]
124− | JSReturn JS
125− | JSApp JS [JS]
126− | JSNew String [JS]
127− | JSError String
128− | JSBinOp String JS JS
129− | JSPreOp String JS
130− | JSPostOp String JS
131− | JSProj JS String
132− | JSNull
133− | JSUndefined
134− | JSThis
135− | JSTrue
136− | JSFalse
137− | JSArray [JS]
138− | JSString String
139− | JSNum JSNum
140− | JSWord JSWord
141− | JSAssign JS JS
142− | JSAlloc String (Maybe JS)
143− | JSIndex JS JS
144− | JSSwitch JS [(JS, JS)] (Maybe JS)
145− | JSCond [(JS, JS)]
146− | JSTernary JS JS JS
147− | JSParens JS
148− | JSWhile JS JS
149− | JSFFI String [JS]
150− | JSAnnotation JSAnnotation JS
151− | JSNoop
152− deriving Eq
153−
154−
155−data FFI = FFICode Char | FFIArg Int | FFIError String
156−
157−ffi :: String -> [String] -> String
158−ffi code args = let parsed = ffiParse code in
159− case ffiError parsed of
160− Just err -> error err
161− Nothing -> renderFFI parsed args
162− where
163− ffiParse :: String -> [FFI]
164− ffiParse "" = []
165− ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
166− ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
167− ffiParse ('%':s:ss)
168− | isDigit s =
169− FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
170− | otherwise =
171− [FFIError "FFI - Invalid positional argument"]
172− ffiParse (s:ss) = FFICode s : ffiParse ss
173−
174−
175− ffiError :: [FFI] -> Maybe String
176− ffiError [] = Nothing
177− ffiError ((FFIError s):xs) = Just s
178− ffiError (x:xs) = ffiError xs
179−
180−
181− renderFFI :: [FFI] -> [String] -> String
182− renderFFI [] _ = ""
183− renderFFI (FFICode c : fs) args = c : renderFFI fs args
184− renderFFI (FFIArg i : fs) args
185− | i < length args && i >= 0 = args !! i ++ renderFFI fs args
186− | otherwise = error "FFI - Argument index out of bounds"
187−
188−compileJS :: JS -> String
189−compileJS = compileJS' 0
190−
191−compileJS' :: Int -> JS -> String
192−compileJS' indent JSNoop = ""
193−
194−compileJS' indent (JSAnnotation annotation js) =
195− "/** @" ++ show annotation ++ " */\n" ++ compileJS' indent js
196−
197−compileJS' indent (JSFFI raw args) =
198− ffi raw (map (compileJS' indent) args)
199−
200−compileJS' indent (JSRaw code) =
201− code
202−
203−compileJS' indent (JSIdent ident) =
204− ident
205−
206−compileJS' indent (JSFunction args body) =
207− replicate indent ' ' ++ "function("
208− ++ intercalate "," args
209− ++ "){\n"
210− ++ compileJS' (indent + 2) body
211− ++ "\n}\n"
212−
213−compileJS' indent (JSType ty)
214− | JSIntTy <- ty = "i$Int"
215− | JSStringTy <- ty = "i$String"
216− | JSIntegerTy <- ty = "i$Integer"
217− | JSFloatTy <- ty = "i$Float"
218− | JSCharTy <- ty = "i$Char"
219− | JSPtrTy <- ty = "i$Ptr"
220− | JSForgotTy <- ty = "i$Forgot"
221−
222−compileJS' indent (JSSeq seq) =
223− intercalate ";\n" (
224− map (
225− (replicate indent ' ' ++) . (compileJS' indent)
226− ) $ filter (/= JSNoop) seq
227− ) ++ ";"
228−
229−compileJS' indent (JSReturn val) =
230− "return " ++ compileJS' indent val
231−
232−compileJS' indent (JSApp lhs rhs)
233− | JSFunction {} <- lhs =
234− concat ["(", compileJS' indent lhs, ")(", args, ")"]
235− | otherwise =
236− concat [compileJS' indent lhs, "(", args, ")"]
237− where args :: String
238− args = intercalate "," $ map (compileJS' 0) rhs
239−
240−compileJS' indent (JSNew name args) =
241− "new " ++ name ++ "(" ++ intercalate "," (map (compileJS' 0) args) ++ ")"
242−
243−compileJS' indent (JSError exc) =
244− "throw new Error(\"" ++ exc ++ "\")"
245−
246−compileJS' indent (JSBinOp op lhs rhs) =
247− compileJS' indent lhs ++ " " ++ op ++ " " ++ compileJS' indent rhs
248−
249−compileJS' indent (JSPreOp op val) =
250− op ++ compileJS' indent val
251−
252−compileJS' indent (JSProj obj field)
253− | JSFunction {} <- obj =
254− concat ["(", compileJS' indent obj, ").", field]
255− | JSAssign {} <- obj =
256− concat ["(", compileJS' indent obj, ").", field]
257− | otherwise =
258− compileJS' indent obj ++ '.' : field
259−
260−compileJS' indent JSNull =
261− "null"
262−
263−compileJS' indent JSUndefined =
264− "undefined"
265−
266−compileJS' indent JSThis =
267− "this"
268−
269−compileJS' indent JSTrue =
270− "true"
271−
272−compileJS' indent JSFalse =
273− "false"
274−
275−compileJS' indent (JSArray elems) =
276− "[" ++ intercalate "," (map (compileJS' 0) elems) ++ "]"
277−
278−compileJS' indent (JSString str) =
279− "\"" ++ str ++ "\""
280−
281−compileJS' indent (JSNum num)
282− | JSInt i <- num = show i
283− | JSFloat f <- num = show f
284− | JSInteger JSBigZero <- num = "i$ZERO"
285− | JSInteger JSBigOne <- num = "i$ONE"
286− | JSInteger (JSBigInt i) <- num = show i
287− | JSInteger (JSBigIntExpr e) <- num = "i$bigInt(" ++ compileJS' indent e ++ ")"
288−
289−compileJS' indent (JSAssign lhs rhs) =
290− compileJS' indent lhs ++ " = " ++ compileJS' indent rhs
291−
292−compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
293− "var " ++ name ++ " = " ++ compileJS' 0 val ++ ";\n"
294−
295−compileJS' indent (JSAlloc name val) =
296− "var " ++ name ++ maybe "" ((" = " ++) . compileJS' indent) val
297−
298−compileJS' indent (JSIndex lhs rhs) =
299− compileJS' indent lhs ++ "[" ++ compileJS' indent rhs ++ "]"
300−
301−compileJS' indent (JSCond branches) =
302− intercalate " else " $ map createIfBlock branches
303− where
304− createIfBlock (JSNoop, e@(JSSeq _)) =
305− "{\n"
306− ++ compileJS' (indent + 2) e
307− ++ "\n" ++ replicate indent ' ' ++ "}"
308− createIfBlock (JSNoop, e) =
309− "{\n"
310− ++ compileJS' (indent + 2) e
311− ++ ";\n" ++ replicate indent ' ' ++ "}"
312− createIfBlock (cond, e@(JSSeq _)) =
313− "if (" ++ compileJS' indent cond ++") {\n"
314− ++ compileJS' (indent + 2) e
315− ++ "\n" ++ replicate indent ' ' ++ "}"
316− createIfBlock (cond, e) =
317− "if (" ++ compileJS' indent cond ++") {\n"
318− ++ replicate (indent + 2) ' ' ++ compileJS' (indent + 2) e
319− ++ ";\n" ++ replicate indent ' ' ++ "}"
320−
321−compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
322− let (h,t) = splitAt 1 seq in
323− (concatMap (compileJS' indent) h ++ ";\n")
324− ++ (intercalate ";\n" $ map ((replicate indent ' ' ++) . compileJS' indent) t)
325−
326−compileJS' indent (JSSwitch val branches def) =
327− "switch(" ++ compileJS' indent val ++ "){\n"
328− ++ concatMap mkBranch branches
329− ++ mkDefault def
330− ++ replicate indent ' ' ++ "}"
331− where
332− mkBranch :: (JS, JS) -> String
333− mkBranch (tag, code) =
334− replicate (indent + 2) ' ' ++ "case " ++ compileJS' indent tag ++ ":\n"
335− ++ compileJS' (indent + 4) code
336− ++ "\n" ++ (replicate (indent + 4) ' ' ++ "break;\n")
337−
338− mkDefault :: Maybe JS -> String
339− mkDefault Nothing = ""
340− mkDefault (Just def) =
341− replicate (indent + 2) ' ' ++ "default:\n"
342− ++ compileJS' (indent + 4)def
343− ++ "\n"
344−
345−
346−compileJS' indent (JSTernary cond true false) =
347− let c = compileJS' indent cond
348− t = compileJS' indent true
349− f = compileJS' indent false in
350− "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
351−
352−compileJS' indent (JSParens js) =
353− "(" ++ compileJS' indent js ++ ")"
354−
355−compileJS' indent (JSWhile cond body) =
356− "while (" ++ compileJS' indent cond ++ ") {\n"
357− ++ compileJS' (indent + 2) body
358− ++ "\n" ++ replicate indent ' ' ++ "}"
359−
360−compileJS' indent (JSWord word)
361− | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
362− | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
363− | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
364− | JSWord64 b <- word = "i$bigInt(\"" ++ show b ++ "\")"
365−
36687codegenJavaScript :: CodeGenerator
36788codegenJavaScript ci =
36889 codegenJS_all JavaScript (simpleDecls ci)
@@ -406,12 +127,12 @@ codegenJS_all target definitions includes libs filename outputType = do
406127 ++ idrRuntime
407128 ++ tgtRuntime
408129 )
409− writeFile filename ( runtime
410− ++ concatMap compileJS opt
411− ++ concatMap compileJS cons
412− ++ main
413− ++ invokeMain
414− )
130+ TIO.writeFile filename ( T.pack runtime
131+ `T.append` T.concat (map compileJS opt)
132+ `T.append` T.concat (map compileJS cons)
133+ `T.append` main
134+ `T.append` invokeMain
135+ )
415136 setPermissions filename (emptyPermissions { readable = True
416137 , executable = target == Node
417138 , writable = True
@@ -478,7 +199,7 @@ codegenJS_all target definitions includes libs filename outputType = do
478199 getIncludes :: [FilePath] -> IO [String]
479200 getIncludes = mapM readFile
480201
481− main :: String
202+ main :: T.Text
482203 main =
483204 compileJS $ JSAlloc "main" (Just $
484205 JSFunction [] (
@@ -532,7 +253,7 @@ codegenJS_all target definitions includes libs filename outputType = do
532253 )
533254 ]
534255
535− invokeMain :: String
256+ invokeMain :: T.Text
536257 invokeMain = compileJS $ JSApp (JSIdent "main") []
537258
538259optimizeConstructors :: [JS] -> ([JS], [JS])
@@ -890,64 +611,6 @@ jsMKCON info r t rs =
890611 ]
891612 )
892613
893−jsInstanceOf :: JS -> String -> JS
894−jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
895−
896−jsOr :: JS -> JS -> JS
897−jsOr lhs rhs = JSBinOp "||" lhs rhs
898−
899−jsAnd :: JS -> JS -> JS
900−jsAnd lhs rhs = JSBinOp "&&" lhs rhs
901−
902−jsMeth :: JS -> String -> [JS] -> JS
903−jsMeth obj meth args = JSApp (JSProj obj meth) args
904−
905−jsCall :: String -> [JS] -> JS
906−jsCall fun args = JSApp (JSIdent fun) args
907−
908−jsTypeOf :: JS -> JS
909−jsTypeOf js = JSPreOp "typeof " js
910−
911−jsEq :: JS -> JS -> JS
912−jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
913−jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
914−jsEq lhs rhs = JSBinOp "==" lhs rhs
915−
916−jsNotEq :: JS -> JS -> JS
917−jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
918−
919−jsIsNumber :: JS -> JS
920−jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
921−
922−jsIsNull :: JS -> JS
923−jsIsNull js = JSBinOp "==" js JSNull
924−
925−jsBigInt :: JS -> JS
926−jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
927−jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
928−jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
929−
930−jsUnPackBits :: JS -> JS
931−jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
932−
933−jsPackUBits8 :: JS -> JS
934−jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
935−
936−jsPackUBits16 :: JS -> JS
937−jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
938−
939−jsPackUBits32 :: JS -> JS
940−jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
941−
942−jsPackSBits8 :: JS -> JS
943−jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
944−
945−jsPackSBits16 :: JS -> JS
946−jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
947−
948−jsPackSBits32 :: JS -> JS
949−jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
950−
951614jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
952615jsCASE info safe reg cases def =
953616 JSSwitch (tag safe $ translateReg reg) (