Streamline basicCliMain

.gitignore

@@ -11,5 +11,6 @@
 /.purs*
 /.psa*
 /.spago
+/.vscode
 /*.purs*
 /**/.DS_Store

src/Main.purs

@@ -2,16 +2,20 @@ module Main where
 
 import Prelude
 
+import ArgParse.Basic (ArgParser)
+import ArgParse.Basic as ArgParser
 import Control.Plus (empty)
 import Data.Array as Array
 import Data.Either (Either(..), isRight)
 import Data.Foldable (oneOf)
-import Data.Maybe (fromMaybe, maybe)
+import Data.Map as Map
+import Data.Maybe (Maybe, fromMaybe, maybe)
 import Data.Monoid (power)
 import Data.Newtype (unwrap)
 import Data.String (Pattern(..))
 import Data.String as String
 import Data.String.CodeUnits as SCU
+import Data.Traversable (traverse)
 import Dodo as Dodo
 import Effect (Effect)
 import Effect.Aff (Aff, attempt, effectCanceler, error, makeAff, throwError)
@@ -25,15 +29,46 @@ import Node.FS.Stream (createReadStream, createWriteStream)
 import Node.Path (FilePath)
 import Node.Path as Path
 import Node.Stream as Stream
-import PureScript.Backend.Builder.Cli (basicCliMain)
+import PureScript.Backend.Builder.Cli (basicCliMain, externalDirectivesFromFile)
 import PureScript.Backend.Codegen.EcmaScript (esCodegenModule, esModulePath)
 import PureScript.CoreFn (Module(..), ModuleName(..))
 
