@@ -80,13 +80,52 @@ data JS = JSRaw String
8080 | JSTernary JS JS JS
8181 | JSParens JS
8282 | JSWhile JS JS
83+ | JSFFI String [JS]
8384 | JSNoop
8485 deriving Eq
8586
8687
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+
87123compileJS :: JS -> String
88124compileJS JSNoop = ""
89125
126+compileJS (JSFFI raw args) =
127+ ffi raw (map compileJS args)
128+
90129compileJS (JSRaw code) =
91130 code
92131
@@ -316,6 +355,8 @@ foldJS tr add acc js =
316355 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
317356 | JSWhile cond body <- js =
318357 add (tr js) $ add (fold cond) (fold body)
358+ | JSFFI raw args <- js =
359+ add (tr js) $ foldl' add acc $ map fold args
319360 | otherwise =
320361 tr js
321362
@@ -342,7 +383,8 @@ transformJS tr js =
342383 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
343384 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
344385 | 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)
346388 | otherwise = js
347389
348390
@@ -1887,16 +1929,20 @@ translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
18871929 JSBinOp "==" (JSVar lhs) (JSVar rhs)
18881930
18891931translateExpression (SForeign _ _ fun args) =
1890− ffi fun (map generateWrapper args)
1932+ JSFFI fun (map generateWrapper args)
18911933 where
18921934 generateWrapper (ffunc, name)
18931935 | FFunction <- ffunc =
1894− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1936+ JSApp (
1937+ JSIdent $ idrRTNamespace ++ "ffiWrap"
1938+ ) [JSIdent $ translateVariableName name]
18951939 | FFunctionIO <- ffunc =
1896− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1940+ JSApp (
1941+ JSIdent $ idrRTNamespace ++ "ffiWrap"
1942+ ) [JSIdent $ translateVariableName name]
18971943
18981944 generateWrapper (_, name) =
1899− translateVariableName name
1945+ JSIdent $ translateVariableName name
19001946
19011947translateExpression patterncase
19021948 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
@@ -1939,41 +1985,6 @@ translateExpression e =
19391985 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
19401986
19411987
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−
19771988data CaseType = ConCase Int
19781989 | TypeCase JSType
19791990 | DefaultCase