Merge pull request #4073 from rbarreiro/exportiface_js

--interface for node backend

CHANGELOG.md

@@ -15,6 +15,7 @@
 ## Tool Updates
 + Private functions are no longer visible in the REPL except for modules
   that are explicitly loaded.
++ The --interface option now creates CommonJS modules on the node backend.
 
 # New in 1.1.1
 

CONTRIBUTORS

@@ -177,6 +177,7 @@ Ricky Elrod
 Robert Clipsham
 Robert Edström
 Ross Meikleham
+Rui Barreiro
 Ryan Scott
 Sam Elliott
 Sam T

codegen/idris-codegen-node/Main.hs

@@ -7,10 +7,15 @@ import Idris.Options
 import IRTS.CodegenJavaScript
 import IRTS.Compiler
 
+import Paths_idris
+
+import Control.Monad
+
 import System.Environment
 import System.Exit
 
 data Opts = Opts { inputs :: [FilePath]
+                 , interface :: Bool
                  , output :: FilePath
                  }
 
@@ -20,17 +25,20 @@ showUsage = do putStrLn "A code generator which is intended to be called by the
 
 getOpts :: IO Opts
 getOpts = do xs <- getArgs
-             return $ process (Opts [] "main.js") xs
+             return $ process (Opts [] False "main.js") xs
   where
     process opts ("-o":o:xs) = process (opts { output = o }) xs
+    process opts ("--interface":xs) = process (opts { interface = True }) xs
     process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs
     process opts [] = opts
 
 jsMain :: Opts -> Idris ()
 jsMain opts = do elabPrims
                  loadInputs (inputs opts) Nothing
-                 mainProg <- elabMain
-                 ir <- compile (Via IBCFormat "node") (output opts) (Just mainProg)
+                 mainProg <- if interface opts
+                                then return Nothing
+                                else liftM Just elabMain
+                 ir <- compile (Via IBCFormat "node") (output opts) mainProg
                  runIO $ codegenNode ir
 
 main :: IO ()

src/IRTS/CodegenJavaScript.hs

@@ -55,15 +55,24 @@ codegenJavaScript ci =
 
 codegenNode :: CodeGenerator
 codegenNode ci =
