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,66 +22,43 @@ 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 =
+externalDirectivesFromFile :: FilePath -> Aff (Map EvalRef InlineDirective)
-  { coreFnDir :: FilePath
+externalDirectivesFromFile filePath = do
-  , outputDir :: FilePath
+  fileContent <- FS.readTextFile UTF8 filePath
-  , foreignDir :: Maybe FilePath
+  let { errors, directives } = parseDirectiveFile fileContent
-  , directivesFile :: Maybe FilePath
+  for_ errors \(Tuple directive { position, error }) -> do
-  }
+    Console.warn $ "Invalid directive [" <> show (position.line + 1) <> ":" <> show (position.column + 1) <> "]"
-
+    Console.warn $ "  " <> directive
-basicArgParser :: FilePath -> ArgParser BasicCliArgs
+    Console.warn $ "  " <> printParseError error
-basicArgParser defaultOutputDir =
+  pure directives
-  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
+  :: forall args
+   . { name :: String
      , description :: String
-     , defaultOutputDir :: FilePath
+     , argParser :: ArgParser args
-     , onCodegenBefore :: BasicCliArgs -> Aff Unit
+     , resolveCoreFnDirectory :: args -> Aff FilePath
-     , onCodegenAfter :: BasicCliArgs -> Aff Unit
+     , resolveExternalDirectives ::  args -> Aff (Map EvalRef InlineDirective)
-     , onCodegenModule :: BasicCliArgs -> BuildEnv -> Module Ann -> BackendModule -> Aff Unit
+     , onCodegenBefore :: args -> Aff Unit
-     , onPrepareModule :: BasicCliArgs -> BuildEnv -> Module Ann -> Aff (Module Ann)
+     , 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
-  let
+  case ArgParser.parseArgs options.name options.description options.argParser cliArgs of
-    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
+    Right args -> launchAff_ do
-      externalDirectives <- fromMaybe Map.empty <$> for directivesFile \filePath -> do
+      { coreFnDir, externalDirectives } <- sequential do
-        fileContent <- FS.readTextFile UTF8 filePath
+        { coreFnDir: _, externalDirectives: _ }
-        let { errors, directives } = parseDirectiveFile fileContent
+          <$> parallel (options.resolveCoreFnDirectory args)
-        for_ errors \(Tuple directive { position, error }) -> do
+          <*> parallel (options.resolveExternalDirectives args)
-          Console.warn $ "Invalid directive [" <> show (position.line + 1) <> ":" <> show (position.column + 1) <> "]"
-          Console.warn $ "  " <> directive
-          Console.warn $ "  " <> printParseError error
-        pure directives
       let defaultDirectives = (parseDirectiveFile Defaults.defaultDirectives).directives
       let allDirectives = Map.union externalDirectives defaultDirectives
       coreFnModulesFromOutput coreFnDir >>= case _ of