Get hello world to working state

example-react-serverside-rendering/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2016 Pedro Tacla Yamada
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

example-react-serverside-rendering/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

example-react-serverside-rendering/example-react-serverside-rendering.cabal

@@ -0,0 +1,17 @@
+name:                example-react-serverside-rendering
+version:             0.1.0.0
+synopsis:            An example for ghcjs-commonjs
+homepage:            https://github.com/beijaflor-io/ghcjs-commonjs
+license:             MIT
+license-file:        LICENSE
+author:              Pedro Tacla Yamada
+maintainer:          tacla.yamada@gmail.com
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable example-react-serverside-rendering
+  main-is:             Main.hs
+  build-depends:       base >=4.8 && <4.9
+  hs-source-dirs:      src
+  default-language:    Haskell2010

example-react-serverside-rendering/src/Main.hs

@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = undefined

examples/.#ghcjs-require.js

@@ -0,0 +1 @@
+yamadapc@Pedros-MBP.42571

examples/Makefile

@@ -0,0 +1,3 @@
+hello-world: FORCE
+
+FORCE:

examples/README.md

@@ -0,0 +1,4 @@
+# ghcjs-commonjs-examples
+This is a collection of runnable examples for **ghcjs-commonjs**, there's a
+`Vagrantfile` and `Dockerfile` in this directory so you can get everything up
+and running quickly.

examples/hello-world/Main.hs

@@ -0,0 +1,8 @@
+module Main where
+
+import qualified GHCJS.CommonJS as CommonJS
+
+main :: IO ()
+main = CommonJS.exportMain
+    [ CommonJS.pack ("sayHello", putStrLn "Hello, I'm a Haskell")
+    ]

examples/hello-world/README.md

@@ -0,0 +1,29 @@
+# ghcjs-commonjs-hello-world
+GHCJS CommonJS Hello Haskell World example.
+
+## Building
+Running:
+```
+npm install
+```
+Will install dependencies and run an initial build. To re-build you can run:
+```
+npm run build
+```
+
+## Running
+The generated code should be executable in **Node.js** and the **Browser**.
+
+### Running on the Browser
+```
+npm run start-browser
+```
+
+Should open a **Browser** window running the code.
+
+### Running on Node.js
+```
+npm run start-node
+```
+
+Should run the code on **Node.js**.

examples/hello-world/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

examples/hello-world/ghcjs-commonjs-hello-world.cabal

@@ -0,0 +1,14 @@
+name:                ghcjs-commonjs-hello-world
+version:             0.1.0.0
+author:              Pedro Tacla Yamada
+maintainer:          tacla.yamada@gmail.com
+category:            Web
+build-type:          Simple
+extra-source-files:  README.md
+cabal-version:       >=1.10
+
+executable ghcjs-commonjs-hello-world
+  main-is:             Main.hs
+  build-depends:       base >=4.8 && <4.9
+                     , ghcjs-commonjs
+  default-language:    Haskell2010

examples/hello-world/index.js

@@ -0,0 +1,8 @@
+const ghcjsRequire = require('ghcjs-require');
+const HelloWorld = ghcjsRequire(module, 'ghcjs-commonjs-hello-world');
+
+HelloWorld(({wrapped}) => {
+  wrapped.sayHello().then(() => {
+    console.log('And I\'m a JavaScript');
+  });
+});

examples/hello-world/package.json

@@ -0,0 +1,15 @@
+{
+  "name": "ghcjs-commonjs-hello-world",
+  "version": "1.0.0",
+  "description": "GHCJS CommonJS Hello Haskell World example",
+  "main": "index.js",
+  "scripts": {
+    "build": "stack build --install-ghc",
+    "test": "mocha"
+  },
+  "author": "Pedro Tacla Yamada",
+  "license": "MIT",
+  "dependencies": {
+    "ghcjs-require": "file:///Users/yamadapc/program/github.com/beijaflor-io/ghcjs-commonjs/ghcjs-require"
+  }
+}

examples/hello-world/stack.yaml