-  do
-    codegenJs (CGConf { header = "#!/usr/bin/env node\n"
+  if interfaces ci then
+    codegenJs (CGConf { header = ""
                       , footer = ""
                       , jsbnPath = "jsbn/jsbn-browser.js"
                       , extraRunTime = "Runtime-node.js"
                       }
               )
               ci
-    setPermissions (outputFile ci) (emptyPermissions { readable   = True
-                                                     , executable = True
-                                                     , writable   = True
-                                                     })
+    else
+      do
+        codegenJs (CGConf { header = "#!/usr/bin/env node\n"
+                          , footer = ""
+                          , jsbnPath = "jsbn/jsbn-browser.js"
+                          , extraRunTime = "Runtime-node.js"
+                          }
+                  )
+                  ci
+        setPermissions (outputFile ci) (emptyPermissions { readable   = True
+                                                         , executable = True
+                                                         , writable   = True
+                                                         })

src/IRTS/Compiler.hs

@@ -142,7 +142,7 @@ generate codegen mainmod ir
                                         return fn
                        let cmd = "idris-codegen-" ++ cg
                            args = [input, "-o", outputFile ir] ++ compilerFlags ir
-                       exit <- rawSystem cmd args
+                       exit <- rawSystem cmd (if interfaces ir then "--interface" : args else args)
                        when (exit /= ExitSuccess) $
                             putStrLn ("FAILURE: " ++ show cmd ++ " " ++ show args)
        Bytecode -> dumpBC (simpleDecls ir) (outputFile ir)

src/IRTS/JavaScript/Codegen.hs

@@ -14,6 +14,7 @@ module IRTS.JavaScript.Codegen( codegenJs
 
 import Idris.Core.TT
 import IRTS.CodegenCommon
+import IRTS.Exports
 import IRTS.JavaScript.AST
 import IRTS.JavaScript.LangTransforms
 import IRTS.JavaScript.Name
@@ -39,7 +40,6 @@ import System.Directory (doesFileExist)
 import System.Environment
 import System.FilePath
 
-
 -- | Code generation stats hold information about the generated user
 -- code. Based on that information we add additional code to make
 -- things work.
@@ -98,14 +98,42 @@ isYes (Just "Y") = True
 isYes (Just "y") = True
 isYes _ = False
 
+makeExportDecls :: Map Name LDecl -> ExportIFace -> [Text]
+makeExportDecls defs (Export _ _ e) =
+  concatMap makeExport e
+  where
+    uncurryF name argTy (Just args) =
+      if length argTy == length args then name
+        else T.concat [ "function(){ return "
+                      , name
+                      , ".apply(this, Array.prototype.slice.call(arguments, 0,", T.pack $ show $ length args,"))"
+                      , T.concat $ map (\x -> T.concat ["(arguments[", T.pack $ show x , "])"]) [length args .. (length argTy - 1)]
+                      , "}"
+                      ]
+    uncurryF name argTy Nothing = name
+
+    addApplyForIO (FIO _) f = T.concat ["function(){ return (",f, ").apply(this,arguments)()}"]
+    addApplyForIO _ f = f
+
+    makeExport (ExportData _) =
+      []
+    makeExport (ExportFun name (FStr exportname) retTy argTy) =
+      [T.concat [ T.pack $ exportname
+                ,  ": "
+                , addApplyForIO retTy $ uncurryF (jsName name) argTy (getArgList' name defs)
+                ]
+      ]
 
 codegenJs :: CGConf -> CodeGenerator
 codegenJs conf ci =
   do
     debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"
     let defs' = Map.fromList $ liftDecls ci
     let defs = globlToCon defs'
-    let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
+    let iface = interfaces ci
+    let used = if iface then
+                  Map.elems $ removeDeadCode defs (getExpNames $ exportDecls ci)
+                  else Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
     when debug $ do
         writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
         putStrLn $ "Finished calculating used"
@@ -136,7 +164,8 @@ codegenJs conf ci =
                                              , doPartials (partialApplications stats), "\n"
                                              , doHiddenClasses (hiddenClasses stats), "\n"
                                              , out, "\n"
-                                             , jsName (sMN 0 "runMain"), "();\n"
+                                             , if iface then T.concat ["module.exports = {\n", T.intercalate ",\n" $ concatMap (makeExportDecls defs) (exportDecls ci), "\n};\n"]
+                                                  else jsName (sMN 0 "runMain") `T.append` "();\n"
                                              , "}.call(this))"
                                              , footer conf
                                              ]
@@ -223,13 +252,17 @@ getConsId n =
         Just (LConstructor _ conId arity) -> pure (conId, arity)
         _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."
 
+getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
+getArgList' n defs =
+    case Map.lookup n defs of
+      Just (LFun _ _ a _) -> Just a
+      _ -> Nothing
+
 getArgList :: Name -> State CGBodyState (Maybe [Name])
 getArgList n =
   do
     st <- get
-    case Map.lookup n (defs st) of
-      Just (LFun _ _ a _) -> pure $ Just a
-      _ -> pure Nothing
+    pure $ getArgList' n (defs st)
 
 data BodyResTarget = ReturnBT
                    | DecBT Text

src/Idris/REPL.hs

@@ -79,6 +79,7 @@ import Idris.REPL.Parser
 import Idris.Termination
 import Idris.TypeSearch (searchByType)
 import Idris.WhoCalls
+import IRTS.CodegenCommon
 import IRTS.Compiler
 import Network
 import Prelude hiding (id, (.), (<$>))
@@ -1280,7 +1281,8 @@ process fn (Compile codegen f)
                                return (Just m')
                        ir <- compile codegen f m
                        i <- getIState
-                       runIO $ generate codegen (fst (head (idris_imported i))) ir
+                       let ir' = ir {interfaces = iface}
+                       runIO $ generate codegen (fst (head (idris_imported i))) ir'
   where fc = fileFC "main"
 process fn (LogLvl i) = setLogLevel i
 process fn (LogCategory cs) = setLogCats cs

test/TestData.hs

@@ -72,7 +72,7 @@ testFamiliesData = [
       ( 18, ANY  ),
       ( 19, ANY  ),
       ( 20, ANY  ),
-      ( 21, ANY  )]),
+      ( 21, C_CG  )]),
   ("bignum",          "Bignum",
     [ (  1, ANY  ),
       (  2, ANY  )]),
@@ -129,6 +129,7 @@ testFamiliesData = [
     , (  8, C_CG )
     , (  9, C_CG )
     , ( 10, NODE_CG )
+    , ( 11, NODE_CG )
     ]),
   ("folding",         "Folding",
     [ (  1, ANY  )]),

test/ffi011/expected

@@ -0,0 +1,2 @@
+Ready to show...
+[10, 20, 30, 40]

test/ffi011/ffi011

@@ -0,0 +1,7 @@
+l = require("./lib.js");
+
+x = l.cons(10, l.cons(20, l.nil()));
+y = l.cons(30, l.cons(40, l.nil()));
+z = l.addLists(x, y);
+
+console.log(l.showList(z));

test/ffi011/ffi011.idr

@@ -0,0 +1,27 @@
+module Lib
+
+import Data.List
+
+addLists : List Int -> List Int -> List Int
+addLists xs ys = xs ++ ys
+
+nil : List Int
+nil = []
+
+cons : Int -> List Int -> List Int
+cons x xs = x :: xs
+
+show' : List Int -> JS_IO String
+show' xs = do putStrLn' "Ready to show..."
+              pure (show xs)
+
+testList : FFI_Export FFI_JS "" []
+testList = Data (List Int) "ListInt" $
+           Data (List Nat) "ListNat" $
+           Fun addLists "addLists" $
+           Fun nil "nil" $
+           Fun cons "cons" $
+           Data Nat "Nat" $
+           Fun Strings.length "lengthS" $
+           Fun show' "showList" $
+           End

test/ffi011/run

@@ -0,0 +1,4 @@
+#!/usr/bin/env bash
+${IDRIS:-idris} $@ ffi011.idr --interface -o lib.js
+node ./ffi011
+rm -f *.ibc lib.js