Merge pull request #8 from ethul/topic/purescript-rewrite

Topic/purescript rewrite

9 files changed, 436 insertions, 0 deletions

diff --git a/src/ChildProcess.purs b/src/ChildProcess.purs
new file mode 100644
index 0000000..c9ff23b
--- /dev/null
+++ b/src/ChildProcess.purs
@@ -0,0 +1,40 @@
+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);
+
+    process.stdout.on('data', function(data){
+      stdout = Buffer.concat([stdout, new Buffer(data)]);
+    });
+
+    process.on('close', function(code){
+      if (code !== 0) errback(new Error(stdout.toString()))();
+      else callback(stdout.toString())();
+    });
+  };
+}
+""" :: 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/FS.purs b/src/FS.purs
new file mode 100644
index 0000000..68fe2f9
--- /dev/null
+++ b/src/FS.purs
@@ -0,0 +1,45 @@
+module PursLoader.FS
+  ( FS()
+  , readFileUtf8
+  , readFileUtf8Sync
+  ) where
+
+import Control.Monad.Aff (Aff(), makeAff)
+import Control.Monad.Eff (Eff())
+import Control.Monad.Eff.Exception (Error())
+
+import Data.Function
+
+foreign import data FS :: !
+
+readFileUtf8 :: forall eff. String -> Aff (fs :: FS | eff) String
+readFileUtf8 filepath = makeAff $ runFn3 readFileUtf8Fn filepath
+
+readFileUtf8Sync :: forall eff. String -> Eff (fs :: FS | eff) String
+readFileUtf8Sync filepath = readFileUtf8SyncFn filepath
+
+foreign import readFileUtf8Fn """
+function readFileUtf8Fn(filepath, errback, callback) {
+  return function(){
+    var fs = require('fs');
+
+    fs.readFile(filepath, 'utf-8', function(e, data){
+      if (e) errback(e)();
+      else callback(data)();
+    });
+  };
+}
+""" :: forall eff. Fn3 String
+                       (Error -> Eff (fs :: FS | eff) Unit)
+                       (String -> Eff (fs :: FS | eff) Unit)
+                       (Eff (fs :: FS | eff) Unit)
+
+foreign import readFileUtf8SyncFn """
+function readFileUtf8SyncFn(filepath) {
+  return function(){
+    var fs = require('fs');
+
+    return fs.readFileSync(filepath, {encoding: 'utf-8'});
+  };
+}
+""" :: forall eff. String -> (Eff (fs :: FS | eff) String)
diff --git a/src/Glob.purs b/src/Glob.purs
new file mode 100644
index 0000000..7bc9212
--- /dev/null
+++ b/src/Glob.purs
@@ -0,0 +1,31 @@
+module PursLoader.Glob
+  ( Glob()
+  , glob
+  ) 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 :: !
+
+glob :: forall eff. String -> Aff (glob :: Glob | eff) [String]
+glob pattern = makeAff $ runFn3 globFn pattern
+
+foreign import globFn """
+function globFn(pattern, errback, callback) {
+  return function(){
+    var glob = require('glob');
+
+    glob(pattern, function(e, data){
+      if (e) errback(e)();
+      else callback(data)();
+    });
+  };
+}
+""" :: 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/Loader.purs b/src/Loader.purs
new file mode 100644
index 0000000..523aa7a
--- /dev/null
+++ b/src/Loader.purs
@@ -0,0 +1,114 @@
+module PursLoader.Loader
+  ( LoaderEff()
+  , 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 ((!!), catMaybes, concat, nub, null)
+import Data.Function (Fn2(), mkFn2)
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.String (joinWith, split)
+import Data.String.Regex (Regex(), match, noFlags, regex)
+import Data.StrMap (StrMap(), fromList, lookup)
+import Data.Traversable (sequence)
+import Data.Tuple.Nested (tuple2)
+
+import PursLoader.ChildProcess (ChildProcess(), spawn)
+import PursLoader.FS (FS(), readFileUtf8, readFileUtf8Sync)
+import PursLoader.Glob (Glob(), glob)
+import PursLoader.LoaderRef (LoaderRef(), Loader(), async, cacheable, clearDependencies, addDependency, query, resourcePath)
+import PursLoader.LoaderUtil (getRemainingRequest, parseQuery)
+import PursLoader.OS (eol)
+import PursLoader.Options (pscMakeOptions, pscMakeDefaultOutput, pscMakeOutputOption)
+import PursLoader.Path (dirname, join, relative, resolve)
+
+foreign import cwd "var cwd = process.cwd();" :: String
+
+moduleRegex = regex "(?:^|\\n)module\\s+([\\w\\.]+)" noFlags { ignoreCase = true }
+
+importRegex = regex "^\\s*import\\s+(?:qualified\\s+)?([\\w\\.]+)" noFlags { ignoreCase = true }
+
+bowerPattern = join [ "bower_components", "purescript-*", "src" ]
+
+pscMakeCommand = "psc-make"
+
+indexFilename = "index.js"
+
+(!!!) = flip (!!)
+
+pursPattern :: String -> String
+pursPattern root = join [ "{" ++ joinWith "," [ bowerPattern, root ] ++ "}"
+                        , "**"
+                        , "*.purs"
+                        ]
+
+type GraphModule = { file :: String, imports :: [String] }
+
+type Graph = StrMap GraphModule
+
+mkGraph :: forall eff. [String] -> Eff (fs :: FS | eff) Graph
+mkGraph files = (fromList <<< catMaybes) <$> sequence (parse <$> files)
+  where parse file = do source <- readFileUtf8Sync file
+                        let key = match moduleRegex source >>= (!!!) 1
+                            lines = split eol source
+                            imports = catMaybes $ (\a -> match importRegex a >>= (!!!) 1) <$> lines
+                        return $ (\a -> tuple2 a { file: file, imports: imports }) <$> key
+
+mkDeps :: forall eff. String -> Graph -> [String]
+mkDeps key graph = nub $ go [] key
+  where go acc key =
+    maybe acc (\a -> if null a.imports
+                       then acc
+                       else concat $ go (acc <> a.imports) <$> a.imports) (lookup key graph)
+
+addDeps :: forall eff. LoaderRef -> Graph -> [String] -> Eff (loader :: Loader | eff) Unit
+addDeps ref graph deps = const unit <$> (sequence $ add <$> deps)
+  where add dep = let res = lookup dep graph
+                      path = (\a -> resolve a.file) <$> res
+                   in maybe (pure unit) (addDependency ref) path
+
+type LoaderAff eff a = Aff (loader :: Loader, glob :: Glob, cp :: ChildProcess, fs :: FS | eff) a
+
+loader' :: forall eff. LoaderRef -> String -> LoaderAff eff (Maybe String)
+loader' ref source = do
+  liftEff $ cacheable ref
+
+  let request = getRemainingRequest ref
+      root = dirname $ relative cwd request
+      parsed = parseQuery $ query ref
+      opts = pscMakeOptions parsed
+      pattern = pursPattern root
+      key = match moduleRegex source >>= (!!!) 1
+
+  files <- glob pattern
+  graph <- liftEff $ mkGraph files
+
+  let deps = fromMaybe [] $ flip mkDeps graph <$> key
+      outputPath = fromMaybe pscMakeDefaultOutput $ pscMakeOutputOption parsed
+      indexPath = (\a -> join [ outputPath, a, indexFilename ]) <$> key
+
+  liftEff $ clearDependencies ref
+  liftEff $ addDependency ref (resourcePath ref)
+  liftEff $ addDeps ref graph deps
+
+  spawn pscMakeCommand (opts <> files)
+  indexFile <- sequence $ readFileUtf8 <$> indexPath
+  return indexFile
+
+type LoaderEff eff a = Eff (loader :: Loader, glob :: Glob, cp :: ChildProcess, fs :: FS | eff) a
+
+loader :: forall eff. LoaderRef -> String -> LoaderEff 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 (LoaderEff eff Unit)
+loaderFn = mkFn2 loader
diff --git a/src/LoaderRef.purs b/src/LoaderRef.purs
new file mode 100644
index 0000000..2d62754
--- /dev/null
+++ b/src/LoaderRef.purs
@@ -0,0 +1,75 @@
+module PursLoader.LoaderRef
+  ( LoaderRef()
+  , Loader()
+  , async
+  , cacheable
+  , clearDependencies
+  , resourcePath
+  , addDependency
+  , query
+  ) where
+
+import Control.Monad.Eff (Eff())
+import Control.Monad.Eff.Exception (Error())
+
+import Data.Foreign (Foreign())
+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 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
+
+foreign import query """
+function query(ref){
+  return ref.query;
+}""" :: LoaderRef -> String
diff --git a/src/LoaderUtil.purs b/src/LoaderUtil.purs
new file mode 100644
index 0000000..f22be44
--- /dev/null
+++ b/src/LoaderUtil.purs
@@ -0,0 +1,20 @@
+module PursLoader.LoaderUtil
+  ( getRemainingRequest
+  , parseQuery
+  ) where
+
+import Data.Foreign (Foreign())
+
+import PursLoader.LoaderRef (LoaderRef())
+
+foreign import getRemainingRequest """
+function getRemainingRequest(ref){
+  var loaderUtils = require('loader-utils');
+  return loaderUtils.getRemainingRequest(ref);
+}""" :: LoaderRef -> String
+
+foreign import parseQuery """
+function parseQuery(query){
+  var loaderUtils = require('loader-utils');
+  return loaderUtils.parseQuery(query);
+}""" :: String -> Foreign
diff --git a/src/OS.purs b/src/OS.purs
new file mode 100644
index 0000000..590c3d6
--- /dev/null
+++ b/src/OS.purs
@@ -0,0 +1,3 @@
+module PursLoader.OS (eol) where
+
+foreign import eol "var eol = require('os').EOL;" :: String
diff --git a/src/Options.purs b/src/Options.purs
new file mode 100644
index 0000000..b96cddc
--- /dev/null
+++ b/src/Options.purs
@@ -0,0 +1,72 @@
+module PursLoader.Options
+  ( pscMakeOptions
+  , pscMakeDefaultOutput
+  , pscMakeOutputOption
+  ) where
+
+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)
+
+noPreludeOpt = "no-prelude"
+
+noOptsOpt = "no-opts"
+
+noMagicDoOpt = "no-magic-do"
+
+noTcoOpt = "no-tco"
+
+verboseErrorsOpt = "verbose-errors"
+
+outputOpt = "output"
+
+pscMakeDefaultOutput = "output"
+
+newtype Options
+  = Options { noPrelude :: NullOrUndefined Boolean
+            , noOpts :: NullOrUndefined Boolean
+            , noMagicDo :: NullOrUndefined Boolean
+            , noTco :: NullOrUndefined Boolean
+            , verboseErrors :: NullOrUndefined Boolean
+            , output :: NullOrUndefined String
+            }
+
+instance isForeignOptions :: IsForeign Options where
+  read obj = (\a b c d e f ->
+             Options { noPrelude: a
+                     , noOpts: b
+                     , noMagicDo: c
+                     , noTco: d
+                     , verboseErrors: e
+                     , output: f
+                     }) <$> readProp noPreludeOpt obj
+                        <*> readProp noOptsOpt obj
+                        <*> readProp noMagicDoOpt obj
+                        <*> readProp noTcoOpt obj
+                        <*> readProp verboseErrorsOpt obj
+                        <*> readProp outputOpt obj
+
+booleanOpt :: String -> NullOrUndefined Boolean -> [String]
+booleanOpt key opt = maybe [] (\a -> if a then ["--" ++ key] else []) (runNullOrUndefined opt)
+
+stringOpt :: String -> NullOrUndefined String -> [String]
+stringOpt key opt = maybe [] (\a -> ["--" ++ key ++ "=" ++ a]) (runNullOrUndefined opt)
+
+pscMakeOutputOption :: Foreign -> Maybe String
+pscMakeOutputOption query = either (const Nothing)
+                                   (\(Options a) -> runNullOrUndefined a.output)
+                                   (read query)
+
+pscMakeOptions :: Foreign -> [String]
+pscMakeOptions query = either (const []) fold parsed
+  where parsed = read query :: F Options
+        fold (Options a) = booleanOpt noPreludeOpt a.noPrelude <>
+                           booleanOpt noOptsOpt a.noOpts <>
+                           booleanOpt noMagicDoOpt a.noMagicDo <>
+                           booleanOpt noTcoOpt a.noTco <>
+                           booleanOpt verboseErrorsOpt a.verboseErrors <>
+                           stringOpt outputOpt a.output
diff --git a/src/Path.purs b/src/Path.purs
new file mode 100644
index 0000000..e071e35
--- /dev/null
+++ b/src/Path.purs
@@ -0,0 +1,36 @@
+module PursLoader.Path
+  ( dirname
+  , join
+  , relative
+  , resolve
+  ) where
+
+foreign import dirname """
+function dirname(filepath) {
+  var path = require('path');
+  return path.dirname(filepath);
+}
+""" :: String -> String
+
+foreign import join """
+function join(parts) {
+  var path = require('path');
+  return path.join.apply(path, parts);
+}
+""" :: [String] -> String
+
+foreign import relative """
+function relative(from) {
+  return function(to){
+    var path = require('path');
+    return path.relative(from, to);
+  };
+}
+""" :: String -> String -> String
+
+foreign import resolve """
+function resolve(filepath) {
+  var path = require('path');
+  return path.resolve(filepath);
+}
+""" :: String -> String