@@ -52,6 +52,13 @@ data JSNum = JSInt Int
5252 deriving Eq
5353
5454
55+data JSAnnotation = JSConstructor deriving Eq
56+
57+
58+instance Show JSAnnotation where
59+ show JSConstructor = "constructor"
60+
61+
5562data JS = JSRaw String
5663 | JSIdent String
5764 | JSFunction [String] JS
@@ -80,13 +87,56 @@ data JS = JSRaw String
8087 | JSTernary JS JS JS
8188 | JSParens JS
8289 | JSWhile JS JS
90+ | JSFFI String [JS]
91+ | JSAnnotation JSAnnotation JS
8392 | JSNoop
8493 deriving Eq
8594
8695
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+
87131compileJS :: JS -> String
88132compileJS JSNoop = ""
89133
134+compileJS (JSAnnotation annotation js) =
135+ "/** @" ++ show annotation ++ " */\n" ++ compileJS js
136+
137+compileJS (JSFFI raw args) =
138+ ffi raw (map compileJS args)
139+
90140compileJS (JSRaw code) =
91141 code
92142
@@ -316,6 +366,10 @@ foldJS tr add acc js =
316366 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
317367 | JSWhile cond body <- js =
318368 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
319373 | otherwise =
320374 tr js
321375
@@ -342,7 +396,9 @@ transformJS tr js =
342396 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
343397 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
344398 | 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)
346402 | otherwise = js
347403
348404
@@ -350,6 +406,9 @@ moveJSDeclToTop :: String -> [JS] -> [JS]
350406moveJSDeclToTop decl js = move ([], js)
351407 where
352408 move :: ([JS], [JS]) -> [JS]
409+ move (front, js@(JSAnnotation _ (JSAlloc name _)):back)
410+ | name == decl = js : front ++ back
411+
353412 move (front, js@(JSAlloc name _):back)
354413 | name == decl = js : front ++ back
355414
@@ -1012,7 +1071,7 @@ unfoldLookupTable input =
10121071 adaptCon js =
10131072 adaptCon' [] js
10141073 where
1015− adaptCon' front ((JSAlloc "__IDRRT__Con" (Just _)):back) =
1074+ adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =
10161075 front ++ (new:back)
10171076
10181077 adaptCon' front (next:back) =
@@ -1022,11 +1081,12 @@ unfoldLookupTable input =
10221081
10231082
10241083 new =
1025− JSAlloc "__IDRRT__Con" (Just $
1026− JSFunction newArgs (
1027− JSSeq (map newVar newArgs)
1084+ JSAnnotation JSConstructor $
1085+ JSAlloc "__IDRRT__Con" (Just $
1086+ JSFunction newArgs (
1087+ JSSeq (map newVar newArgs)
1088+ )
10281089 )
1029− )
10301090 where
10311091 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
10321092 newArgs = ["tag", "eval", "app", "vars"]
@@ -1396,14 +1456,16 @@ codegenJavaScript target definitions includes filename outputType = do
13961456
13971457 prelude :: [JS]
13981458 prelude =
1399− [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1400− JSAssign (JSProj JSThis "k") (JSIdent "k")
1401− ))
1402− , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1403− JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1404− , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1405− ]
1406− ))
1459+ [ JSAnnotation JSConstructor $
1460+ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1461+ JSAssign (JSProj JSThis "k") (JSIdent "k")
1462+ ))
1463+ , JSAnnotation JSConstructor $
1464+ JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1465+ JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1466+ , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1467+ ]
1468+ ))
14071469 ]
14081470
14091471 mainLoop :: JS
@@ -1887,16 +1949,20 @@ translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
18871949 JSBinOp "==" (JSVar lhs) (JSVar rhs)
18881950
18891951translateExpression (SForeign _ _ fun args) =
1890− ffi fun (map generateWrapper args)
1952+ JSFFI fun (map generateWrapper args)
18911953 where
18921954 generateWrapper (ffunc, name)
18931955 | FFunction <- ffunc =
1894− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1956+ JSApp (
1957+ JSIdent $ idrRTNamespace ++ "ffiWrap"
1958+ ) [JSIdent $ translateVariableName name]
18951959 | FFunctionIO <- ffunc =
1896− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1960+ JSApp (
1961+ JSIdent $ idrRTNamespace ++ "ffiWrap"
1962+ ) [JSIdent $ translateVariableName name]
18971963
18981964 generateWrapper (_, name) =
1899− translateVariableName name
1965+ JSIdent $ translateVariableName name
19001966
19011967translateExpression patterncase
19021968 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
@@ -1939,41 +2005,6 @@ translateExpression e =
19392005 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
19402006
19412007
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−
19772008data CaseType = ConCase Int
19782009 | TypeCase JSType
19792010 | DefaultCase