7 files changed, 456 insertions, 0 deletions

diff --git a/src/PursLoader/ChildProcess.purs b/src/PursLoader/ChildProcess.purs
new file mode 100644
index 0000000..34558fa
--- /dev/null
+++ b/src/PursLoader/ChildProcess.purs
@@ -0,0 +1,56 @@
+module PursLoader.ChildProcess
+  ( ChildProcess()
+  , spawn
+  ) where
+
+import Control.Monad.Aff (Aff(), makeAff)
+import Control.Monad.Eff (Eff())
+import Control.Monad.Eff.Exception (Error())
+
+import Data.Function
+
+foreign import data ChildProcess :: !
+
+spawn :: forall eff. String -> [String] -> Aff (cp :: ChildProcess | eff) String
+spawn command args = makeAff $ runFn4 spawnFn command args
+
+foreign import spawnFn """
+function spawnFn(command, args, errback, callback) {
+  return function(){
+    var child_process = require('child_process');
+
+    var process = child_process.spawn(command, args);
+
+    var stdout = new Buffer(0);
+
+    var stderr = new Buffer(0);
+
+    process.stdout.on('data', function(data){
+      stdout = Buffer.concat([stdout, new Buffer(data)]);
+    });
+
+    process.stderr.on('data', function(data){
+      stderr = Buffer.concat([stderr, new Buffer(data)]);
+    });
+
+    process.on('close', function(code){
+      var chalk = require('chalk');
+
+      var output = stdout.toString('utf-8');
+
+      var error = stderr.toString('utf-8');
+
+      if (error.length > 0) {
+         console.error('\n' + chalk.red('*') + ' ' + error);
+      }
+
+      if (code !== 0) errback(new Error('Process terminated with code ' + code))();
+      else callback(output)();
+    });
+  };
+}
+""" :: forall eff. Fn4 String
+                       [String]
+                       (Error -> Eff (cp :: ChildProcess | eff) Unit)
+                       (String -> Eff (cp :: ChildProcess | eff) Unit)
+                       (Eff (cp :: ChildProcess | eff) Unit)
diff --git a/src/PursLoader/FS.purs b/src/PursLoader/FS.purs
new file mode 100644
index 0000000..6955a63
--- /dev/null
+++ b/src/PursLoader/FS.purs
@@ -0,0 +1,67 @@
+module PursLoader.FS
+  ( FS()
+  , writeFileUtf8
+  , findFileUtf8
+  ) where
+
+import Control.Monad.Aff (Aff(), makeAff)
+import Control.Monad.Eff (Eff())
+import Control.Monad.Eff.Exception (Error())
+
+import Data.Maybe (Maybe(..))
+import Data.String.Regex (Regex())
+
+import Data.Function
+
+foreign import data FS :: !
+
+writeFileUtf8 :: forall eff. String -> String -> Aff (fs :: FS | eff) Unit
+writeFileUtf8 filepath contents = makeAff $ runFn4 writeFileUtf8Fn filepath contents
+
+foreign import writeFileUtf8Fn """
+function writeFileUtf8Fn(filepath, contents, errback, callback) {
+  return function(){
+    var fs = require('fs');
+
+    fs.writeFile(filepath, contents, function(error){
+      if (error) errback(error)();
+      else callback()();
+    });
+  };
+}
+""" :: forall eff. Fn4 String
+                       String
+                       (Error -> Eff (fs :: FS | eff) Unit)
+                       (Unit -> Eff (fs :: FS | eff) Unit)
+                       (Eff (fs :: FS | eff) Unit)
+
+findFileUtf8 :: forall eff. Regex -> [String] -> Aff (fs :: FS | eff) (Maybe String)
+findFileUtf8 regexp filepaths = makeAff $ runFn6 findFileUtf8Fn Nothing Just regexp filepaths
+
+foreign import findFileUtf8Fn """
+function findFileUtf8Fn(nothing, just, regex, filepaths, errback, callback) {
+  return function(){
+    var fs = require('fs');
+
+    var async = require('async');
+
+    function findFile(filepath, callback) {
+      fs.readFile(filepath, {encoding: 'utf-8'}, function(error, result){
+        if (error) callback(false);
+        else callback(regex.test(result));
+      });
+    }
+
+    async.detect(filepaths, findFile, function(result){
+      if (!result) callback(nothing)();
+      else callback(just(result))();
+    });
+  };
+}
+""" :: forall eff. Fn6 (Maybe String)
+                       (String -> Maybe String)
+                       Regex
+                       [String]
+                       (Error -> Eff (fs :: FS | eff) Unit)
+                       (Maybe String -> Eff (fs :: FS | eff) Unit)
+                       (Eff (fs :: FS | eff) Unit)
diff --git a/src/PursLoader/Glob.purs b/src/PursLoader/Glob.purs
new file mode 100644
index 0000000..392d9e4
--- /dev/null
+++ b/src/PursLoader/Glob.purs
@@ -0,0 +1,33 @@
+module PursLoader.Glob
+  ( Glob()
+  , globAll
+  ) where
+
+import Control.Monad.Aff (Aff(), makeAff)
+import Control.Monad.Eff (Eff())
+import Control.Monad.Eff.Exception (Error())
+
+import Data.Function
+
+foreign import data Glob :: !
+
+globAll :: forall eff. [String] -> Aff (glob :: Glob | eff) [[String]]
+globAll patterns = makeAff $ runFn3 globAllFn patterns
+
+foreign import globAllFn """
+function globAllFn(patterns, errback, callback) {
+  return function(){
+    var glob = require('glob');
+
+    var async = require('async');
+
+    async.map(patterns, glob, function(error, result){
+      if (error) errback(new Error(error))();
+      else callback(result)();
+    });
+  };
+}
+""" :: forall eff. Fn3 [String]
+                       (Error -> Eff (glob :: Glob | eff) Unit)
+                       ([[String]] -> Eff (glob :: Glob | eff) Unit)
+                       (Eff (glob :: Glob | eff) Unit)
diff --git a/src/PursLoader/Loader.purs b/src/PursLoader/Loader.purs
new file mode 100644
index 0000000..e9e03c4
--- /dev/null
+++ b/src/PursLoader/Loader.purs
@@ -0,0 +1,106 @@
+module PursLoader.Loader
+  ( Effects()
+  , loader
+  , loaderFn
+  ) where
+
+import Control.Monad.Aff (Aff(), runAff)
+import Control.Monad.Eff (Eff())
+import Control.Monad.Eff.Class (liftEff)
+import Control.Monad.Eff.Exception (error)
+
+import Data.Array ((!!), concat)
+import Data.Function (Fn2(), mkFn2)
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.String (joinWith)
+import Data.String.Regex (match, noFlags, regex, test)
+
+import PursLoader.ChildProcess (ChildProcess(), spawn)
+import PursLoader.FS (FS(), writeFileUtf8, findFileUtf8)
+import PursLoader.Glob (Glob(), globAll)
+import PursLoader.LoaderRef (LoaderRef(), Loader(), async, cacheable, query, clearDependencies, addDependency, resourcePath)
+import PursLoader.LoaderUtil (parseQuery)
+import PursLoader.Options (loaderFFIOption, loaderSrcOption, pscOptions)
+
+type Effects eff = (cp :: ChildProcess, fs :: FS, glob :: Glob, loader :: Loader | eff)
+
+moduleRegex = regex "(?:^|\\n)module\\s+([\\w\\.]+)" noFlags { ignoreCase = true }
+
+foreignRegex = regex "(?:^|\\n)\\s*foreign import\\s+" noFlags { ignoreCase = true }
+
+pscCommand = "psc"
+
+psciCommand = "psci"
+
+psciFilename = ".psci"
+
+(!!!) = flip (!!)
+
+foreign import cwd "var cwd = process.cwd();" :: String
+
+foreign import relative """
+function relative(from) {
+  return function(to){
+    var path = require('path');
+    return path.relative(from, to);
+  };
+}
+""" :: String -> String -> String
+
+mkPsci :: [[String]] -> [[String]] -> String
+mkPsci srcs ffis = joinWith "\n" ((loadModule <$> concat srcs) <> (loadForeign <$> concat ffis))
+  where
+    loadModule :: String -> String
+    loadModule a = ":m " ++ relative cwd a
+
+    loadForeign :: String -> String
+    loadForeign a = ":f " ++ relative cwd a
+
+findFFI :: forall eff. [[String]] -> String -> Aff (fs :: FS | eff) (Maybe String)
+findFFI ffiss name = findFileUtf8 re (concat ffiss)
+  where
+    re = regex ("(?:^|\\n)//\\s*module\\s*" ++ name ++ "\\s*\\n") noFlags
+
+loader' :: forall eff. LoaderRef -> String -> Aff (Effects eff) (Maybe String)
+loader' ref source = do
+  liftEff $ cacheable ref
+
+  let parsed = parseQuery $ query ref
+      srcs = fromMaybe [] (loaderSrcOption parsed)
+      ffis = fromMaybe [] (loaderFFIOption parsed)
+      opts = pscOptions parsed
+
+  spawn pscCommand (srcs <> opts)
+
+  srcss <- globAll srcs
+  ffiss <- globAll ffis
+
+  let psciFile = mkPsci srcss ffiss
+
+  writeFileUtf8 psciFilename psciFile
+
+  let moduleName = match moduleRegex source >>= (!!!) 1
+      hasForeign = test foreignRegex source
+      result = (\a -> "module.exports = require('" ++ a ++ "');") <$> moduleName
+
+  liftEff (clearDependencies ref)
+  liftEff (addDependency ref (resourcePath ref))
+
+  foreignPath <- if hasForeign
+                    then fromMaybe (pure Nothing) (findFFI ffiss <$> moduleName)
+                    else pure Nothing
+
+  fromMaybe (pure unit) ((\path -> liftEff (addDependency ref path)) <$> foreignPath)
+
+  return result
+
+loader :: forall eff. LoaderRef -> String -> Eff (Effects eff) Unit
+loader ref source = do
+  callback <- async ref
+  runAff (\e -> callback (Just e) "")
+         (maybe (callback (Just (error "Loader has failed to run")) "")
+                (callback Nothing))
+         (loader' ref source)
+
+loaderFn :: forall eff. Fn2 LoaderRef String (Eff (Effects eff) Unit)
+loaderFn = mkFn2 loader
diff --git a/src/PursLoader/LoaderRef.purs b/src/PursLoader/LoaderRef.purs
new file mode 100644
index 0000000..f1efa04
--- /dev/null
+++ b/src/PursLoader/LoaderRef.purs
@@ -0,0 +1,74 @@
+module PursLoader.LoaderRef
+  ( LoaderRef()
+  , Loader()
+  , async
+  , cacheable
+  , query
+  , clearDependencies
+  , addDependency
+  , resourcePath
+  ) where
+
+import Control.Monad.Eff (Eff())
+import Control.Monad.Eff.Exception (Error())
+
+import Data.Function (Fn3(), runFn3)
+import Data.Maybe (Maybe(), fromMaybe, isJust)
+
+data LoaderRef
+
+foreign import data Loader :: !
+
+foreign import asyncFn """
+function asyncFn(isJust, fromMaybe, ref){
+  return function(){
+    var callback = ref.async();
+    return function(error){
+      return function(value){
+        return function(){
+          return isJust(error) ? callback(fromMaybe(new Error())(error))
+                               : callback(null, value);
+        };
+      };
+    };
+  };
+}""" :: forall eff a. Fn3 (Maybe Error -> Boolean)
+                          (Error -> Maybe Error -> Error)
+                          LoaderRef
+                          (Eff (loader :: Loader | eff) (Maybe Error -> a -> Eff (loader :: Loader | eff) Unit))
+
+async :: forall eff a. LoaderRef -> Eff (loader :: Loader | eff) (Maybe Error -> a -> Eff (loader :: Loader | eff) Unit)
+async ref = runFn3 asyncFn isJust fromMaybe ref
+
+foreign import cacheable """
+function cacheable(ref){
+  return function(){
+    return ref.cacheable && ref.cacheable();
+  };
+}""" :: forall eff. LoaderRef -> Eff (loader :: Loader | eff) Unit
+
+foreign import query """
+function query(ref){
+  return ref.query;
+}""" :: LoaderRef -> String
+
+foreign import clearDependencies """
+function clearDependencies(ref){
+  return function(){
+    return ref.clearDependencies();
+  };
+}""" :: forall eff. LoaderRef -> Eff (loader :: Loader | eff) Unit
+
+foreign import resourcePath """
+function resourcePath(ref){
+  return ref.resourcePath;
+}""" :: LoaderRef -> String
+
+foreign import addDependency """
+function addDependency(ref){
+  return function(dep){
+    return function(){
+      return ref.addDependency(dep);
+    };
+  };
+}""" :: forall eff. LoaderRef -> String -> Eff (loader :: Loader | eff) Unit
diff --git a/src/PursLoader/LoaderUtil.purs b/src/PursLoader/LoaderUtil.purs
new file mode 100644
index 0000000..86be124
--- /dev/null
+++ b/src/PursLoader/LoaderUtil.purs
@@ -0,0 +1,13 @@
+module PursLoader.LoaderUtil
+  ( parseQuery
+  ) where
+
+import Data.Foreign (Foreign())
+
+import PursLoader.LoaderRef (LoaderRef())
+
+foreign import parseQuery """
+function parseQuery(query){
+  var loaderUtils = require('loader-utils');
+  return loaderUtils.parseQuery(query);
+}""" :: String -> Foreign
diff --git a/src/PursLoader/Options.purs b/src/PursLoader/Options.purs
new file mode 100644
index 0000000..51e9be5
--- /dev/null
+++ b/src/PursLoader/Options.purs
@@ -0,0 +1,107 @@
+module PursLoader.Options
+  ( pscOptions
+  , loaderSrcOption
+  , loaderFFIOption
+  ) where
+
+import Data.Array (concat)
+import Data.Either (either)
+
+import Data.Foreign (Foreign(), F())
+import Data.Foreign.Class (IsForeign, read, readProp)
+import Data.Foreign.NullOrUndefined (NullOrUndefined(..), runNullOrUndefined)
+
+import Data.Maybe (Maybe(..), maybe, fromMaybe)
+
+noPreludeOpt = "no-prelude"
+
+noOptsOpt = "no-opts"
+
+noMagicDoOpt = "no-magic-do"
+
+noTcoOpt = "no-tco"
+
+verboseErrorsOpt = "verbose-errors"
+
+outputOpt = "output"
+
+commentsOpt = "comments"
+
+noPrefixOpt = "no-prefix"
+
+requirePathOpt = "require-path"
+
+srcOpt = "src"
+
+ffiOpt = "ffi"
+
+newtype Options
+  = Options { noPrelude :: NullOrUndefined Boolean
+            , noOpts :: NullOrUndefined Boolean
+            , noMagicDo :: NullOrUndefined Boolean
+            , noTco :: NullOrUndefined Boolean
+            , verboseErrors :: NullOrUndefined Boolean
+            , comments :: NullOrUndefined Boolean
+            , output :: NullOrUndefined String
+            , noPrefix :: NullOrUndefined Boolean
+            , requirePath :: NullOrUndefined String
+            , src :: NullOrUndefined [String]
+            , ffi :: NullOrUndefined [String]
+            }
+
+instance isForeignOptions :: IsForeign Options where
+  read obj = Options <$> ({ noPrelude: _
+                          , noOpts: _
+                          , noMagicDo: _
+                          , noTco: _
+                          , verboseErrors: _
+                          , comments: _
+                          , output: _
+                          , noPrefix: _
+                          , requirePath: _
+                          , src: _
+                          , ffi: _
+                          } <$> readProp noPreludeOpt obj
+                            <*> readProp noOptsOpt obj
+                            <*> readProp noMagicDoOpt obj
+                            <*> readProp noTcoOpt obj
+                            <*> readProp verboseErrorsOpt obj
+                            <*> readProp commentsOpt obj
+                            <*> readProp outputOpt obj
+                            <*> readProp noPrefixOpt obj
+                            <*> readProp requirePathOpt obj
+                            <*> readProp srcOpt obj
+                            <*> readProp ffiOpt obj)
+
+class LoaderOption a where
+  opt :: String -> NullOrUndefined a -> [String]
+
+instance booleanLoaderOption :: LoaderOption Boolean where
+  opt key val = maybe [] (\a -> if a then ["--" ++ key] else []) (runNullOrUndefined val)
+
+instance stringLoaderOption :: LoaderOption String where
+  opt key val = maybe [] (\a -> ["--" ++ key ++ "=" ++ a]) (runNullOrUndefined val)
+
+instance arrayLoaderOption :: (LoaderOption a) => LoaderOption [a] where
+  opt key val = concat (opt key <$> (NullOrUndefined <<< Just)
+                                <$> (fromMaybe [] (runNullOrUndefined val)))
+
+pscOptions :: Foreign -> [String]
+pscOptions query = either (const []) fold parsed
+  where parsed = read query :: F Options
+        fold (Options a) = opt noPreludeOpt a.noPrelude <>
+                           opt noOptsOpt a.noOpts <>
+                           opt noMagicDoOpt a.noMagicDo <>
+                           opt noTcoOpt a.noTco <>
+                           opt verboseErrorsOpt a.verboseErrors <>
+                           opt commentsOpt a.comments <>
+                           opt outputOpt a.output <>
+                           opt noPrefixOpt a.noPrefix <>
+                           opt requirePathOpt a.requirePath <>
+                           opt ffiOpt a.ffi
+
+loaderSrcOption :: Foreign -> Maybe [String]
+loaderSrcOption query = either (const Nothing) (\(Options a) -> runNullOrUndefined a.src) (read query)
+
+loaderFFIOption :: Foreign -> Maybe [String]
+loaderFFIOption query = either (const Nothing) (\(Options a) -> runNullOrUndefined a.ffi) (read query)