Factor out build and CLI utils. (#8)

* Factor out build and CLI utils.

Additionally, this adds support for inline directives in module headers. This lets you
declare module local directives (for any module binding) and exported directives (for
local module bindings).

* Trailing newline

.editorconfig

@@ -0,0 +1,9 @@
+root = true
+
+[*]
+indent_style = space
+indent_size = 2
+end_of_line = lf
+charset = utf-8
+trim_trailing_whitespace = true
+insert_final_newline = true

examples/Example9.purs

@@ -1,3 +1,8 @@
+-- @inline Data.Variant.on arity=4
+-- @inline Heterogeneous.Mapping.hmapRecord arity=2
+-- @inline Heterogeneous.Mapping.hmapWithIndexRecord arity=2
+-- @inline Heterogeneous.Mapping.mapRecordWithIndexCons arity=5
+-- @inline Heterogeneous.Mapping.mapRecordWithIndexNil.mapRecordWithIndexBuilder arity=2
 module Example9 where
 
 import Prelude
@@ -74,4 +79,4 @@ test7 = zipRecord
 test8 = do
   let bar = { bar: "world" }
   let wat = { foo: "hello", bar }
-  \_ -> wat.foo <> ", " <> wat.bar.bar
+  \_ -> wat.foo <> ", " <> wat.bar.bar

examples/ExampleDirectives.purs

@@ -1,3 +1,24 @@
+-- @inline ExampleDirectives.inlineNever never
+-- @inline ExampleDirectives.inlineAlways always
+-- @inline ExampleDirectives.inlineArity3 arity=3
+-- @inline ExampleDirectives.classNameBoxNever.classMember never
+-- @inline ExampleDirectives.classNameBoxAlways.classMember always
+-- @inline ExampleDirectives.classNameBoxArity3.classMember arity=3
+-- @inline ExampleDirectives.classNameSuperBoxNever.classMember never
+
+-- Since this dictionary takes a dictionary as an argument,
+-- we need to inline the call to that function
+-- in addition to its member's call.
+-- @inline ExampleDirectives.classNameSuperBoxAlways always
+-- @inline ExampleDirectives.classNameSuperBoxAlways.classMember always
+
+-- Adding the `InlineArity 3` directive to `classNameSuperBoxArity3` does nothing
+-- because it only takes 1 arg.
+-- We would need 2 more args before the inlining would trigger.
+-- We could fix this by changing the arity to 1.
+-- @inline ExampleDirectives.classNameSuperBoxArity3 arity=3
+-- @inline ExampleDirectives.classNameSuperBoxArity3.classMember arity=3
+
 module ExampleDirectives where
 
 import Prelude

index.js

@@ -1,10 +1,3 @@
 #!/usr/bin/env node
-
-import { dirname } from 'path';
-import { fileURLToPath } from 'url';
-
 import { main } from "./output/Main/index.js";
-
-const __dirname = dirname(fileURLToPath(import.meta.url));
-
-main(__dirname)();
+main();

package.json

@@ -2,7 +2,7 @@
   "private": true,
   "type": "module",
   "scripts": {
-    "test-examples": "spago build && (cd examples; spago build -u \"-g corefn\") && node --stack-trace-limit=100 index.js build \"examples/output\" --directives ps-directives.txt",
+    "test-examples": "spago build && (cd examples; spago build -u \"-g corefn\") && node --stack-trace-limit=100 index.js \"examples/output\" --directives ps-directives.txt",
     "benchmark": "node --expose-gc --input-type=module -e \"import { main } from \\\"./output-es/Benchmarks.js\\\"; main()\""
   }
 }

ps-directives.txt

@@ -1,34 +1,9 @@
--- Syntax: 
+-- Syntax:
 -- Path.To.Module.identifier <directive>
 -- Path.To.Module.typeClassInstanceName.memberName <directive>
 --
 -- where <directive> is
+--  'default' - use default heuristics
 --  'always' - always inline
 --  'never' - never inline
---  <positive-int> - inline once <positive-int> args have been passed to function
-ExampleDirectives.inlineNever never
-ExampleDirectives.inlineAlways always
-ExampleDirectives.inlineArity3 3
-ExampleDirectives.classNameBoxNever.classMember never
-ExampleDirectives.classNameBoxAlways.classMember always
-ExampleDirectives.classNameBoxArity3.classMember 3
-ExampleDirectives.classNameSuperBoxNever.classMember never
-
--- Since this dictionary takes a dictionary as an argument,
--- we need to inline the call to that function
--- in addition to its member's call.
-ExampleDirectives.classNameSuperBoxAlways always
-ExampleDirectives.classNameSuperBoxAlways.classMember always
-
--- Adding the `InlineArity 3` directive to `classNameSuperBoxArity3` does nothing
--- because it only takes 1 arg.
--- We would need 2 more args before the inlining would trigger.
--- We could fix this by changing the arity to 1.
-ExampleDirectives.classNameSuperBoxArity3 3
-ExampleDirectives.classNameSuperBoxArity3.classMember 3
-
-Data.Variant.on 4
-Heterogeneous.Mapping.hmapRecord 2
-Heterogeneous.Mapping.hmapWithIndexRecord 2
-Heterogeneous.Mapping.mapRecordWithIndexCons 5
-Heterogeneous.Mapping.mapRecordWithIndexNil.mapRecordWithIndexBuilder 2
+--  'arity' = <positive-int> - inline once <positive-int> args have been passed to function

spago.dhall

@@ -16,6 +16,7 @@ You can edit this file as you like.
   , "dodo-printer"
   , "effect"
   , "either"
+  , "filterable"
   , "foldable-traversable"
   , "foreign-object"
   , "integers"

src/Main.purs

@@ -2,212 +2,59 @@ module Main where
 
 import Prelude
 
-import ArgParse.Basic (ArgParser)
-import ArgParse.Basic as ArgParser
-import Control.Parallel (parTraverse)
 import Control.Plus (empty)
