Run.hs

{-# LANGUAGE BangPatterns   #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | Dead code elimination command based on `Language.PureScript.CoreFn.DCE`.
--
module Command.Run
  ( runZephyr
  ) where

import           Control.Applicative ((<|>))
import           Control.Monad
import           Control.Monad.Error.Class (MonadError(..))
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Supply
import           Control.Monad.Trans (lift)
import           Control.Monad.Trans.Except
import           Control.Exception
import           Control.Concurrent.QSem
import qualified Control.Concurrent.Async as Async

import qualified Data.Aeson as A
import           Data.Aeson.Internal (JSONPath)
import qualified Data.Aeson.Internal as A
import           Data.Aeson.Parser (eitherDecodeWith, json)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.UTF8 as BU8
import           Data.Bool (bool)
import           Data.Either (lefts, rights, partitionEithers)
import           Data.Foldable (for_, traverse_)
import qualified Data.Map as M
import qualified Data.Set as S
import           Data.Maybe (isNothing, listToMaybe)
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as TE
import           Data.Version (Version)
import           Formatting (sformat, string, stext, (%))

import           GHC.Conc.Sync (getNumCapabilities)

import qualified Language.PureScript.Docs.Types as Docs
import qualified Language.JavaScript.Parser as JS
import qualified Language.PureScript as P
import qualified Language.PureScript.CoreFn as CoreFn
import qualified Language.PureScript.CoreFn.FromJSON as CoreFn
import qualified Language.PureScript.Errors.JSON as P
import qualified System.Console.ANSI as ANSI
import           System.Directory (copyFile, doesDirectoryExist, doesFileExist,
                                   getCurrentDirectory, removeFile)
import           System.Exit (exitFailure, exitSuccess)
import           System.FilePath ((</>), (-<.>))
import           System.FilePath.Glob (compile, globDir1)
import           System.IO (hPutStrLn, stderr)

import           Command.Options
import           Language.PureScript.DCE.Errors (EntryPoint (..))

import           Language.PureScript.DCE ( DCEError (..)
                                         , Level (..)
                                         )
import qualified Language.PureScript.DCE as DCE


readInput :: [FilePath]
          -> IO [Either
                  (FilePath, JSONPath, String)
                  (Version, CoreFn.Module CoreFn.Ann)
                ]

readInput inputFiles = do
    -- limit parallelizm to at most the number of capablities
    sem <- getNumCapabilities >>= newQSem
    threads <-
      forM inputFiles $ \f -> do
        waitQSem sem
        mask $ \unmask -> Async.async $
          (unmask $ do
            c <- BSL.readFile f
            -- being strict here forces reading the file and promptly closing its file
            -- descriptor
            case decodeCoreFn c of
              Left  (p, e)     -> pure $ Left  (f, p, e)
              Right r@(!_, !_) -> pure $ Right r
          )
          `finally`
            signalQSem sem
    forM threads Async.wait
  where
    decodeCoreFn :: BSL.ByteString
                 -> Either (JSONPath, String)
                           (Version, CoreFn.Module CoreFn.Ann)
    decodeCoreFn = eitherDecodeWith json (A.iparse CoreFn.moduleFromJSON)


-- | Argumnets: verbose, use JSON, warnings, errors
--
printWarningsAndErrors
    :: Bool                      -- ^ be verbose
    -> Bool                      -- ^ use 'JSON'
    -> P.MultipleErrors          -- ^ warnings
    -> Either P.MultipleErrors a -- ^ errors
    -> IO ()

printWarningsAndErrors verbose False warnings errors = do
  pwd <- getCurrentDirectory
  cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr
  let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, 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 _ -> return ()

printWarningsAndErrors verbose True warnings errors = do
  hPutStrLn stderr . BU8.toString . A.encode $
    P.JSONResult (P.toJSONErrors verbose P.Warning [] warnings)
               (either (P.toJSONErrors verbose P.Error []) (const []) errors)
  either (const exitFailure) (const (return ())) errors


-- | Application exception
--
data DCEAppError
  = ParseErrors       ![Text]
  -- ^ parser errors
  | InputNotDirectory !FilePath
  -- ^ input directory does not exists (or is not a directory)
  | NoInputs          !FilePath
  -- ^ no input files
  | DCEAppError  !(DCEError 'Error)
  -- ^ PureScript errors


-- | Render 'DCEAppError' as 'Text'
--
formatDCEAppError :: Options -> FilePath -> DCEAppError -> Text
formatDCEAppError opts _ (ParseErrors errs) =
  let errs' =
        if optVerbose opts
        then errs
        else take 5 errs ++ case length $ drop 5 errs of
          0 -> []
          x -> ["... (" <> T.pack (show x) <> " more)"]
  in sformat
        (string % ": Failed parsing:\n  " % stext)
        (DCE.colorString DCE.errorColor "Error")
        (T.intercalate "\n\t" errs')
formatDCEAppError _ _ (NoInputs path)
  = sformat
        (stext % ": No inputs found under " % string % " directory.\n"
               % "       Please run `purs compile --codegen corefn ..` or"
               % "`pulp build -- --codegen corefn`")
        (DCE.colorText DCE.errorColor "Error")
        (DCE.colorString DCE.codeColor path)
formatDCEAppError _ _ (InputNotDirectory path)
  = sformat
        (stext % ": Directory "%string%" does not exists.")
        (DCE.colorText DCE.errorColor "Error")
        (DCE.colorString DCE.codeColor path)
formatDCEAppError _ relPath (DCEAppError err)
  = T.pack $ DCE.displayDCEError relPath err


-- | Given list of modules and list of entry points, find qualilfied names of
-- roots.
--
getEntryPoints
  :: [CoreFn.Module CoreFn.Ann]
  -> [EntryPoint]
  -> [Either EntryPoint (P.Qualified P.Ident)]
getEntryPoints mods = go []
  where
    go acc [] = acc
    go acc ((EntryPoint i) : eps)  =
      if i `fnd` mods
        then go (Right i : acc) eps
        else go (Left (EntryPoint i)  : acc) eps
    go acc ((EntryModule mn) : eps) = go (modExports mn mods ++ acc) eps
    go acc ((err@EntryParseError{}) : eps) = go (Left err : acc) eps

    modExports :: P.ModuleName -> [CoreFn.Module CoreFn.Ann] -> [Either EntryPoint (P.Qualified P.Ident)]
    modExports mn [] = [Left (EntryModule mn)]
    modExports mn (CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleExports, CoreFn.moduleReExports } : ms)
      | mn == moduleName
      = (Right . flip P.mkQualified mn) `map` (moduleExports ++ (snd =<< M.toList moduleReExports))
      | otherwise
      = modExports mn ms

    fnd :: P.Qualified P.Ident -> [CoreFn.Module CoreFn.Ann] -> Bool
    fnd _ [] = False
    fnd qi@(P.Qualified (P.ByModuleName mn) i) (pModule@CoreFn.Module{ CoreFn.moduleName } : ms)
      = if moduleName == mn && i `elem` (allExports pModule)
          then True
          else fnd qi ms
    fnd _ _ = False

    allExports :: CoreFn.Module CoreFn.Ann -> [P.Ident]
    allExports CoreFn.Module{ CoreFn.moduleExports, CoreFn.moduleReExports } =
      moduleExports ++ (M.toList moduleReExports >>= snd)


dceCommand :: Options -> ExceptT DCEAppError IO ()
dceCommand Options { optEntryPoints
                   , optInputDir
                   , optOutputDir
                   , optVerbose
                   , optForeign
                   , optPureScriptOptions
                   , optUsePrefix
                   , optJsonErrors
                   , optEvaluate
                   } = do
    -- initial checks
    inptDirExist <- lift $ doesDirectoryExist optInputDir
    unless inptDirExist $
      throwError (InputNotDirectory optInputDir)

    -- read files, parse errors
    let cfnGlb = compile "**/corefn.json"
    inpts0 <- liftIO $ globDir1 cfnGlb optInputDir >>= readInput
    -- force inputs sequentially
    inpts  <- liftIO $ traverse evaluate inpts0
    let errs = lefts inpts
    unless (null errs) $
      throwError (ParseErrors $ formatError `map` errs)

    let mPursVer = fmap fst . listToMaybe . rights $ inpts
    when (isNothing mPursVer) $
      throwError (NoInputs optInputDir)

    let (notFound, entryPoints) =
          partitionEithers
            (getEntryPoints
              (fmap snd . rights $ inpts)
              optEntryPoints)

    when (not $ null notFound) $
      case filter DCE.isEntryParseError notFound of
        []   -> throwError (DCEAppError $ EntryPointsNotFound notFound)
        perrs ->
          let fn (EntryParseError s) acc = s : acc
              fn _                   acc = acc
          in throwError (DCEAppError $ EntryPointsNotParsed (foldr fn [] perrs))

    when (null entryPoints) $
      throwError (DCEAppError NoEntryPoint)

    -- run `evaluate` and `runDeadCodeElimination` on `CoreFn` representation
    let mods = if optEvaluate
                  then DCE.runDeadCodeElimination
                        entryPoints
                        (DCE.evaluate (snd `map` rights inpts))
                  else DCE.runDeadCodeElimination
                        entryPoints
                        (snd `map` rights inpts)

    let filePathMap =
          M.fromList
            (map
              (\m -> (CoreFn.moduleName m, Right $ CoreFn.modulePath m))
              mods)
    foreigns <- P.inferForeignModules filePathMap
    let makeActions = (P.buildMakeActions optOutputDir filePathMap foreigns optUsePrefix)
          { P.ffiCodegen = \CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleForeign } -> liftIO $ do
                let codegenTargets = P.optionsCodegenTargets optPureScriptOptions
                when (S.member P.JS codegenTargets) $ do
                  case moduleName `M.lookup` foreigns of
                    -- run `runForeignModuleDeadCodeElimination`
                    Just path | optForeign  -> do
                      jsCode <- BU8.toString <$> BSL.readFile path
                      case JS.parseModule jsCode path of
                        Left _ -> return ()
                        Right (JS.JSAstModule items ann) ->
                          let items'    = DCE.runForeignModuleDeadCodeElimination moduleForeign items
                              jsAst' = JS.JSAstModule items' ann
                              foreignFile = optOutputDir
                                        </> T.unpack (P.runModuleName moduleName)
                                        </> "foreign.js"
                          in BSL.writeFile foreignFile (TE.encodeUtf8 $ JS.renderToText jsAst')
                        Right _ -> return ()

                    Just path -> do
                      let filePath = T.unpack (P.runModuleName moduleName)
                          outputPath = optInputDir </> filePath </> "foreign.js"
                      -- prefer foreign module in 'optOutputDir'.
                      bool path outputPath <$> doesFileExist outputPath
                        >>= (`copyFile` (optOutputDir </> filePath </> "foreign.js"))

                    Nothing -> pure ()
            }

    (makeErrors, makeWarnings) <-
        liftIO
        $ P.runMake optPureScriptOptions
        $ runSupplyT 0
        $ traverse
            (\m ->
              P.codegen makeActions m
                        (Docs.Module (CoreFn.moduleName m) Nothing [] [])
                        (moduleToExternsFile m))
            mods

    traverse_ (liftIO . P.runMake optPureScriptOptions . P.ffiCodegen makeActions) mods

    -- copy extern files; We do not have access to data to regenerate extern
    -- files (they relay on more information than is present in 'CoreFn.Module'
    -- represenation).
    for_ mods $ \m -> lift $ do
      let mn = CoreFn.moduleName m
      copyExterns mn "cbor" <|> do
        -- zephyr will always generate "externs.cbor" file, if we are working
        -- on a project using purescript-0.13.6 we need to remove it.
        removeFile (optOutputDir </> (T.unpack $ P.runModuleName mn) </> "externs.cbor")
        copyExterns mn "json"
    liftIO $
      printWarningsAndErrors
        (P.optionsVerboseErrors optPureScriptOptions)
        optJsonErrors
        (suppressFFIErrors makeWarnings)
        (either (Left . suppressFFIErrors) Right makeErrors)

  where

    formatError :: (FilePath, JSONPath, String) -> Text
    formatError (f, p, err) =
      if optVerbose
        then sformat (string%":\n    "%string) f (A.formatError p err)
        else T.pack f

    copyExterns :: P.ModuleName -> String -> IO ()
    copyExterns mn extension = do
      let filePath = T.unpack . P.runModuleName $ mn
      copyFile (optInputDir  </> filePath </> "externs" -<.> extension)
               (optOutputDir </> filePath </> "externs" -<.> extension)

    -- a hack: purescript codegen function reads FFI from disk, and checks
    -- against it.
    suppressFFIErrors :: P.MultipleErrors -> P.MultipleErrors
    suppressFFIErrors (P.MultipleErrors errs) = P.MultipleErrors $ filter fn errs
      where
        fn (P.ErrorMessage _ P.UnnecessaryFFIModule{})     = False
        fn (P.ErrorMessage _ P.UnusedFFIImplementations{}) = False
        fn _                                               = True

    moduleToExternsFile :: CoreFn.Module a -> P.ExternsFile
    moduleToExternsFile CoreFn.Module {CoreFn.moduleName} = P.ExternsFile {
        P.efVersion      = mempty,
        P.efModuleName   = moduleName,
        P.efExports      = [],
        P.efImports      = [],
        P.efFixities     = [],
        P.efTypeFixities = [],
        P.efDeclarations = [],
        P.efSourceSpan   = P.SourceSpan "none" (P.SourcePos 0 0) (P.SourcePos 0 0)
      }


runZephyr
  :: Options
  -> IO ()
runZephyr opts = do
  res <- runExceptT $ dceCommand opts
  relPath <- getCurrentDirectory
  case res of
    Left e  ->
         (hPutStrLn stderr . T.unpack . formatDCEAppError opts relPath $ e)
      *> exitFailure
    Right{} ->
      exitSuccess