purescript · colinwahl · May 18, 2021 · May 18, 2021 · May 18, 2021 · May 19, 2021
diff --git a/CHANGELOG.d/feature_add-codegen-command.md b/CHANGELOG.d/feature_add-codegen-command.md
@@ -0,0 +1,4 @@
+* Add `purs codegen` command (#4092, @colinwahl)
+
+  Adds a new command, `purs codegen`, which generates JavaScript code
+  for the given files containing the CoreFn Module JSON representation.
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
@@ -159,6 +159,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) |
 | [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) |
 | [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license](http://opensource.org/licenses/MIT) |
+| [@colinwahl](https://github.com/colinwahl) | Colin Wahl | [MIT license](http://opensource.org/licenses/MIT) |
 
 ### Contributors using Modified Terms
 
@@ -174,7 +175,6 @@ If you would prefer to use different terms, please use the section below instead
 | [@nwolverson](https://github.com/nwolverson) | Nicholas Wolverson | Contributions I made during March 2020 until further notice are in employment of [Id3as Company](#companies), who own the copyright. All other contributions remain Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). |
 
 
-
 ### Companies
 
 | Username | Company | Terms |

diff --git a/app/Command/Codegen.hs b/app/Command/Codegen.hs
@@ -0,0 +1,113 @@
+module Command.Codegen (command) where
+
+import Prelude
+
+import           Command.Common (globWarningOnMisses, printWarningsAndErrors)
+
+import           Control.Applicative (many)
+import           Control.Monad (when, unless)
+
+import qualified Data.Aeson.Internal as A
+import           Data.Aeson.Parser (eitherDecodeWith, json)
+import qualified Data.ByteString.Lazy as BSL
+import           Data.Either (lefts, rights)
+import           Data.Foldable (traverse_)
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+import qualified Language.PureScript as P
+import qualified Language.PureScript.CoreFn as CoreFn
+import qualified Language.PureScript.CoreFn.FromJSON as CoreFn
+
+import qualified Options.Applicative as Opts
+
+import           System.Exit (exitFailure)
+import           System.IO (hPutStr, hPutStrLn, stderr)
+
+data CodegenOptions = CodegenOptions
+  { codegenCoreFnInput :: [FilePath]
+  , codegenJSONErrors :: Bool
+  , codegenOutputDir :: FilePath
+  , codegenSourceMaps :: Bool
+  }
+
+codegen :: CodegenOptions -> IO ()
+codegen CodegenOptions{..} = do
+  inputFiles <- globWarningOnMisses (unless codegenJSONErrors . warnFileTypeNotFound) codegenCoreFnInput
+  when (null inputFiles && not codegenJSONErrors) $ do
+    hPutStr stderr $ unlines
+      [ "purs codegen: No input files."
+      , "Usage: For basic information, try the `--help` option."
+      ]
+    exitFailure
+  mods <- traverse parseCoreFn inputFiles
+  let successMods = rights mods
+  let failedMods = lefts mods
+
+  let
+    filePathMap =
+      M.fromList $ map ((\m -> (CoreFn.moduleName m, Right $ CoreFn.modulePath m)) . snd) successMods
+
+  unless (null failedMods) $ do
+    traverse_ (hPutStr stderr . formatParseError) failedMods
+    exitFailure
+
+  foreigns <- P.inferForeignModules filePathMap
+  (makeResult, makeWarnings) <-
+    P.runMake purescriptOptions
+      $ traverse (P.codegenJS (makeActions foreigns filePathMap) codegenSourceMaps . snd) successMods
+  printWarningsAndErrors True codegenJSONErrors makeWarnings makeResult
+  where
+  formatParseError (file, _, e) =
+    "Failed parsing file " <> file <> " with error: " <> e
+
+  parseCoreFn file = do
+    contents <- BSL.readFile file
+    case eitherDecodeWith json (A.iparse CoreFn.moduleFromJSON) contents of
+      Left (j, e) -> pure $ Left (file, j, e)
+      Right r -> pure $ Right r
+
+  makeActions foreigns filePathMap = P.buildMakeActions codegenOutputDir filePathMap foreigns False
+
+  purescriptOptions :: P.Options
+  purescriptOptions = P.Options False False (S.fromList [ P.JS ])
+
+  warnFileTypeNotFound :: String -> IO ()
+  warnFileTypeNotFound =
+    hPutStrLn stderr . ("purs codegen: No files found using pattern: " <>)
+
+command :: Opts.Parser (IO ())
+command = codegen <$> (Opts.helper <*> codegenOptions)
+  where
+  codegenOptions :: Opts.Parser CodegenOptions
+  codegenOptions =
+    CodegenOptions <$> many inputFile
+                   <*> jsonErrors
+                   <*> outputDirectory
+                   <*> sourceMaps
+
+  inputFile :: Opts.Parser FilePath
+  inputFile =
+    Opts.strArgument $
+      Opts.metavar "FILE" <>
+      Opts.help "The input corefn.json file(s)."
+
+  jsonErrors :: Opts.Parser Bool
+  jsonErrors =
+    Opts.switch $
+      Opts.long "json-errors" <>
+      Opts.help "Print errors to stderr as JSON"
+
+  outputDirectory :: Opts.Parser FilePath
+  outputDirectory = Opts.strOption $
+    Opts.short 'o'
+      <> Opts.long "output"
+      <> Opts.value "output"
+      <> Opts.showDefault
+      <> Opts.help "The output directory"
+
+  sourceMaps :: Opts.Parser Bool
+  sourceMaps =
+    Opts.switch $
+      Opts.long "source-maps" <>
+      Opts.help "Generate source maps for generated JS"
diff --git a/app/Command/Common.hs b/app/Command/Common.hs
@@ -0,0 +1,44 @@
+module Command.Common (globWarningOnMisses, printWarningsAndErrors) where
+
+import Prelude
+
+import           Control.Monad (when)
+import qualified Data.Aeson as A
+import           Data.Bool (bool)
+import qualified Data.ByteString.Lazy.UTF8 as LBU8
+import qualified Language.PureScript as P
+import           Language.PureScript.Errors.JSON
+import           Protolude (concatMapM)
+import qualified System.Console.ANSI as ANSI
+import           System.Directory (getCurrentDirectory)
+import           System.Exit (exitFailure)
+import           System.FilePath.Glob (glob)
+import           System.IO (stdout)
+
+globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
+globWarningOnMisses warn = concatMapM globWithWarning
+  where
+  globWithWarning :: String -> IO [FilePath]
+  globWithWarning pattern' = do
+    paths <- glob pattern'
+    when (null paths) $ warn pattern'
+    return paths
+
+-- | Arguments: verbose, use JSON, warnings, errors
+printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
+printWarningsAndErrors verbose False warnings errors = do
+  pwd <- getCurrentDirectory
+  cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stdout
+  let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd }
+  when (P.nonEmpty warnings) $
+    putStrLn (P.prettyPrintMultipleWarnings ppeOpts warnings)
+  case errors of
+    Left errs -> do
+      putStrLn (P.prettyPrintMultipleErrors ppeOpts errs)
+      exitFailure
+    Right _ -> return ()
+printWarningsAndErrors verbose True warnings errors = do
+  putStrLn . LBU8.toString . A.encode $
+    JSONResult (toJSONErrors verbose P.Warning warnings)
+               (either (toJSONErrors verbose P.Error) (const []) errors)
+  either (const exitFailure) (const (return ())) errors
diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
@@ -2,26 +2,20 @@ module Command.Compile (command) where
 
 import Prelude
 
+import           Command.Common (globWarningOnMisses, printWarningsAndErrors)
 import           Control.Applicative
 import           Control.Monad
-import qualified Data.Aeson as A
-import           Data.Bool (bool)
-import qualified Data.ByteString.Lazy.UTF8 as LBU8
 import           Data.List (intercalate)
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.Text as T
 import           Data.Traversable (for)
 import qualified Language.PureScript as P
 import qualified Language.PureScript.CST as CST
-import           Language.PureScript.Errors.JSON
 import           Language.PureScript.Make
 import qualified Options.Applicative as Opts
-import qualified System.Console.ANSI as ANSI
 import           System.Exit (exitSuccess, exitFailure)
-import           System.Directory (getCurrentDirectory)
-import           System.FilePath.Glob (glob)
-import           System.IO (hPutStr, hPutStrLn, stderr, stdout)
+import           System.IO (hPutStr, hPutStrLn, stderr)
 import           System.IO.UTF8 (readUTF8FilesT)
 
 data PSCMakeOptions = PSCMakeOptions
@@ -32,25 +26,6 @@ data PSCMakeOptions = PSCMakeOptions
   , pscmJSONErrors   :: Bool
   }
 
--- | Arguments: verbose, use JSON, warnings, errors
-printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
-printWarningsAndErrors verbose False warnings errors = do
-  pwd <- getCurrentDirectory
-  cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stdout
-  let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd }
-  when (P.nonEmpty warnings) $
-    putStrLn (P.prettyPrintMultipleWarnings ppeOpts warnings)
-  case errors of
-    Left errs -> do
-      putStrLn (P.prettyPrintMultipleErrors ppeOpts errs)
-      exitFailure
-    Right _ -> return ()
-printWarningsAndErrors verbose True warnings errors = do
-  putStrLn . LBU8.toString . A.encode $
-    JSONResult (toJSONErrors verbose P.Warning warnings)
-               (either (toJSONErrors verbose P.Error) (const []) errors)
-  either (const exitFailure) (const (return ())) errors
-
 compile :: PSCMakeOptions -> IO ()
 compile PSCMakeOptions{..} = do
   input <- globWarningOnMisses warnFileTypeNotFound pscmInput