-import Data.Argonaut as Json
 import Data.Array as Array
-import Data.Bifunctor (lmap)
 import Data.Either (Either(..), isRight)
 import Data.Foldable (oneOf)
-import Data.List (List)
-import Data.List as List
-import Data.Map (Map)
-import Data.Map as Map
-import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.Maybe (fromMaybe, maybe)
+import Data.Monoid (power)
 import Data.Newtype (unwrap)
-import Data.Set as Set
 import Data.String (Pattern(..))
 import Data.String as String
-import Data.Traversable (for)
-import Data.Tuple (Tuple(..))
+import Data.String.CodeUnits as SCU
 import Dodo as Dodo
 import Effect (Effect)
-import Effect.Aff (Aff, attempt, effectCanceler, error, launchAff_, makeAff, throwError)
-import Effect.Class (liftEffect)
+import Effect.Aff (Aff, attempt, effectCanceler, error, makeAff, throwError)
 import Effect.Class.Console as Console
-import Foreign.Object as Object
-import Node.Buffer as Buffer
-import Node.ChildProcess (defaultExecSyncOptions)
-import Node.ChildProcess as ChildProcess
 import Node.Encoding (Encoding(..))
 import Node.FS.Aff (writeTextFile)
 import Node.FS.Aff as FS
-import Node.FS.Aff as FSA
-import Node.FS.Perms as Perms
 import Node.FS.Stats as Stats
 import Node.FS.Stream (createReadStream, createWriteStream)
