git.iko.soy/Idris-dev
on master help sign in
javascript: make FFI part of AST
c353a68raichoo
src/IRTS/CodegenJavaScript.hs+51−40
compare with master
unifiedsplit
@@ -80,13 +80,52 @@ data JS = JSRaw String
80 | JSTernary JS JS JS
80 | JSTernary JS JS JS
81 | JSParens JS
81 | JSParens JS
82 | JSWhile JS JS
82 | JSWhile JS JS
83+ | JSFFI String [JS]
83 | JSNoop
84 | JSNoop
84 deriving Eq
85 deriving Eq
85
86
86
87
88+data FFI = FFICode Char | FFIArg Int | FFIError String
89+
90+
91+ffi :: String -> [String] -> String
92+ffi code args = let parsed = ffiParse code in
93+ case ffiError parsed of
94+ Just err -> compileJS $ jsError err
95+ Nothing -> renderFFI parsed args
96+ where
97+ ffiParse :: String -> [FFI]
98+ ffiParse "" = []
99+ ffiParse ['%'] = [FFIError "Invalid positional argument"]
100+ ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
101+ ffiParse ('%':s:ss)
102+ | isDigit s =
103+ FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
104+ | otherwise =
105+ [FFIError "Invalid positional argument"]
106+ ffiParse (s:ss) = FFICode s : ffiParse ss
107+
108+
109+ ffiError :: [FFI] -> Maybe String
110+ ffiError [] = Nothing
111+ ffiError ((FFIError s):xs) = Just s
112+ ffiError (x:xs) = ffiError xs
113+
114+
115+ renderFFI :: [FFI] -> [String] -> String
116+ renderFFI [] _ = ""
117+ renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
118+ renderFFI ((FFIArg i) : fs) args
119+ | i < length args && i >= 0 = args !! i ++ renderFFI fs args
120+ | otherwise = "Argument index out of bounds"
121+
122+
87compileJS :: JS -> String
123compileJS :: JS -> String
88compileJS JSNoop = ""
124compileJS JSNoop = ""
89
125
126+compileJS (JSFFI raw args) =
127+ ffi raw (map compileJS args)
128+
90compileJS (JSRaw code) =
129compileJS (JSRaw code) =
91 code
130 code
92
131
@@ -316,6 +355,8 @@ foldJS tr add acc js =
316 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
355 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
317 | JSWhile cond body <- js =
356 | JSWhile cond body <- js =
318 add (tr js) $ add (fold cond) (fold body)
357 add (tr js) $ add (fold cond) (fold body)
358+ | JSFFI raw args <- js =
359+ add (tr js) $ foldl' add acc $ map fold args
319 | otherwise =
360 | otherwise =
320 tr js
361 tr js
321
362
@@ -342,7 +383,8 @@ transformJS tr js =
342 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
383 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
343 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
384 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
344 | JSParens val <- js = JSParens $ tr val
385 | JSParens val <- js = JSParens $ tr val
345− | JSWhile cond body <- js = JSWhile(tr cond) (tr body)
386+ | JSWhile cond body <- js = JSWhile (tr cond) (tr body)
387+ | JSFFI raw args <- js = JSFFI raw (map tr args)
346 | otherwise = js
388 | otherwise = js
347
389
348
390
@@ -1887,16 +1929,20 @@ translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
1887 JSBinOp "==" (JSVar lhs) (JSVar rhs)
1929 JSBinOp "==" (JSVar lhs) (JSVar rhs)
1888
1930
1889translateExpression (SForeign _ _ fun args) =
1931translateExpression (SForeign _ _ fun args) =
1890− ffi fun (map generateWrapper args)
1932+ JSFFI fun (map generateWrapper args)
1891 where
1933 where
1892 generateWrapper (ffunc, name)
1934 generateWrapper (ffunc, name)
1893 | FFunction <- ffunc =
1935 | FFunction <- ffunc =
1936+ JSApp (
1937+ JSIdent $ idrRTNamespace ++ "ffiWrap"
1894− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1938+ ) [JSIdent $ translateVariableName name]
1895 | FFunctionIO <- ffunc =
1939 | FFunctionIO <- ffunc =
1940+ JSApp (
1941+ JSIdent $ idrRTNamespace ++ "ffiWrap"
1896− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1942+ ) [JSIdent $ translateVariableName name]
1897
1943
1898 generateWrapper (_, name) =
1944 generateWrapper (_, name) =
1899− translateVariableName name
1945+ JSIdent $ translateVariableName name
1900
1946
1901translateExpression patterncase
1947translateExpression patterncase
1902 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1948 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
@@ -1939,41 +1985,6 @@ translateExpression e =
1939 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1985 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1940
1986
1941
1987
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
1988data CaseType = ConCase Int
1978 | TypeCase JSType
1989 | TypeCase JSType
1979 | DefaultCase
1990 | DefaultCase