@@ -72,15 +47,6 @@ compile PSCMakeOptions{..} = do
 warnFileTypeNotFound :: String -> IO ()
 warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++)
 
-globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
-globWarningOnMisses warn = concatMapM globWithWarning
-  where
-  globWithWarning pattern' = do
-    paths <- glob pattern'
-    when (null paths) $ warn pattern'
-    return paths
-  concatMapM f = fmap concat . mapM f
-
 inputFile :: Opts.Parser FilePath
 inputFile = Opts.strArgument $
      Opts.metavar "FILE"

diff --git a/app/Command/Graph.hs b/app/Command/Graph.hs
@@ -2,19 +2,14 @@ module Command.Graph (command) where
 
 import Prelude
 
+import           Command.Common (globWarningOnMisses, printWarningsAndErrors)
 import           Control.Applicative (many)
 import           Control.Monad (unless, when)
 import qualified Data.Aeson as Json
-import           Data.Bool (bool)
 import qualified Data.ByteString.Lazy as LB
-import qualified Data.ByteString.Lazy.UTF8 as LBU8
 import qualified Language.PureScript as P
-import           Language.PureScript.Errors.JSON
 import qualified Options.Applicative as Opts
-import qualified System.Console.ANSI as ANSI
 import           System.Exit (exitFailure)
