Compile.hs

module Command.Compile (command) where

import Control.Applicative (Alternative (..))
import Control.Monad (when)
import Data.Aeson qualified as A
import Data.Bool (bool)
import Data.ByteString.Lazy.UTF8 qualified as LBU8
import Data.List (intercalate)
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Traversable (for)
import Language.PureScript qualified as P
import Language.PureScript.Compile qualified as P 
import Language.PureScript.DB (mkConnection)
import Language.PureScript.Errors.JSON (JSONResult (..), toJSONErrors)
import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
import Language.PureScript.Make.Index (initDb)
import Options.Applicative qualified as Opts
import SharedCLI qualified
import System.Console.ANSI qualified as ANSI
import System.Directory (getCurrentDirectory)
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStr, stderr, stdout)
import System.IO.UTF8 (readUTF8FilesT)
import Prelude

data PSCMakeOptions = PSCMakeOptions
  { pscmInput :: [FilePath],
    pscmInputFromFile :: Maybe FilePath,
    pscmExclude :: [FilePath],
    pscmOutputDir :: FilePath,
    pscmOpts :: P.Options,
    pscmUsePrefix :: Bool,
    pscmJSONErrors :: Bool
  }

-- | Arguments: verbose, use JSON, warnings, errors
printWarningsAndErrors :: Bool -> Bool -> [(FilePath, T.Text)] -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
printWarningsAndErrors verbose False files 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, P.ppeFileContents = files}
  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 files warnings errors = do
  putStrLn . LBU8.toString . A.encode $
    JSONResult
      (toJSONErrors verbose P.Warning files warnings)
      (either (toJSONErrors verbose P.Error files) (const []) errors)
  either (const exitFailure) (const (return ())) errors

compile :: PSCMakeOptions -> IO ()
compile PSCMakeOptions {..} = do
  input <-
    toInputGlobs $
      PSCGlobs
        { pscInputGlobs = pscmInput,
          pscInputGlobsFromFile = pscmInputFromFile,
          pscExcludeGlobs = pscmExclude,
          pscWarnFileTypeNotFound = warnFileTypeNotFound "compile"
        }
  when (null input) $ do
    hPutStr stderr $
      unlines
        [ "purs compile: No input files.",
          "Usage: For basic information, try the `--help' option."
        ]
    exitFailure
  (_, conn) <- mkConnection pscmOutputDir
  initDb conn
  moduleFiles <- readUTF8FilesT input
  (makeErrors, makeWarnings) <- P.compile pscmOpts moduleFiles conn pscmOutputDir pscmUsePrefix
  printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
  exitSuccess



outputDirectory :: Opts.Parser FilePath
outputDirectory =
  Opts.strOption $
    Opts.short 'o'
      <> Opts.long "output"
      <> Opts.value "output"
      <> Opts.showDefault
      <> Opts.help "The output directory"

comments :: Opts.Parser Bool
comments =
  Opts.switch $
    Opts.short 'c'
      <> Opts.long "comments"
      <> Opts.help "Include comments in the generated code"

verboseErrors :: Opts.Parser Bool
verboseErrors =
  Opts.switch $
    Opts.short 'v'
      <> Opts.long "verbose-errors"
      <> Opts.help "Display verbose error messages"

noPrefix :: Opts.Parser Bool
noPrefix =
  Opts.switch $
    Opts.short 'p'
      <> Opts.long "no-prefix"
      <> Opts.help "Do not include comment header"

jsonErrors :: Opts.Parser Bool
jsonErrors =
  Opts.switch $
    Opts.long "json-errors"
      <> Opts.help "Print errors to stderr as JSON"

codegenTargets :: Opts.Parser [P.CodegenTarget]
codegenTargets =
  Opts.option targetParser $
    Opts.short 'g'
      <> Opts.long "codegen"
      <> Opts.value [P.JS]
      <> Opts.help
        ( "Specifies comma-separated codegen targets to include. "
            <> targetsMessage
            <> " The default target is 'js', but if this option is used only the targets specified will be used."
        )

targetsMessage :: String
targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys P.codegenTargets) <> "'."

targetParser :: Opts.ReadM [P.CodegenTarget]
targetParser =
  Opts.str >>= \s ->
    for (T.split (== ',') s) $
      maybe (Opts.readerError targetsMessage) pure
        . flip M.lookup P.codegenTargets
        . T.unpack
        . T.strip

options :: Opts.Parser P.Options
options =
  P.Options
    <$> verboseErrors
    <*> (not <$> comments)
    <*> (handleTargets <$> codegenTargets)
  where
    -- Ensure that the JS target is included if sourcemaps are
    handleTargets :: [P.CodegenTarget] -> S.Set P.CodegenTarget
    handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts)

pscMakeOptions :: Opts.Parser PSCMakeOptions
pscMakeOptions =
  PSCMakeOptions
    <$> many SharedCLI.inputFile
    <*> SharedCLI.globInputFile
    <*> many SharedCLI.excludeFiles
    <*> outputDirectory
    <*> options
    <*> (not <$> noPrefix)
    <*> jsonErrors

command :: Opts.Parser (IO ())
command = compile <$> (Opts.helper <*> pscMakeOptions)