git.iko.soy/Idris-dev
on master help sign in
fixed point free functions, IO returning functions and added a test, all for js interfaces functionality
2eea508Rui Barreiro
src/IRTS/JavaScript/Codegen.hs+29−9
compare with master
unifiedsplit
@@ -40,7 +40,6 @@ import System.Directory (doesFileExist)
40import System.Environment
40import System.Environment
41import System.FilePath
41import System.FilePath
42
42
43−
44-- | Code generation stats hold information about the generated user
43-- | Code generation stats hold information about the generated user
45-- code. Based on that information we add additional code to make
44-- code. Based on that information we add additional code to make
46-- things work.
45-- things work.
@@ -99,14 +98,31 @@ isYes (Just "Y") = True
99isYes (Just "y") = True
98isYes (Just "y") = True
100isYes _ = False
99isYes _ = False
101
100
102−makeExportDecls :: ExportIFace -> [Text]
101+makeExportDecls :: Map Name LDecl -> ExportIFace -> [Text]
103−makeExportDecls (Export _ _ e) =
102+makeExportDecls defs (Export _ _ e) =
104 concatMap makeExport e
103 concatMap makeExport e
105 where
104 where
105+ uncurryF name argTy (Just args) =
106+ if length argTy == length args then name
107+ else T.concat [ "function(){ return "
108+ , name
109+ , ".apply(this, Array.prototype.slice.call(arguments, 0,", T.pack $ show $ length args,"))"
110+ , T.concat $ map (\x -> T.concat ["(arguments[", T.pack $ show x , "])"]) [length args .. (length argTy - 1)]
111+ , "}"
112+ ]
113+ uncurryF name argTy Nothing = name
114+
115+ addApplyForIO (FIO _) f = T.concat ["function(){ return (",f, ").apply(this,arguments)()}"]
116+ addApplyForIO _ f = f
117+
106 makeExport (ExportData _) =
118 makeExport (ExportData _) =
107 []
119 []
108− makeExport (ExportFun name (FStr exportname) _ _) =
120+ makeExport (ExportFun name (FStr exportname) retTy argTy) =
109− [T.concat [T.pack $ exportname, ": ", jsName name]]
121+ [T.concat [ T.pack $ exportname
122+ , ": "
123+ , addApplyForIO retTy $ uncurryF (jsName name) argTy (getArgList' name defs)
124+ ]
125+ ]
110
126
111codegenJs :: CGConf -> CodeGenerator
127codegenJs :: CGConf -> CodeGenerator
112codegenJs conf ci =
128codegenJs conf ci =
@@ -148,7 +164,7 @@ codegenJs conf ci =
148 , doPartials (partialApplications stats), "\n"
164 , doPartials (partialApplications stats), "\n"
149 , doHiddenClasses (hiddenClasses stats), "\n"
165 , doHiddenClasses (hiddenClasses stats), "\n"
150 , out, "\n"
166 , out, "\n"
151− , if iface then T.concat ["module.exports = {\n", T.intercalate ";\n" $ concatMap makeExportDecls (exportDecls ci), "\n};\n"]
167+ , if iface then T.concat ["module.exports = {\n", T.intercalate ",\n" $ concatMap (makeExportDecls defs) (exportDecls ci), "\n};\n"]
152 else jsName (sMN 0 "runMain") `T.append` "();\n"
168 else jsName (sMN 0 "runMain") `T.append` "();\n"
153 , "}.call(this))"
169 , "}.call(this))"
154 , footer conf
170 , footer conf
@@ -236,13 +252,17 @@ getConsId n =
236 Just (LConstructor _ conId arity) -> pure (conId, arity)
252 Just (LConstructor _ conId arity) -> pure (conId, arity)
237 _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."
253 _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."
238
254
255+getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
256+getArgList' n defs =
257+ case Map.lookup n defs of
258+ Just (LFun _ _ a _) -> Just a
259+ _ -> Nothing
260+
239getArgList :: Name -> State CGBodyState (Maybe [Name])
261getArgList :: Name -> State CGBodyState (Maybe [Name])
240getArgList n =
262getArgList n =
241 do
263 do
242 st <- get
264 st <- get
243− case Map.lookup n (defs st) of
265+ pure $ getArgList' n (defs st)
244− Just (LFun _ _ a _) -> pure $ Just a
245− _ -> pure Nothing
246
266
247data BodyResTarget = ReturnBT
267data BodyResTarget = ReturnBT
248 | DecBT Text
268 | DecBT Text
test/TestData.hs+1
@@ -128,6 +128,7 @@ testFamiliesData = [
128 , ( 8, C_CG )
128 , ( 8, C_CG )
129 , ( 9, C_CG )
129 , ( 9, C_CG )
130 , ( 10, NODE_CG )
130 , ( 10, NODE_CG )
131+ , ( 11, NODE_CG )
131 ]),
132 ]),
132 ("folding", "Folding",
133 ("folding", "Folding",
133 [ ( 1, ANY )]),
134 [ ( 1, ANY )]),
test/ffi011/expectednew file+2
@@ -0,0 +1,2 @@
1+Ready to show...
2+[10, 20, 30, 40]
test/ffi011/ffi011new file+7
@@ -0,0 +1,7 @@
1+l = require("./lib.js");
2+
3+x = l.cons(10, l.cons(20, l.nil()));
4+y = l.cons(30, l.cons(40, l.nil()));
5+z = l.addLists(x, y);
6+
7+console.log(l.showList(z));
test/ffi011/ffi011.idrnew file+27
@@ -0,0 +1,27 @@
1+module Lib
2+
3+import Data.List
4+
5+addLists : List Int -> List Int -> List Int
6+addLists xs ys = xs ++ ys
7+
8+nil : List Int
9+nil = []
10+
11+cons : Int -> List Int -> List Int
12+cons x xs = x :: xs
13+
14+show' : List Int -> JS_IO String
15+show' xs = do putStrLn' "Ready to show..."
16+ pure (show xs)
17+
18+testList : FFI_Export FFI_JS "" []
19+testList = Data (List Int) "ListInt" $
20+ Data (List Nat) "ListNat" $
21+ Fun addLists "addLists" $
22+ Fun nil "nil" $
23+ Fun cons "cons" $
24+ Data Nat "Nat" $
25+ Fun Strings.length "lengthS" $
26+ Fun show' "showList" $
27+ End
test/ffi011/runnew file+4
@@ -0,0 +1,4 @@
1+#!/usr/bin/env bash
2+${IDRIS:-idris} $@ ffi011.idr --interface -o lib.js
3+node ./ffi011
4+rm -f *.ibc lib.js