+type BasicCliArgs =
+  { coreFnDir :: FilePath
+  , outputDir :: FilePath
+  , foreignDir :: Maybe FilePath
+  , directivesFile :: Maybe FilePath
+  }
+
+esArgParser :: ArgParser BasicCliArgs
+esArgParser =
+  ArgParser.fromRecord
+    { coreFnDir:
+        ArgParser.anyNotFlag "COREFN_DIR"
+          "Directory for corefn.json files."
+          # ArgParser.default "output"
+    , outputDir:
+        ArgParser.argument [ "--output-dir" ]
+          "Output directory for backend files"
+          # ArgParser.default (Path.concat [ ".", "output-es" ])
+    , foreignDir:
+        ArgParser.argument [ "--foreign-dir" ]
+          "Directory for foreign module implementations"
+          # ArgParser.optional
+    , directivesFile:
+        ArgParser.argument [ "--directives" ]
+          "Path to file that defines external inline directives"
+          # ArgParser.optional
+    }
+    <* ArgParser.flagHelp
+
 main :: FilePath -> Effect Unit
 main cliRoot = basicCliMain
   { name: "purs-backend-es"
   , description: "A PureScript backend for modern ECMAScript."
-  , defaultOutputDir: Path.concat [ ".", "output-es" ]
+  , argParser: esArgParser
+  , resolveCoreFnDirectory: pure <<< _.coreFnDir
+  , resolveExternalDirectives: map (fromMaybe Map.empty) <<< traverse externalDirectivesFromFile <<< _.directivesFile
   , onCodegenBefore: \args -> do
       mkdirp args.outputDir
       writeTextFile UTF8 (Path.concat [ args.outputDir, "package.json" ]) esModulePackageJson

src/PureScript/Backend/Builder/Cli.purs

@@ -7,12 +7,11 @@ import ArgParse.Basic as ArgParser
 import Data.Array as Array
 import Data.Either (Either(..))
 import Data.Foldable (for_)
+import Data.Map (Map)
 import Data.Map as Map
-import Data.Maybe (Maybe, fromMaybe)
-import Data.Traversable (for)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
-import Effect.Aff (Aff, launchAff_)
+import Effect.Aff (Aff, launchAff_, parallel, sequential)
 import Effect.Class (liftEffect)
 import Effect.Class.Console as Console
 import Node.Encoding (Encoding(..))
@@ -23,59 +22,12 @@ import PureScript.Backend.Builder (BuildEnv, buildModules, coreFnModulesFromOutp
 import PureScript.Backend.Convert (BackendModule)
 import PureScript.Backend.Directives (parseDirectiveFile)
 import PureScript.Backend.Directives.Defaults as Defaults
+import PureScript.Backend.Semantics (EvalRef, InlineDirective)
 import PureScript.CST.Errors (printParseError)
 import PureScript.CoreFn (Ann, Module)
 
-type BasicCliArgs =
-  { coreFnDir :: FilePath
-  , outputDir :: FilePath
-  , foreignDir :: Maybe FilePath
-  , directivesFile :: Maybe FilePath
-  }
-
-basicArgParser :: FilePath -> ArgParser BasicCliArgs
-basicArgParser defaultOutputDir =
-  ArgParser.fromRecord
-    { coreFnDir:
-        ArgParser.anyNotFlag "COREFN_DIR"
-          "Directory for corefn.json files."
-    , outputDir:
-        ArgParser.argument [ "--output-dir" ]
-          "Output directory for backend files"
-          # ArgParser.default defaultOutputDir
-    , foreignDir:
-        ArgParser.argument [ "--foreign-dir" ]
-          "Directory for foreign module implementations"
-          # ArgParser.optional
-    , directivesFile:
-        ArgParser.argument [ "--directives" ]
-          "Path to file that defines external inline directives"
-          # ArgParser.optional
-    }
-    <* ArgParser.flagHelp
-
-basicCliMain
-  :: { name :: String
-     , description :: String
-     , defaultOutputDir :: FilePath
-     , onCodegenBefore :: BasicCliArgs -> Aff Unit
-     , onCodegenAfter :: BasicCliArgs -> Aff Unit
-     , onCodegenModule :: BasicCliArgs -> BuildEnv -> Module Ann -> BackendModule -> Aff Unit
-     , onPrepareModule :: BasicCliArgs -> BuildEnv -> Module Ann -> Aff (Module Ann)
-     }
-  -> Effect Unit
-basicCliMain options = do
-  cliArgs <- Array.drop 2 <$> Process.argv
-  let
-    parsedArgs =
-      ArgParser.parseArgs options.name options.description
-        (basicArgParser options.defaultOutputDir)
-        cliArgs
-  case parsedArgs of
-    Left err ->
-      Console.error $ ArgParser.printArgError err
-    Right args@{ coreFnDir, directivesFile } -> launchAff_ do
-      externalDirectives <- fromMaybe Map.empty <$> for directivesFile \filePath -> do
+externalDirectivesFromFile :: FilePath -> Aff (Map EvalRef InlineDirective)
+externalDirectivesFromFile filePath = do
   fileContent <- FS.readTextFile UTF8 filePath
   let { errors, directives } = parseDirectiveFile fileContent
   for_ errors \(Tuple directive { position, error }) -> do
@@ -83,6 +35,30 @@ basicCliMain options = do
     Console.warn $ "  " <> directive
     Console.warn $ "  " <> printParseError error
   pure directives
+
+basicCliMain
+  :: forall args
+   . { name :: String
+     , description :: String
+     , argParser :: ArgParser args
+     , resolveCoreFnDirectory :: args -> Aff FilePath
+     , resolveExternalDirectives ::  args -> Aff (Map EvalRef InlineDirective)
+     , onCodegenBefore :: args -> Aff Unit
+     , onCodegenAfter :: args -> Aff Unit
+     , onCodegenModule :: args -> BuildEnv -> Module Ann -> BackendModule -> Aff Unit
+     , onPrepareModule :: args -> BuildEnv -> Module Ann -> Aff (Module Ann)
+     }
+  -> Effect Unit
+basicCliMain options = do
+  cliArgs <- Array.drop 2 <$> Process.argv
+  case ArgParser.parseArgs options.name options.description options.argParser cliArgs of
+    Left err ->
+      Console.error $ ArgParser.printArgError err
+    Right args -> launchAff_ do
+      { coreFnDir, externalDirectives } <- sequential do
+        { coreFnDir: _, externalDirectives: _ }
+          <$> parallel (options.resolveCoreFnDirectory args)
+          <*> parallel (options.resolveExternalDirectives args)
       let defaultDirectives = (parseDirectiveFile Defaults.defaultDirectives).directives
       let allDirectives = Map.union externalDirectives defaultDirectives
       coreFnModulesFromOutput coreFnDir >>= case _ of