-import Node.FS.Sync (mkdir')
-import Node.Glob.Basic (expandGlobs)
 import Node.Path (FilePath)
 import Node.Path as Path
-import Node.Process as Process
 import Node.Stream as Stream
+import PureScript.Backend.Builder.Cli (basicCliMain)
 import PureScript.Backend.Codegen.EcmaScript (esCodegenModule, esForeignModulePath, esModulePath)
-import PureScript.Backend.Convert (toBackendModule)
-import PureScript.Backend.Directives (parseDirective)
-import PureScript.Backend.Semantics (EvalRef(..), InlineDirective(..))
-import PureScript.Backend.Semantics.Foreign (qualified)
-import PureScript.Backend.Syntax (BackendAccessor(..))
-import PureScript.CoreFn (Ann, Import(..), Module(..), ModuleName(..))
-import PureScript.CoreFn.Json (decodeModule)
+import PureScript.CoreFn (Module(..))
 
-data Args
-  = Build
-      { corefnDir :: String
-      , outputDir :: String
-      , foreignDir :: Maybe String
-      , directivesFile :: Maybe String
-      }
-  | Run
-      { main :: String
-      , bin :: String
-      , args :: Array String
-      , outputDir :: String
-      }
-
-argParser :: ArgParser Args
-argParser = ArgParser.choose "command"
-  [ Build <$> ArgParser.command [ "build" ]
-      "Build a project from corefn modules."
-      do
-        ArgParser.fromRecord
-          { corefnDir:
-              ArgParser.anyNotFlag "COREFN_DIR"
-                "Directory for corefn.json files."
-          , 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
-  , Run <$> ArgParser.command [ "run" ]
-      "Run a module."
-      do
-        ArgParser.fromRecord
-          { main:
-              ArgParser.anyNotFlag "MODULE_NAME"
-                "Main entry point module name."
-          , bin:
-              ArgParser.argument [ "--bin" ]
-                "Path to lua bin"
-                # ArgParser.default "lua"
-          , args:
-              ArgParser.rest
-                "Command line arguments to script."
-                # ArgParser.default []
-          , outputDir:
-              ArgParser.argument [ "--output-dir" ]
-                "Output directory for backend files"
-                # ArgParser.default (Path.concat [ ".", "output-es" ])
-          }
-  ]
-
-defaultDirectives :: Map EvalRef InlineDirective
-defaultDirectives = Map.fromFoldable
-  [ Tuple (EvalExtern (qualified "Control.Apply" "applyFirst") Nothing) (InlineArity 2)
-  , Tuple (EvalExtern (qualified "Control.Apply" "applySecond") Nothing) (InlineArity 2)
-  , Tuple (EvalExtern (qualified "Control.Category" "categoryFn") (Just (GetProp "identity"))) InlineAlways
-  , Tuple (EvalExtern (qualified "Control.Monad.ST.Internal" "modify") Nothing) (InlineArity 2)
-  , Tuple (EvalExtern (qualified "Control.Semigroupoid" "composeFlipped") Nothing) (InlineArity 3)
-  , Tuple (EvalExtern (qualified "Control.Semigroupoid" "semigroupoidFn") (Just (GetProp "compose"))) (InlineArity 2)
-  , Tuple (EvalExtern (qualified "Data.Function" "const") Nothing) (InlineArity 1)
-  , Tuple (EvalExtern (qualified "Effect.Ref" "modify") Nothing) (InlineArity 2)
-  , Tuple (EvalExtern (qualified "Record.Builder" "build") Nothing) (InlineArity 1)
-  , Tuple (EvalExtern (qualified "Record.Builder" "rename") Nothing) (InlineArity 8)
-  ]
-
-main :: FilePath -> Effect Unit
-main dirName = do
-  args <- Array.drop 2 <$> Process.argv
-  let
-    parsedArgs =
-      ArgParser.parseArgs "purs-backend-project"
-        "An example PureScript backend."
-        argParser
-        args
-  case parsedArgs of
-    Left err ->
-      Console.error $ ArgParser.printArgError err
-    Right args' -> launchAff_ do
-      compileModules dirName args'
-
-compileModules :: FilePath -> Args -> Aff Unit
-compileModules dirName = case _ of
-  Build { corefnDir, outputDir, foreignDir, directivesFile } -> do
-    coreFnModules <-
-      expandGlobs corefnDir [ "*/corefn.json" ] >>=
-        Array.fromFoldable
-          >>> parTraverse readCoreFnModule
-          >>> map (Array.catMaybes >>> Map.fromFoldable)
-    liftEffect $ mkdir' outputDir { recursive: true, mode: Perms.mkPerms Perms.all Perms.all Perms.all }
-    writeTextFile UTF8 (Path.concat [ outputDir, "package.json" ]) $ Json.stringify do
-      Json.jsonSingletonObject "type" (Json.fromString "module")
-    mbExternalDirectives <- for directivesFile \filePath -> do
-      annFileContent <- FSA.readTextFile UTF8 filePath
-      pure $ parseDirective $ String.split (Pattern "\n") annFileContent
-    let
-      -- We use `const` here to ensure external directives don't override the default ones
-      allDirectives = maybe defaultDirectives (\exDirs -> Map.unionWith const defaultDirectives exDirs) mbExternalDirectives
-      go implementations = case _ of
-        List.Nil -> pure unit
-        List.Cons coreFnMod@(Module { name, foreign: foreignIdents, path }) mods -> do
-          Console.log $ unwrap name
-          let modPath = Path.concat [ outputDir, esModulePath name ]
-          let backendMod = toBackendModule coreFnMod { currentModule: name, currentLevel: 0, toLevel: Map.empty, implementations, deps: Set.empty, directives: allDirectives, dataTypes: Map.empty }
-          let formatted = Dodo.print Dodo.plainText (Dodo.twoSpaces { pageWidth = 180, ribbonRatio = 1.0 }) $ esCodegenModule backendMod
-          writeTextFile UTF8 modPath formatted
-          unless (Array.null foreignIdents) do
-            let foreignFileName = esForeignModulePath name
-            let foreignOutputPath = Path.concat [ outputDir, foreignFileName ]
-            let origPath = Path.concat [ corefnDir, "..", path ]
-            let foreignSiblingPath = fromMaybe origPath (String.stripSuffix (Pattern (Path.extname origPath)) origPath) <> ".js"
-            res <- attempt $ oneOf
-              [ copyFile foreignSiblingPath foreignOutputPath
-              , maybe empty (\dir -> copyFile (Path.concat [ dir, esModulePath name ]) foreignOutputPath) foreignDir
-              , copyFile (Path.concat [ dirName, "foreign-es", esModulePath name ]) foreignOutputPath
-              ]
-            unless (isRight res) do
-              Console.warn $ "  Foreign implementation missing"
-          go (Map.union backendMod.implementations implementations) mods
-    go Map.empty (sortCoreFnModules coreFnModules)
-  Run { main: mainModule, bin, args, outputDir } -> do
-    cwd <- liftEffect $ Path.resolve [] outputDir
-    luaPath <- liftEffect $ Process.lookupEnv "LUA_PATH"
-    let modulePath = esModulePath (ModuleName mainModule)
-    let script = "require('runtime');require('" <> modulePath <> "').main()"
-    buffer <- liftEffect $ ChildProcess.execSync
-      (String.joinWith " " ([ bin, "-e", show script ] <> args))
-      defaultExecSyncOptions
-        { env = Just $ Object.fromFoldable
-            [ Tuple "LUA_PATH" $ String.joinWith ";" $ Array.catMaybes
-                [ Just $ Path.concat [ cwd, "?.lua" ]
-                , Just $ Path.concat [ dirName, "runtime", "?.lua" ]
-                , luaPath
-                ]
-            ]
-        , cwd = Just cwd
-        }
-    makeAff \k -> Stream.write Process.stdout buffer (\err -> (k (maybe (Right unit) Left err))) $> mempty
-
-readCoreFnModule :: FilePath -> Aff (Maybe (Tuple ModuleName (Module Ann)))
-readCoreFnModule filePath = do
-  contents <- liftEffect <<< Buffer.toString UTF8 =<< FS.readFile filePath
-  case lmap Json.printJsonDecodeError <<< decodeModule =<< Json.jsonParser contents of
-    Left err -> do
-      Console.error $ filePath <> ":\n" <> err
-      pure Nothing
-    Right mod@(Module { name }) ->
-      pure $ Just (Tuple name mod)
+main :: Effect Unit
+main = basicCliMain
+  { name: "purs-backend-es"
+  , description: "A PureScript backend for modern ECMAScript."
+  , defaultOutputDir: Path.concat [ ".", "output-es" ]
+  , onCodegenBefore: mempty
+  , onCodegenAfter: mempty
+  , onCodegenModule: \args build (Module coreFnMod) backendMod -> do
+      let total = show build.moduleCount
+      let index = show (build.moduleIndex + 1)
+      let padding = power " " (SCU.length total - SCU.length index)
+      Console.log $ "[" <> padding <> index <>  " of " <> total <> "] Building " <> unwrap backendMod.name
+      let formatted = Dodo.print Dodo.plainText (Dodo.twoSpaces { pageWidth = 180, ribbonRatio = 1.0 }) $ esCodegenModule backendMod
+      let modPath = Path.concat [ args.outputDir, esModulePath backendMod.name ]
+      writeTextFile UTF8 modPath formatted
+      unless (Array.null coreFnMod.foreign) do
+        let foreignFileName = esForeignModulePath backendMod.name
+        let foreignOutputPath = Path.concat [ args.outputDir, foreignFileName ]
+        let origPath = Path.concat [ args.outputDir, "..", coreFnMod.path ]
+        let foreignSiblingPath = fromMaybe origPath (String.stripSuffix (Pattern (Path.extname origPath)) origPath) <> ".js"
+        res <- attempt $ oneOf
+          [ copyFile foreignSiblingPath foreignOutputPath
+          , maybe empty (\dir -> copyFile (Path.concat [ dir, esModulePath backendMod.name ]) foreignOutputPath) args.foreignDir
+          ]
+        unless (isRight res) do
+          Console.log $ "  Foreign implementation missing."
+  }
 
 copyFile :: FilePath -> FilePath -> Aff Unit
 copyFile from to = do
@@ -226,29 +73,3 @@ copyFile from to = do
       Stream.destroy res
       Stream.destroy dst
       Stream.destroy src
-
-sortCoreFnModules :: forall a. Map ModuleName (Module a) -> List (Module a)
-sortCoreFnModules initialModules = go initialModIndex List.Nil (Right <<< getModuleName <$> List.fromFoldable initialModules)
-  where
-  initialModIndex =
-    (\mod -> { module: mod, visited: false }) <$> initialModules
-
-  go modIndex acc = case _ of
-    List.Nil ->
-      List.reverse acc
-    List.Cons (Left mod) names ->
-      go modIndex (List.Cons mod acc) names
-    List.Cons (Right name) names ->
-      case Map.lookup name modIndex of
-        Just modState@{ module: Module mod } -> do
-          if modState.visited then
-            go modIndex acc names
-          else do
-            let importNames = (\(Import _ imp) -> Right imp) <$> mod.imports
-            let modIndex' = Map.insert name (modState { visited = true }) modIndex
-            go modIndex' acc (List.fromFoldable importNames <> List.Cons (Left modState.module) names)
-        _ ->
-          go modIndex acc names
-
-getModuleName :: forall a. Module a -> ModuleName
-getModuleName (Module mod) = mod.name

src/PureScript/Backend/Builder.purs

@@ -0,0 +1,89 @@
+module PureScript.Backend.Builder
+  ( BuildEnv
+  , BuildOptions
+  , buildModules
+  , readCoreFnModule
+  , coreFnModulesFromOutput
+  ) where
+
+import Prelude
+
+import Control.Parallel (parTraverse)
+import Data.Argonaut as Json
+import Data.Array as Array
+import Data.Array.NonEmpty (NonEmptyArray)
+import Data.Array.NonEmpty as NonEmptyArray
+import Data.Bifunctor (lmap)
+import Data.Compactable (separate)
+import Data.Either (Either(..))
+import Data.List (List, foldM)
+import Data.List as List
+import Data.Map (Map)
+import Data.Map as Map
+import Data.Maybe (Maybe(..))
+import Data.Set as Set
+import Data.Tuple (Tuple(..))
+import Effect.Aff (Aff)
+import Node.Encoding (Encoding(..))
+import Node.FS.Aff as FS
+import Node.Glob.Basic (expandGlobs)
+import Node.Path (FilePath)
+import PureScript.Backend.Analysis (BackendAnalysis)
+import PureScript.Backend.Convert (BackendModule, toBackendModule)
+import PureScript.Backend.Semantics (EvalRef, ExternImpl, InlineDirective)
+import PureScript.CoreFn (Ann, Ident, Module(..), Qualified)
+import PureScript.CoreFn.Json (decodeModule)
+import PureScript.CoreFn.Sort (sortModules)
+
+type BuildEnv =
+  { implementations :: Map (Qualified Ident) (Tuple BackendAnalysis ExternImpl)
+  , moduleCount :: Int
+  , moduleIndex :: Int
+  }
+
+type BuildOptions =
+  { directives :: Map EvalRef InlineDirective
+  , onCodegenModule :: BuildEnv -> Module Ann -> BackendModule -> Aff Unit
+  }
+
+coreFnModulesFromOutput :: FilePath -> Aff (Either (NonEmptyArray (Tuple FilePath String)) (List (Module Ann)))
+coreFnModulesFromOutput path = do
+  { left, right } <- map separate $ expandGlobs path [ "*/corefn.json" ] >>= Array.fromFoldable >>> parTraverse readCoreFnModule
+  case NonEmptyArray.fromArray left of
+    Just errors ->
+      pure $ Left errors
+    Nothing ->
+      pure $ Right $ sortModules right
+
+readCoreFnModule :: FilePath -> Aff (Either (Tuple FilePath String) (Module Ann))
+readCoreFnModule filePath = do
+  contents <- FS.readTextFile UTF8 filePath
+  case lmap Json.printJsonDecodeError <<< decodeModule =<< Json.jsonParser contents of
+    Left err -> do
+      pure $ Left $ Tuple filePath err
+    Right mod ->
+      pure $ Right mod
+
+buildModules :: BuildOptions -> List (Module Ann) -> Aff Unit
+buildModules options coreFnModules =
+  void $ foldM go { directives: options.directives, implementations: Map.empty, moduleIndex: 0 } (sortModules coreFnModules)
+  where
+  moduleCount = List.length coreFnModules
+  go { directives, implementations, moduleIndex } coreFnMod@(Module { name }) = do
+    let
+      backendMod = toBackendModule coreFnMod
+        { currentModule: name
+        , currentLevel: 0
+        , toLevel: Map.empty
+        , implementations
+        , deps: Set.empty
+        , directives
+        , dataTypes: Map.empty
+        , rewriteLimit: 10000
+        }
+    options.onCodegenModule { implementations, moduleCount, moduleIndex } coreFnMod backendMod
+    pure
+      { directives: Map.union directives backendMod.directives
+      , implementations: Map.union backendMod.implementations implementations
+      , moduleIndex: moduleIndex + 1
+      }

src/PureScript/Backend/Builder/Cli.purs

@@ -0,0 +1,95 @@
+module PureScript.Backend.Builder.Cli where
+
+import Prelude
+
+import ArgParse.Basic (ArgParser)
+import ArgParse.Basic as ArgParser
+import Data.Array as Array
+import Data.Either (Either(..))
+import Data.Foldable (for_)
+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.Class (liftEffect)
+import Effect.Class.Console as Console
+import Node.Encoding (Encoding(..))
+import Node.FS.Aff as FS
+import Node.Path (FilePath)
+import Node.Process as Process
+import PureScript.Backend.Builder (BuildEnv, buildModules, coreFnModulesFromOutput)
+import PureScript.Backend.Convert (BackendModule)
+import PureScript.Backend.Directives (parseDirectiveFile)
+import PureScript.Backend.Directives.Defaults as Defaults
+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
+     }
+  -> 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
+        fileContent <- FS.readTextFile UTF8 filePath
+        let { errors, directives } = parseDirectiveFile fileContent
+        for_ errors \(Tuple directive { position, error }) -> do
+          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
+        Left errors -> do
+          for_ errors \(Tuple filePath err) -> do
+            Console.error $ filePath <> " " <> err
+          liftEffect $ Process.exit 1
+        Right coreFnModules -> do
+          options.onCodegenBefore args
+          buildModules { directives: allDirectives, onCodegenModule: options.onCodegenModule args } coreFnModules
+          options.onCodegenAfter args

src/PureScript/Backend/Codegen/Tco.purs

@@ -258,4 +258,4 @@ analyze env (NeutralExpr expr) = case expr of
       TcoExpr analysis expr'
   _ -> do
     let expr' = analyze env <$> expr
-    TcoExpr (tcoNoTailCalls (foldMap tcoAnalysisOf expr')) expr'
+    TcoExpr (tcoNoTailCalls (foldMap tcoAnalysisOf expr')) expr'

src/PureScript/Backend/Convert.purs

@@ -21,10 +21,9 @@ import Data.Set (Set)
 import Data.Set as Set
 import Data.Traversable (class Foldable, Accum, foldr, mapAccumL, sequence, traverse)
 import Data.Tuple (Tuple(..), fst, snd)
-import Effect.Class.Console as Console
-import Effect.Unsafe (unsafePerformEffect)
 import Partial.Unsafe (unsafeCrashWith)
 import PureScript.Backend.Analysis (BackendAnalysis)
+import PureScript.Backend.Directives (parseDirectiveHeader)
 import PureScript.Backend.Semantics (BackendExpr(..), BackendSemantics, Ctx, Env(..), EvalRef(..), ExternImpl(..), ExternSpine, InlineDirective(..), NeutralExpr(..), build, evalExternFromImpl, freeze, optimize)
 import PureScript.Backend.Semantics.Foreign (coreForeignSemantics)
 import PureScript.Backend.Syntax (BackendAccessor(..), BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorOrd(..), BackendSyntax(..), Level(..), Pair(..))
@@ -43,6 +42,7 @@ type BackendModule =
   , exports :: Array (Tuple Ident (Qualified Ident))
   , foreign :: Array Ident
   , implementations :: Map (Qualified Ident) (Tuple BackendAnalysis ExternImpl)
+  , directives :: Map EvalRef InlineDirective
   }
 
 type DataTypeMeta =
@@ -63,6 +63,7 @@ type ConvertEnv =
   , implementations :: Map (Qualified Ident) (Tuple BackendAnalysis ExternImpl)
   , deps :: Set ModuleName
   , directives :: Map EvalRef InlineDirective
+  , rewriteLimit :: Int
   }
 
 type ConvertM = Function ConvertEnv
@@ -70,6 +71,9 @@ type ConvertM = Function ConvertEnv
 toBackendModule :: Module Ann -> ConvertM BackendModule
 toBackendModule (Module mod) env = do
   let
+    directives =
+      parseDirectiveHeader mod.name mod.comments
+
     ctors = do
       Binding _ _ value <- mod.decls >>= case _ of
         Rec bindings -> bindings
@@ -91,7 +95,10 @@ toBackendModule (Module mod) env = do
       # Map.fromFoldable
 
     moduleBindings =
-      toBackendTopLevelBindingGroups mod.decls env { dataTypes = dataTypes }
+      toBackendTopLevelBindingGroups mod.decls env
+        { dataTypes = dataTypes
+        , directives = Map.union directives.locals env.directives
+        }
 
   { name: mod.name
   , imports: Array.filter (not <<< (eq mod.name || eq (ModuleName "Prim"))) $ Set.toUnfoldable moduleBindings.accum.deps
@@ -102,6 +109,7 @@ toBackendModule (Module mod) env = do
       , map (\(ReExport mn a) -> Tuple a (Qualified (Just mn) a)) mod.reExports
       ]
   , implementations: moduleBindings.accum.implementations
+  , directives: directives.exports
   , foreign: mod.foreign
   }
 
@@ -129,10 +137,9 @@ toBackendTopLevelBindingGroup env = case _ of
 
 toTopLevelBackendBinding :: Array (Qualified Ident) -> ConvertEnv ->  Binding Ann -> Accum ConvertEnv (Tuple Ident NeutralExpr)
 toTopLevelBackendBinding group env (Binding _ ident cfn) = do
-  let _ = unsafePerformEffect $ Console.log ("  " <> unwrap ident)
   let evalEnv = Env { currentModule: env.currentModule, evalExtern: makeExternEval env, locals: [], directives: env.directives, try: Nothing }
   let backendExpr = toBackendExpr cfn env
-  let Tuple impl expr' = toExternImpl group (optimize (getCtx env) evalEnv backendExpr)
+  let Tuple impl expr' = toExternImpl group (optimize (getCtx env) evalEnv (Qualified (Just env.currentModule) ident) env.rewriteLimit backendExpr)
   { accum: env
       { implementations = Map.insert (Qualified (Just env.currentModule) ident) impl env.implementations
       , deps = Set.union (unwrap (fst impl)).deps env.deps
@@ -435,4 +442,4 @@ toBackendExpr = case _ of
   make a = buildM =<< sequence a
 
 toBackendBinding :: Binding Ann -> ConvertM (Tuple Ident BackendExpr)
-toBackendBinding (Binding _ ident expr) = Tuple ident <$> toBackendExpr expr
+toBackendBinding (Binding _ ident expr) = Tuple ident <$> toBackendExpr expr

src/PureScript/Backend/Debug.purs

@@ -6,4 +6,4 @@ traceWhen :: forall a b. DebugWarning => Boolean -> a -> b -> b
 traceWhen bool a b = if bool then trace a \_ -> b else b
 
 spyWhen :: forall a. DebugWarning => Boolean -> a -> a
-spyWhen bool a = traceWhen bool a a
+spyWhen bool a = traceWhen bool a a

src/PureScript/Backend/Directives.purs

@@ -1,62 +1,163 @@
-module PureScript.Backend.Directives where
+module PureScript.Backend.Directives
+  ( parseDirectiveFile
+  , parseDirectiveHeader
+  , parseDirectiveLine
+  , parseDirectiveExport
+  ) where
 
 import Prelude
 
+import Control.Alt ((<|>))
 import Data.Array as Array
 import Data.Either (Either(..))
+import Data.Foldable (foldl)
+import Data.FoldableWithIndex (foldlWithIndex)
 import Data.Map (Map)
 import Data.Map as Map
 import Data.Maybe (Maybe(..))
-import Data.Tuple (Tuple(..))
+import Data.String (Pattern(..))
+import Data.String as String
+import Data.Tuple (Tuple(..), fst)
 import PureScript.Backend.Semantics (EvalRef(..), InlineDirective(..))
 import PureScript.Backend.Syntax (BackendAccessor(..))
-import PureScript.CST.Errors (ParseError)
-import PureScript.CST.Lexer as Lexer
-import PureScript.CST.TokenStream (TokenStep(..), TokenStream)
-import PureScript.CST.TokenStream as TokenStream
-import PureScript.CST.Types (IntValue(..), Token(..))
+import PureScript.CST.Errors (ParseError(..))
+import PureScript.CST.Lexer (lex)
+import PureScript.CST.Parser.Monad (Parser, PositionedError, eof, optional, runParser, take)
+import PureScript.CST.Types (IntValue(..), SourceToken, Token(..))
 import PureScript.CST.Types as CST
-import PureScript.CoreFn (Ident(..), ModuleName(..), Qualified(..))
+import PureScript.CoreFn (Comment(..), Ident(..), ModuleName(..), Qualified(..))
 
-parseDirective :: Array String -> Map EvalRef InlineDirective
-parseDirective = Map.fromFoldable <<< Array.mapMaybe parseLine
+type DirectiveFileResult =
+  { errors :: Array (Tuple String PositionedError)
+  , directives :: Map EvalRef InlineDirective
+  }
 
-parseLine :: String -> Maybe (Tuple EvalRef InlineDirective)
-parseLine = Lexer.lex >>> tokenStreamToArray >>> case _ of
-  Right [ TokLowerName modName fn, directive ] ->
-    inlineIdentifier modName fn Nothing directive
-  Right [ TokLowerName modName fn, TokDot, TokLowerName Nothing fieldName, directive ] ->
-    inlineIdentifier modName fn (Just (GetProp fieldName)) directive
-  _ -> Nothing
+parseDirectiveFile :: String -> DirectiveFileResult
+parseDirectiveFile = foldlWithIndex go { errors: [], directives: Map.empty } <<< String.split (Pattern "\n")
   where
-  inlineIdentifier
-    :: Maybe CST.ModuleName
-    -> String
-    -> Maybe BackendAccessor
-    -> Token
-    -> Maybe (Tuple EvalRef InlineDirective)
-  inlineIdentifier cstModName identifier externAccessor directive = do
-    let
-      qi = Qualified (map cstToBackendMod cstModName) (Ident identifier)
-    Tuple (EvalExtern qi externAccessor) <$> inlineDirective directive
+  go line { errors, directives } str = case parseDirectiveLine str of
+    Left err ->
+      { errors: Array.snoc errors (Tuple str (err { position { line = line } })), directives }
+    Right Nothing ->
+      { errors, directives }
+    Right (Just (Tuple key val)) ->
+      { errors, directives: Map.insert key val directives }
 
-  inlineDirective :: Token -> Maybe InlineDirective
-  inlineDirective = case _ of
-    -- An arity of `0` or some negative number wouldn't make sense
-    TokInt _ (SmallInt arity) | arity > 0 -> Just $ InlineArity arity
-    TokLowerName Nothing "always" -> Just InlineAlways
-    TokLowerName Nothing "never" -> Just InlineNever
-    _ -> Nothing
+type DirectiveHeaderResult =
+  { errors :: Array (Tuple String PositionedError)
+  , locals :: Map EvalRef InlineDirective
+  , exports :: Map EvalRef InlineDirective
+  }
 
-  cstToBackendMod (CST.ModuleName mn) = ModuleName mn
+parseDirectiveHeader :: ModuleName -> Array Comment -> DirectiveHeaderResult
+parseDirectiveHeader moduleName = foldl go { errors: [], locals: Map.empty, exports: Map.empty }
+  where
+  go { errors, locals, exports } = case _ of
+    LineComment str
+      | Just line <- String.stripPrefix (Pattern "@inline") $ String.trim str -> do
+          let line' = String.trim line -- Trim again for leading space, makes errors better.
+          case runParser (lex line') parser of
+            Left err ->
+              { errors: Array.snoc errors (Tuple line' err), locals, exports }
+            Right (Tuple (Left (Tuple key val)) _) ->
+              { errors, locals: Map.insert key val locals, exports: Map.insert key val exports}
+            Right (Tuple (Right (Tuple key val)) _) ->
+              { errors, locals: Map.insert key val locals, exports }
+    _ ->
+      { errors, locals, exports }
 
-  tokenStreamToArray :: TokenStream -> Either ParseError (Array Token)
-  tokenStreamToArray = go []
-    where
-    go acc = TokenStream.step >>> case _ of
-      TokenEOF _ _ ->
-        Right acc
-      TokenError _ err _ _ ->
-        Left err
-      TokenCons tok _ next _ ->
-        go (Array.snoc acc tok.value) next
+  parser =
+    Left <$> parseDirectiveExport moduleName <|> Right <$> parseDirective
+
+parseDirectiveLine :: String -> Either PositionedError (Maybe (Tuple EvalRef InlineDirective))
+parseDirectiveLine line = fst <$> runParser (lex line) parseDirectiveMaybe
+
+parseDirectiveMaybe :: Parser (Maybe (Tuple EvalRef InlineDirective))
+parseDirectiveMaybe = Just <$> parseDirective <|> (Nothing <$ eof)
+
+parseDirectiveExport :: ModuleName -> Parser (Tuple EvalRef InlineDirective)
+parseDirectiveExport moduleName =
+  ( ado
+      keyword "export"
+      ident <- unqualified
+      accessor <- optional (dot *> label)
+      directive <-  parseInlineDirective
+      in Tuple (EvalExtern (Qualified (Just moduleName) ident) (GetProp <$> accessor)) directive
+  ) <* eof
+
+parseDirective :: Parser (Tuple EvalRef InlineDirective)
+parseDirective =
+  ( ado
+      qual <- qualified
+      accessor <- optional (dot *> label)
+      directive <-  parseInlineDirective
+      in Tuple (EvalExtern qual (GetProp <$> accessor)) directive
+  ) <* eof
+
+parseInlineDirective :: Parser InlineDirective
+parseInlineDirective =
+  InlineDefault <$ keyword "default"
+    <|> InlineNever <$ keyword "never"
+    <|> InlineAlways <$ keyword "always"
+    <|> InlineArity <$> (keyword "arity" *> equals *> natural)
+
+qualified :: Parser (Qualified Ident)
+qualified = expectMap case _ of
+  { value: CST.TokLowerName (Just (CST.ModuleName mod)) ident } ->
+    Just $ Qualified (Just (ModuleName mod)) (Ident ident)
+  _ ->
+    Nothing
+
+unqualified :: Parser Ident
+unqualified = expectMap case _ of
+  { value: CST.TokLowerName Nothing ident } ->
+    Just $ Ident ident
+  _ ->
+    Nothing
+
+label :: Parser String
+label = expectMap case _ of
+  { value: TokRawString lbl } ->
+    Just lbl
+  { value: TokString _ lbl } ->
+    Just lbl
+  { value: TokLowerName Nothing lbl } ->
+    Just lbl
+  _ ->
+    Nothing
+
+dot :: Parser Unit
+dot = expectMap case _ of
+  { value: TokDot } ->
+    Just unit
+  _ ->
+    Nothing
+
+equals :: Parser Unit
+equals = expectMap case _ of
+  { value: TokEquals } ->
+    Just unit
+  _ ->
+    Nothing
+
+keyword :: String -> Parser Unit
+keyword word1 = expectMap case _ of
+  { value: TokLowerName Nothing word2} | word1 == word2 ->
+    Just unit
+  _ ->
+    Nothing
+
+natural :: Parser Int
+natural = expectMap case _ of
+  { value: TokInt _ (SmallInt n) } | n > 0 ->
+    Just n
+  _ ->
+    Nothing
+
+expectMap :: forall a. (SourceToken -> Maybe a) -> Parser a
+expectMap k = take \tok ->
+  case k tok of
+    Just a ->
+      Right a
+    Nothing ->
+      Left $ UnexpectedToken tok.value

src/PureScript/Backend/Directives/Defaults.purs

@@ -0,0 +1,16 @@
+module PureScript.Backend.Directives.Defaults where
+
+defaultDirectives :: String
+defaultDirectives =
+  """
+  Control.Apply.applyFirst arity=2
+  Control.Apply.applySecond arity=2
+  Control.Category.categoryFn.identity always
+  Control.Monad.ST.Internal.modify arity=2
+  Control.Semigroupoid.composeFlipped arity=2
+  Control.Semigroupoid.semigroupoidFn.compose arity=2
+  Data.Function const arity=1
+  Effect.Ref.modify arity=2
+  Record.Builder.build arity=1
+  Record.Builder.rename arity=8
+  """

src/PureScript/Backend/Semantics.purs

@@ -22,7 +22,7 @@ import Data.Tuple (Tuple(..), fst)
 import Partial.Unsafe (unsafeCrashWith, unsafePartial)
 import PureScript.Backend.Analysis (class HasAnalysis, BackendAnalysis(..), Complexity(..), Usage(..), analysisOf, analyze, bound, bump, complex, withRewrite)
 import PureScript.Backend.Syntax (class HasSyntax, BackendAccessor(..), BackendEffect, BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorNum(..), BackendOperatorOrd(..), BackendSyntax(..), Level(..), Pair(..), syntaxOf)
-import PureScript.CoreFn (ConstructorType, Ident, Literal(..), ModuleName, Prop(..), ProperName, Qualified(..), findProp, propKey)
+import PureScript.CoreFn (ConstructorType, Ident(..), Literal(..), ModuleName, Prop(..), ProperName, Qualified(..), findProp, propKey)
 
 type Spine a = Array a
 
@@ -108,7 +108,8 @@ derive instance Eq EvalRef
 derive instance Ord EvalRef
 
 data InlineDirective
-  = InlineNever
+  = InlineDefault
+  | InlineNever
   | InlineAlways
   | InlineArity Int
 
@@ -666,6 +667,8 @@ analysisFromDirective (BackendAnalysis analysis) = case _ of
     BackendAnalysis analysis { complexity = NonTrivial, size = top }
   InlineArity n ->
     BackendAnalysis analysis { args = Array.take n analysis.args }
+  InlineDefault ->
+    BackendAnalysis analysis
 
 liftBoolean :: Boolean -> BackendSemantics
 liftBoolean = NeutLit <<< LitBoolean
@@ -962,21 +965,17 @@ shouldInlineLet level a b = do
 
 shouldInlineExternReference :: Qualified Ident -> BackendAnalysis -> NeutralExpr -> Maybe InlineDirective -> Boolean
 shouldInlineExternReference _ (BackendAnalysis s) _ = case _ of
-  Just dir ->
-    case dir of
-      InlineAlways -> true
-      InlineNever -> false
-      InlineArity _ -> false
+  Just InlineAlways -> true
+  Just InlineNever -> false
+  Just (InlineArity _) -> false
   _ ->
     s.complexity <= Deref && s.size < 16
 
 shouldInlineExternApp :: Qualified Ident -> BackendAnalysis -> NeutralExpr -> Spine BackendSemantics -> Maybe InlineDirective -> Boolean
 shouldInlineExternApp _ (BackendAnalysis s) _ args = case _ of
-  Just dir ->
-    case dir of
-      InlineAlways -> true
-      InlineNever -> false
-      InlineArity n -> Array.length args == n
+  Just InlineAlways -> true
+  Just InlineNever -> false
+  Just (InlineArity n) -> Array.length args == n
   _ ->
     (s.complexity <= Deref && s.size < 16)
       || (Array.length s.args > 0 && Array.length s.args <= Array.length args && s.size < 16)
@@ -1013,11 +1012,13 @@ newtype NeutralExpr = NeutralExpr (BackendSyntax NeutralExpr)
 
 derive instance Newtype NeutralExpr _
 
-optimize :: Ctx -> Env -> BackendExpr -> BackendExpr
-optimize ctx env = go 10000
+optimize :: Ctx -> Env -> Qualified Ident -> Int -> BackendExpr -> BackendExpr
+optimize ctx env (Qualified mn (Ident id)) = go
   where
   go n expr1
-    | n == 0 = expr1 -- unsafeCrashWith "Possible infinite optimization loop."
+    | n == 0 = do
+        let name = foldMap ((_ <> ".") <<< unwrap) mn <> id
+        unsafeCrashWith $ name <> ": Possible infinite optimization loop."
     | otherwise = do
         let expr2 = quote ctx (eval env expr1)
         case expr2 of

src/PureScript/CoreFn.purs

@@ -87,6 +87,9 @@ newtype Module a = Module
   , comments :: Array Comment
   }
 
+moduleName :: forall a. Module a -> ModuleName
+moduleName (Module mod) = mod.name
+
 data Import a = Import a ModuleName
 
 derive instance functorImport :: Functor Import
@@ -219,4 +222,4 @@ litChildren :: forall a. Literal a -> Array a
 litChildren = case _ of
   LitArray as -> as
   LitRecord ps -> propValue <$> ps
-  _ -> []
+  _ -> []

src/PureScript/CoreFn/Json.purs

@@ -211,11 +211,11 @@ decodeBinder decAnn json = do
   ann <- getField decAnn obj "annotation"
   typ <- getField decodeString obj "binderType"
   case typ of
-    "NullBinder" -> 
+    "NullBinder" ->
       pure $ BinderNull ann
     "VarBinder" ->
       BinderVar ann <$> getField decodeIdent obj "identifier"
-    "LiteralBinder" -> 
+    "LiteralBinder" ->
       BinderLit ann <$> getField (decodeLiteral (decodeBinder decAnn)) obj "literal"
     "ConstructorBinder" -> do
       tyn <- getField (decodeQualified decodeProperName) obj "typeName"
@@ -238,7 +238,7 @@ decodeLiteral dec json = do
       LitInt <$> getField decodeInt obj "value"
     "NumberLiteral" ->
       LitNumber <$> getField decodeNumber obj "value"
-    "StringLiteral" -> 
+    "StringLiteral" ->
       LitString <$> getField decodeString obj "value"
     "CharLiteral" -> do
       str <- getField decodeString obj "value"
@@ -247,7 +247,7 @@ decodeLiteral dec json = do
         Array.head $ SCU.toCharArray str
     "BooleanLiteral" ->
       LitBoolean <$> getField decodeBoolean obj "value"
-    "ArrayLiteral" -> 
+    "ArrayLiteral" ->
       LitArray <$> getField (decodeArray dec) obj "value"
     "ObjectLiteral" ->
       LitRecord <$> getField (decodeRecord dec) obj "value"
@@ -261,4 +261,4 @@ decodeComment :: Json -> JsonDecode Comment
 decodeComment json = do
   obj <- decodeJObject json
   LineComment <$> getField decodeString obj "LineComment"
-    <|> BlockComment <$> getField decodeString obj "BlockComment"
+    <|> BlockComment <$> getField decodeString obj "BlockComment"

src/PureScript/CoreFn/Sort.purs

@@ -0,0 +1,40 @@
+module PureScript.CoreFn.Sort where
+
+import Prelude
+
+import Data.Either (Either(..))
+import Data.Foldable (class Foldable, foldl, foldr)
+import Data.List (List)
+import Data.List as List
+import Data.Map as Map
+import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..), uncurry)
+import PureScript.CoreFn (Import(..), Module(..), moduleName)
+
+sortModules :: forall f a. Foldable f => f (Module a) -> List (Module a)
+sortModules =
+  ( \init -> do
+      let modIndex = foldl (flip (uncurry Map.insert <<< initialModuleWithName)) Map.empty init
+      let modStk = Right <<< moduleName <$> List.fromFoldable init
+      go modIndex List.Nil modStk
+  )
+  where
+  initialModuleWithName mod@(Module { name }) =
+    Tuple name { visited: false, module: mod }
+
+  go modIndex acc = case _ of
+    List.Cons (Left mod) names ->
+      go modIndex (List.Cons mod acc) names
+    List.Cons (Right name) names ->
+      case Map.lookup name modIndex of
+        Just modState@{ module: Module mod } -> do
+          if modState.visited then
+            go modIndex acc names
+          else do
+            let importNames = (\(Import _ imp) -> Right imp) <$> mod.imports
+            let modIndex' = Map.insert name (modState { visited = true }) modIndex
+            go modIndex' acc (foldr List.Cons (List.Cons (Left modState.module) names) importNames)
+        _ ->
+          go modIndex acc names
+    List.Nil ->
+      List.reverse acc