@@ -0,0 +1,13 @@
+resolver: lts-6.3
+compiler: ghcjs-0.2.0.20160414_ghc-7.10.3
+compiler-check: match-exact
+setup-info:
+  ghcjs:
+    source:
+      ghcjs-0.2.0.20160414_ghc-7.10.3:
+        url: https://s3.amazonaws.com/ghcjs/ghcjs-0.2.0.20160414_ghc-7.10.3.tar.gz
+        sha1: 6d6f307503be9e94e0c96ef1308c7cf224d06be3
+
+packages:
+- .
+- ../../ghcjs-commonjs

ghcjs-commonjs/ghcjs-commonjs.cabal

@@ -12,10 +12,12 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 library
-  exposed-modules: GHCJS.Require
+  exposed-modules: GHCJS.CommonJS
                  , JavaScript.EventEmitter
                  , JavaScript.EventEmitter.Internal
   build-depends:  base >=4.8 && <4.9
+                , containers >= 0.5.6.3
                 , ghcjs-base
+                , hashtables
   hs-source-dirs:      src
   default-language:    Haskell2010

ghcjs-commonjs/src/GHCJS/CommonJS.hs

@@ -0,0 +1,210 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts          #-}
+{-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE GADTs                     #-}
+{-# LANGUAGE ImpredicativeTypes        #-}
+{-# LANGUAGE LambdaCase                #-}
+{-# LANGUAGE OverlappingInstances      #-}
+{-# LANGUAGE ScopedTypeVariables       #-}
+module GHCJS.CommonJS
+  where
+
+import           Control.Concurrent
+import           Control.Monad
+import qualified Data.JSString           as JSString (unpack)
+import qualified Data.Map.Strict         as Map
+import           Data.String
+import           GHCJS.Foreign.Callback
+import           GHCJS.Marshal
+import           GHCJS.Types
+import qualified JavaScript.Array        as JSArray (fromList)
+import           JavaScript.EventEmitter
+
+import           GHCJS.CommonJS.Internal
+import           System.IO.Unsafe
+
+data CommonJSExportArity t = CommonJSExportArity Int
+                           | CommonJSExportArityApply
+
+type CommonJSExport = [JSVal] -> IO [JSVal]
+
+class ToCommonJSExport t where
+    exportName :: t -> String
+    toCommonJSExport :: t -> CommonJSExport
+    arity :: CommonJSExportArity t
+
+instance ToCommonJSExport (String, IO ()) where
+    exportName = fst
+    toCommonJSExport (_, action) _ = void action >> return []
+    arity = CommonJSExportArity 0
+
+instance ToJSVal () where
+    toJSVal _ = return nullRef
+
+instance (FromJSVal a, ToJSVal b) => ToCommonJSExport (String, a -> IO b) where
+    exportName = fst
+    toCommonJSExport (n, action) (a:_) = do
+        v <- fromJSValIO n a >>= action
+        jsV <- toJSVal v
+        return [jsV]
+    toCommonJSExport (n, _) _ = error ("Missing required argument to " ++ n)
+    arity = CommonJSExportArity 1
+
+instance (FromJSVal a1, FromJSVal a2, ToJSVal b) => ToCommonJSExport (String, a1 -> a2 -> IO b) where
+    exportName = fst
+    toCommonJSExport (n, action) (a1:a2:_) = do
+        a1' <- fromJSValIO n a1
+        a2' <- fromJSValIO n a2
+        v <- action a1' a2'
+        jsV <- toJSVal v
+        return [jsV]
+    toCommonJSExport (n, _) _ = error ("Missing required argument(s) to " ++ n)
+    arity = CommonJSExportArity 2
+
+instance (FromJSVal a1, FromJSVal a2, FromJSVal a3, ToJSVal b) => ToCommonJSExport (String, a1 -> a2 -> a3 -> IO b) where
+    exportName = fst
+    toCommonJSExport (n, action) (a1:a2:a3:_) = do
+        a1' <- fromJSValIO n a1
+        a2' <- fromJSValIO n a2
+        a3' <- fromJSValIO n a3
+        v <- action a1' a2' a3'
+        jsV <- toJSVal v
+        return [jsV]
+    toCommonJSExport (n, _) _ = error ("Missing required argument(s) to " ++ n)
+    arity = CommonJSExportArity 2
+
+instance (FromJSVal a, ToJSVal b) => ToCommonJSExport (String, [a] -> IO [b]) where
+    exportName = fst
+    toCommonJSExport (n, action) as = do
+        as' <- fromJSValListOfIO n as
+        v <- action as'
+        mapM toJSVal v
+    arity = CommonJSExportArityApply
+
+instance ToCommonJSExport (String, [JSVal] -> IO [JSVal]) where
+    exportName = fst
+    toCommonJSExport = snd
+    arity = CommonJSExportArityApply
+
+instance (ToJSVal a) => ToCommonJSExport (String, IO a) where
+    exportName = fst
+    toCommonJSExport (_, action) _ = do
+        v <- action
+        mv <- toJSVal v
+        return [mv]
+    arity = CommonJSExportArity 0
+
+instance (FromJSVal b, ToJSVal a) => ToCommonJSExport (String, b -> a) where
+    exportName = fst
+    toCommonJSExport (n, action) (a:_) = do
+        a' <- fromJSValIO n a
+        let v = action a'
+        mv <- toJSVal v
+        return [mv]
+    toCommonJSExport (n, _) _ = error ("Missing required argument(s) to " ++ n)
+    arity = CommonJSExportArity 1
+
+instance (ToJSVal a) => ToCommonJSExport (String, a) where
+    exportName = fst
+    toCommonJSExport (_, action) _ = do
+        let v = action
+        mv <- toJSVal v
+        return [mv]
+    arity = CommonJSExportArity 0
+
+fromJSValListOfIO :: FromJSVal a => String -> [JSVal] -> IO [a]
+fromJSValListOfIO n as = do
+    asms <- mapM fromJSVal as -- :: FromJSVal a => IO [Maybe a]
+    case sequence asms of -- :: Maybe [a] of
+        Nothing -> error ("Wrong type of arguments suplied to " ++ n ++
+                      ". All arguments should have the same type")
+        Just as' -> return as'
+
+fromJSValIO :: FromJSVal a => String -> JSVal -> IO a
+fromJSValIO n a = fromJSVal a >>= \case
+    Nothing -> error ("Wrong type of argument suplied to " ++ n)
+    Just a' -> return a'
+
+-- data Export where
+--     Export :: CommonJSExport e => e -> Export
+    --  forall e . CommonJSExport e => Export e
+type ExportMap = Map.Map String CommonJSExport
+
+defaultMain :: IO ()
+defaultMain = do
+    em <- getRequireEmitter
+    on3 em "ghcjs-require:runexport" onRunExport
+    void $ emit0 em "ghcjs-require:loaded"
+    return ()
+
+exportMain :: (Foldable t) => t (String, CommonJSExport) -> IO ()
+exportMain es = do
+    mapM_ (uncurry exportWrapped) es
+    defaultMain
+
+fibs :: [Int]
+fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
+
+pack :: ToCommonJSExport (String, e) => (String, e) -> (String, CommonJSExport)
+pack e = (exportName e, toCommonJSExport e)
+
+test =
+    exportMain [ pack ("hello", print "Hello")
+               , pack ("fibs", \n -> (take n fibs))
+               , pack ("yo", print "yo")
+               ]
+
+onRunExport :: JSVal -> JSVal -> JSVal -> IO ()
+onRunExport name args cb = do
+    Just str <- fromJSVal name :: IO (Maybe JSString)
+    let hsName = JSString.unpack str
+    maction <- getExport hsName
+    ret <- case maction of
+        Nothing -> error ("No function " ++ hsName ++ " exported")
+        Just action -> fromJSValListOf args >>= \case
+            Nothing -> error ("Second parameter to the ghcjs-require:runexport " ++
+                              "event should be a list of arguments")
+            Just args' -> action args'
+    call cb (nullRef : ret)
+
+call :: JSVal -> [JSVal] -> IO ()
+call fn [] = js_call0 fn
+call fn [a1] = js_call1 fn a1
+call fn [a1, a2] = js_call2 fn a1 a2
+call fn [a1, a2, a3] = js_call3 fn a1 a2 a3
+call fn args = js_apply fn (JSArray.fromList args)
+
+exports :: MVar ExportMap
+exports = unsafePerformIO $ newMVar Map.empty
+{-# NOINLINE exports #-}
+
+getExport :: String -> IO (Maybe CommonJSExport)
+getExport name = do
+    es <- readMVar exports
+    return $ Map.lookup name es
+
+registerExport' :: (String, CommonJSExport) -> IO ()
+registerExport' e = modifyMVar_ exports $ \es ->
+    return $ uncurry Map.insert e es
+
+registerExport :: ToCommonJSExport e => e -> IO ()
+registerExport e =
+    registerExport' (exportName e, toCommonJSExport e)
+
+require :: String -> IO JSVal
+require = js_require . fromString
+
+exportWrapped :: ToCommonJSExport (String, e) => String -> e -> IO ()
+exportWrapped name action = do
+    registerExport (name, action)
+    let name' = fromString name
+    js_registerWrapped name'
+
+export :: String -> IO () -> IO ()
+export name action = do
+    callback <- asyncCallback action
+    let name' = fromString name
+    js_export name' callback
+
+getRequireEmitter :: IO EventEmitter
+getRequireEmitter = emitter <$> js_getRequireEmitter

ghcjs-commonjs/src/GHCJS/CommonJS/Internal.hs

@@ -0,0 +1,34 @@
+module GHCJS.CommonJS.Internal where
+
+import           Data.JSString
+import           GHCJS.Foreign.Callback
+import           GHCJS.Types
+import           JavaScript.Array
+import           JavaScript.Object
+
+foreign import javascript unsafe "$r = require($1)"
+    js_require :: JSString -> IO JSVal
+
+foreign import javascript unsafe "global.wrappedExports.push($1)"
+    js_registerWrapped :: JSString -> IO ()
+
+foreign import javascript unsafe "global.exports[$1] = $2"
+    js_export :: JSString -> Callback a -> IO ()
+
+foreign import javascript unsafe "global.emitter"
+    js_getRequireEmitter :: IO Object
+
+foreign import javascript unsafe "$1()"
+   js_call0 :: JSVal -> IO ()
+
+foreign import javascript unsafe "$1($2)"
+   js_call1 :: JSVal -> JSVal -> IO ()
+
+foreign import javascript unsafe "$1($2, $3)"
+   js_call2 :: JSVal -> JSVal -> JSVal -> IO ()
+
+foreign import javascript unsafe "$1($2, $3, $4)"
+   js_call3 :: JSVal -> JSVal -> JSVal -> JSVal -> IO ()
+
+foreign import javascript unsafe "$1.apply(null, $2)"
+   js_apply :: JSVal -> JSArray -> IO ()

ghcjs-commonjs/src/GHCJS/Require.hs

@@ -1,83 +0,0 @@
-module GHCJS.Require
-  where
-
-import           Control.Concurrent
-import           Control.Monad
-import           Data.JSString
-import           Data.String
-import           GHCJS.Foreign
-import           GHCJS.Foreign.Callback
-import           GHCJS.Marshal
-import           GHCJS.Types
-import           JavaScript.Array
-import           JavaScript.Object
-import           JavaScript.EventEmitter
-import Data.Coerce
-
-import System.IO.Unsafe
-
-defaultMain = do
-    emitter <- getRequireEmitter
-
-    on2 emitter "ghcjs-require:runexport" $ \name cb -> do
-        Just str <- fromJSVal name :: IO (Maybe JSString)
-        maction <- getExport (unpack str)
-        mvl <- case maction of
-            Just action -> action
-            Nothing -> return Nothing
-        case mvl of
-            Just vl -> call2 cb nullRef vl
-            Nothing -> call1 cb nullRef
-
-    emit0 emitter "ghcjs-require:loaded"
-
-foreign import javascript unsafe "$1()"
-   call0 :: JSVal -> IO ()
-
-foreign import javascript unsafe "$1($2)"
-   call1 :: JSVal -> JSVal -> IO ()
-
-foreign import javascript unsafe "$1($2, $3)"
-   call2 :: JSVal -> JSVal -> JSVal -> IO ()
-
-exports = unsafePerformIO (newMVar [])
-{-# NOINLINE exports #-}
-
-getExport :: String -> IO (Maybe (IO (Maybe JSVal)))
-getExport name = lookup name <$> readMVar exports
-
-registerExport :: String -> IO (Maybe JSVal) -> IO ()
-registerExport name action = modifyMVar_ exports $ \e ->
-    return $ (name, action):e
-
-require :: String -> IO JSVal
-require = js_require . fromString
-
-export :: String -> IO (Maybe JSVal) -> IO ()
-export name action = do
-    let name' = fromString name
-    registerExport name $ action
-    callback <- asyncCallback (void action)
-    js_export name' callback
-
-export0 name action = export name $ do
-    action
-    return Nothing
-
-getRequireEmitter :: IO EventEmitter
-getRequireEmitter = emitter <$> js_getRequireEmitter
-
-foreign import javascript unsafe "$r = require($1)"
-    js_require :: JSString -> IO JSVal
-
--- foreign import javascript unsafe "global.startAction"
---     js_startAction :: IO JSString
-
--- foreign import javascript unsafe "global.finishAction"
---     js_finishAction0 :: JSString -> IO ()
-
-foreign import javascript unsafe "global.exports[$1] = $2"
-    js_export :: JSString -> Callback a -> IO ()
-
-foreign import javascript unsafe "global.emitter"
-    js_getRequireEmitter :: IO Object

ghcjs-require/ghcjs-require.js

@@ -1,3 +1,4 @@
+const childProcess = require('child_process');
 const fs = require('fs');
 const path = require('path');
 
@@ -13,34 +14,29 @@ function generateWrapper(fp, mod) {
     const rts = fs.readFileSync(path.join(fp, '/rts.js'));
     const lib = fs.readFileSync(path.join(fp, '/lib.js'));
     const out = fs.readFileSync(path.join(fp, '/out.js'));
-    mod = rts.toString() + lib.toString() + out.toString();
+    mod =
+      rts.toString() +
+      lib.toString() +
+      out.toString();
   }
 
   return stripBOM(`
-    function mapValues(obj, fn) {
-      var keys = Object.keys(obj);
-      var ret = {}
-      for (var i = 0, len = keys.length; i < len; i++) {
-        var key = keys[i];
-        ret[key] = fn(obj[key], key);
-      }
-      return ret;
-    }
-
     exports = module.exports = function bootAndRunHaskellModule(onLoaded) {
       var md = exports.boot();
 
       md.emitter.on('ghcjs-require:loaded', function() {
-        md.wrapped = mapValues(md.exports, function(fn, key) {
-          return function() {
+        md.wrapped = md.wrappedExports.reduce(function(memo, key) {
+          memo[key] = function() {
+            var args = Array.prototype.slice.apply(arguments);
             return new Promise(function(resolve, reject) {
-              md.emitter.emit('ghcjs-require:runexport', key, function(err, result) {
+              md.emitter.emit('ghcjs-require:runexport', key, args, function(err, result) {
                 if (err) return reject(err);
                 resolve(result);
               });
             });
           };
-        });
+          return memo;
+        }, {});
 
         if (onLoaded) onLoaded(md);
       });
@@ -56,6 +52,7 @@ function generateWrapper(fp, mod) {
     exports.boot = function bootHaskellModule() {
       var global = {};
       global.exports = {};
+      global.wrappedExports = [];
       return (function(global, exports, module) {
         ${mod}
         ;
@@ -83,11 +80,40 @@ function addWrapper(fp) {
   fs.writeFileSync(path.join(fp, 'index.js'), idx);
 }
 
-function ghcjsRequire(fp) {
+function find(root) {
+  try {
+    const ls = fs.readdirSync(process.cwd()); // Replace with the module
+    if (ls.indexOf('.stack-work') > -1) {
+      const installRoot = childProcess.execSync('stack path --dist-dir', {
+        chdir: ls,
+      }).toString().split('\n')[0];
+      const bins = fs.readdirSync(path.join(installRoot, 'build', root));
+      const exeIdx = bins.indexOf(root + '.jsexe');
+      if (exeIdx > -1) {
+        const out = path.join(installRoot, 'build', root, bins[exeIdx]);
+        return out;
+      }
+    }
+  } catch (err) {
+    return null;
+  }
+}
+
+function ghcjsRequire(module, fp) {
+  if (path.extname(fp) !== '.jsexe') {
+    const jsexe = find(fp);
+    if (jsexe) {
+      return ghcjsRequire(module, jsexe)
+    }
+
+    throw new Error('Could not resolve Haskell source for ' + fp);
+  }
+
   addWrapper(fp);
-  return require(fp);
+  return module.require('./' + path.join(fp, 'index.js'));
 }
 
 exports = module.exports = ghcjsRequire;
 exports.addWrapper = addWrapper;
+exports.find = find;
 exports.generateWrapper = generateWrapper;