-import           System.Directory (getCurrentDirectory)
-import           System.FilePath.Glob (glob)
 import           System.IO (hPutStr, hPutStrLn, stderr)
 
 data GraphOptions = GraphOptions
@@ -34,7 +29,7 @@ graph GraphOptions{..} = do
 
   (makeResult, makeWarnings) <- P.graph input
 
-  printWarningsAndErrors graphJSONErrors makeWarnings makeResult
+  printWarningsAndErrors True graphJSONErrors makeWarnings makeResult
     >>= (LB.putStr . Json.encode)
 
   where
@@ -62,38 +57,3 @@ command = graph <$> (Opts.helper <*> graphOptions)
     Opts.switch $
       Opts.long "json-errors" <>
       Opts.help "Print errors to stderr as JSON"
-
--- | Arguments: use JSON, warnings, errors
-printWarningsAndErrors :: Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO a
-printWarningsAndErrors False warnings errors = do
-  pwd <- getCurrentDirectory
-  cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr
-  let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = True, P.ppeRelativeDirectory = pwd }
-  when (P.nonEmpty warnings) $
-    hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings)
-  case errors of
-    Left errs -> do
-      hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs)
-      exitFailure
-    Right res -> pure res
-printWarningsAndErrors True warnings errors = do
-  let verbose = True
-  hPutStrLn stderr . LBU8.toString . Json.encode $
-    JSONResult (toJSONErrors verbose P.Warning warnings)
-               (either (toJSONErrors verbose P.Error) (const []) errors)
-  case errors of
-    Left _errs -> exitFailure
-    Right res -> pure res
-
-
-globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
-globWarningOnMisses warn = concatMapM globWithWarning
-  where
-  globWithWarning :: String -> IO [FilePath]
-  globWithWarning pattern' = do
-    paths <- glob pattern'
-    when (null paths) $ warn pattern'
-    return paths
-
-  concatMapM :: (a -> IO [b]) -> [a] -> IO [b]
-  concatMapM f = fmap concat . mapM f
diff --git a/app/Main.hs b/app/Main.hs
@@ -3,6 +3,7 @@ module Main where
 import Prelude
 
 import qualified Command.Bundle as Bundle
+import qualified Command.Codegen as Codegen
 import qualified Command.Compile as Compile
 import qualified Command.Docs as Docs
 import qualified Command.Graph as Graph
@@ -61,6 +62,9 @@ main = do
         [ Opts.command "bundle"
             (Opts.info Bundle.command
               (Opts.progDesc "This command was removed in v0.15.0. Run this command for migration information."))
+        , Opts.command "codegen"
+            (Opts.info Codegen.command
+              (Opts.progDesc "Generate JS from core functional representation"))
         , Opts.command "compile"
             (Opts.info Compile.command
               (Opts.progDesc "Compile PureScript source files"))

diff --git a/purescript.cabal b/purescript.cabal
@@ -393,6 +393,8 @@ executable purs
       gitrev >=1.2.0 && <1.4
   other-modules:
     Command.Bundle
+    Command.Codegen
+    Command.Common
     Command.Compile
     Command.Docs
     Command.Docs.Html

diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs
@@ -24,5 +24,5 @@ evalSupplyT n = fmap fst . runSupplyT n
 
 type Supply = SupplyT Identity
 
-runSupply :: Integer -> Supply a -> (a, Integer)
-runSupply n = runIdentity . runSupplyT n
+evalSupply :: Integer -> Supply a -> a
+evalSupply n = runIdentity . evalSupplyT n
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -111,7 +111,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
   let mod' = Module ss coms moduleName regrouped exps
       corefn = CF.moduleToCoreFn env' mod'
-      (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
+      optimized = evalSupply nextVar' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
       exts = moduleToExternsFile mod' env' renamedIdents
   ffiCodegen renamed
@@ -129,7 +129,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
                  ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs
                Right d -> d
 
-  evalSupplyT nextVar'' $ codegen renamed docs exts
+  codegen renamed docs exts
   return exts
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.