git.iko.soy/Idris-dev
on master help sign in
Merge pull request #947 from raichoo/javascript
1ffa80dEdwin Brady
src/IRTS/CodegenJavaScript.hs+84−53
compare with master
unifiedsplit
@@ -52,6 +52,13 @@ data JSNum = JSInt Int
52 deriving Eq
52 deriving Eq
53
53
54
54
55+data JSAnnotation = JSConstructor deriving Eq
56+
57+
58+instance Show JSAnnotation where
59+ show JSConstructor = "constructor"
60+
61+
55data JS = JSRaw String
62data JS = JSRaw String
56 | JSIdent String
63 | JSIdent String
57 | JSFunction [String] JS
64 | JSFunction [String] JS
@@ -80,13 +87,56 @@ data JS = JSRaw String
80 | JSTernary JS JS JS
87 | JSTernary JS JS JS
81 | JSParens JS
88 | JSParens JS
82 | JSWhile JS JS
89 | JSWhile JS JS
90+ | JSFFI String [JS]
91+ | JSAnnotation JSAnnotation JS
83 | JSNoop
92 | JSNoop
84 deriving Eq
93 deriving Eq
85
94
86
95
96+data FFI = FFICode Char | FFIArg Int | FFIError String
97+
98+
99+ffi :: String -> [String] -> String
100+ffi code args = let parsed = ffiParse code in
101+ case ffiError parsed of
102+ Just err -> compileJS $ jsError err
103+ Nothing -> renderFFI parsed args
104+ where
105+ ffiParse :: String -> [FFI]
106+ ffiParse "" = []
107+ ffiParse ['%'] = [FFIError "Invalid positional argument"]
108+ ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
109+ ffiParse ('%':s:ss)
110+ | isDigit s =
111+ FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
112+ | otherwise =
113+ [FFIError "Invalid positional argument"]
114+ ffiParse (s:ss) = FFICode s : ffiParse ss
115+
116+
117+ ffiError :: [FFI] -> Maybe String
118+ ffiError [] = Nothing
119+ ffiError ((FFIError s):xs) = Just s
120+ ffiError (x:xs) = ffiError xs
121+
122+
123+ renderFFI :: [FFI] -> [String] -> String
124+ renderFFI [] _ = ""
125+ renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
126+ renderFFI ((FFIArg i) : fs) args
127+ | i < length args && i >= 0 = args !! i ++ renderFFI fs args
128+ | otherwise = "Argument index out of bounds"
129+
130+
87compileJS :: JS -> String
131compileJS :: JS -> String
88compileJS JSNoop = ""
132compileJS JSNoop = ""
89
133
134+compileJS (JSAnnotation annotation js) =
135+ "/** @" ++ show annotation ++ " */\n" ++ compileJS js
136+
137+compileJS (JSFFI raw args) =
138+ ffi raw (map compileJS args)
139+
90compileJS (JSRaw code) =
140compileJS (JSRaw code) =
91 code
141 code
92
142
@@ -316,6 +366,10 @@ foldJS tr add acc js =
316 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
366 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
317 | JSWhile cond body <- js =
367 | JSWhile cond body <- js =
318 add (tr js) $ add (fold cond) (fold body)
368 add (tr js) $ add (fold cond) (fold body)
369+ | JSFFI raw args <- js =
370+ add (tr js) $ foldl' add acc $ map fold args
371+ | JSAnnotation a js <- js =
372+ add (tr js) $ fold js
319 | otherwise =
373 | otherwise =
320 tr js
374 tr js
321
375
@@ -342,7 +396,9 @@ transformJS tr js =
342 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
396 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
343 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
397 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
344 | JSParens val <- js = JSParens $ tr val
398 | JSParens val <- js = JSParens $ tr val
345− | JSWhile cond body <- js = JSWhile(tr cond) (tr body)
399+ | JSWhile cond body <- js = JSWhile (tr cond) (tr body)
400+ | JSFFI raw args <- js = JSFFI raw (map tr args)
401+ | JSAnnotation a js <- js = JSAnnotation a (tr js)
346 | otherwise = js
402 | otherwise = js
347
403
348
404
@@ -350,6 +406,9 @@ moveJSDeclToTop :: String -> [JS] -> [JS]
350moveJSDeclToTop decl js = move ([], js)
406moveJSDeclToTop decl js = move ([], js)
351 where
407 where
352 move :: ([JS], [JS]) -> [JS]
408 move :: ([JS], [JS]) -> [JS]
409+ move (front, js@(JSAnnotation _ (JSAlloc name _)):back)
410+ | name == decl = js : front ++ back
411+
353 move (front, js@(JSAlloc name _):back)
412 move (front, js@(JSAlloc name _):back)
354 | name == decl = js : front ++ back
413 | name == decl = js : front ++ back
355
414
@@ -1012,7 +1071,7 @@ unfoldLookupTable input =
1012 adaptCon js =
1071 adaptCon js =
1013 adaptCon' [] js
1072 adaptCon' [] js
1014 where
1073 where
1015− adaptCon' front ((JSAlloc "__IDRRT__Con" (Just _)):back) =
1074+ adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =
1016 front ++ (new:back)
1075 front ++ (new:back)
1017
1076
1018 adaptCon' front (next:back) =
1077 adaptCon' front (next:back) =
@@ -1022,11 +1081,12 @@ unfoldLookupTable input =
1022
1081
1023
1082
1024 new =
1083 new =
1084+ JSAnnotation JSConstructor $
1025− JSAlloc "__IDRRT__Con" (Just $
1085+ JSAlloc "__IDRRT__Con" (Just $
1026− JSFunction newArgs (
1086+ JSFunction newArgs (
1027− JSSeq (map newVar newArgs)
1087+ JSSeq (map newVar newArgs)
1088+ )
1028 )
1089 )
1029− )
1030 where
1090 where
1031 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1091 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1032 newArgs = ["tag", "eval", "app", "vars"]
1092 newArgs = ["tag", "eval", "app", "vars"]
@@ -1396,14 +1456,16 @@ codegenJavaScript target definitions includes filename outputType = do
1396
1456
1397 prelude :: [JS]
1457 prelude :: [JS]
1398 prelude =
1458 prelude =
1459+ [ JSAnnotation JSConstructor $
1399− [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1460+ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1400− JSAssign (JSProj JSThis "k") (JSIdent "k")
1461+ JSAssign (JSProj JSThis "k") (JSIdent "k")
1401− ))
1462+ ))
1463+ , JSAnnotation JSConstructor $
1402− , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1464+ JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1403− JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1465+ JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1404− , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1466+ , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1405− ]
1467+ ]
1406− ))
1468+ ))
1407 ]
1469 ]
1408
1470
1409 mainLoop :: JS
1471 mainLoop :: JS
@@ -1887,16 +1949,20 @@ translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
1887 JSBinOp "==" (JSVar lhs) (JSVar rhs)
1949 JSBinOp "==" (JSVar lhs) (JSVar rhs)
1888
1950
1889translateExpression (SForeign _ _ fun args) =
1951translateExpression (SForeign _ _ fun args) =
1890− ffi fun (map generateWrapper args)
1952+ JSFFI fun (map generateWrapper args)
1891 where
1953 where
1892 generateWrapper (ffunc, name)
1954 generateWrapper (ffunc, name)
1893 | FFunction <- ffunc =
1955 | FFunction <- ffunc =
1956+ JSApp (
1957+ JSIdent $ idrRTNamespace ++ "ffiWrap"
1894− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1958+ ) [JSIdent $ translateVariableName name]
1895 | FFunctionIO <- ffunc =
1959 | FFunctionIO <- ffunc =
1960+ JSApp (
1961+ JSIdent $ idrRTNamespace ++ "ffiWrap"
1896− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1962+ ) [JSIdent $ translateVariableName name]
1897
1963
1898 generateWrapper (_, name) =
1964 generateWrapper (_, name) =
1899− translateVariableName name
1965+ JSIdent $ translateVariableName name
1900
1966
1901translateExpression patterncase
1967translateExpression patterncase
1902 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1968 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
@@ -1939,41 +2005,6 @@ translateExpression e =
1939 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
2005 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1940
2006
1941
2007
1942−data FFI = FFICode Char | FFIArg Int | FFIError String
1943−
1944−
1945−ffi :: String -> [String] -> JS
1946−ffi code args = let parsed = ffiParse code in
1947− case ffiError parsed of
1948− Just err -> jsError err
1949− Nothing -> JSRaw $ renderFFI parsed args
1950− where
1951− ffiParse :: String -> [FFI]
1952− ffiParse "" = []
1953− ffiParse ['%'] = [FFIError "Invalid positional argument"]
1954− ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1955− ffiParse ('%':s:ss)
1956− | isDigit s =
1957− FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1958− | otherwise =
1959− [FFIError "Invalid positional argument"]
1960− ffiParse (s:ss) = FFICode s : ffiParse ss
1961−
1962−
1963− ffiError :: [FFI] -> Maybe String
1964− ffiError [] = Nothing
1965− ffiError ((FFIError s):xs) = Just s
1966− ffiError (x:xs) = ffiError xs
1967−
1968−
1969− renderFFI :: [FFI] -> [String] -> String
1970− renderFFI [] _ = ""
1971− renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1972− renderFFI ((FFIArg i) : fs) args
1973− | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1974− | otherwise = "Argument index out of bounds"
1975−
1976−
1977data CaseType = ConCase Int
2008data CaseType = ConCase Int
1978 | TypeCase JSType
2009 | TypeCase JSType
1979 | DefaultCase
2010 | DefaultCase