content: {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
  module Main (main) where
  
  import qualified BMake.User as BMake
  import qualified Buildsome
  import           Buildsome (Buildsome, CollectStats(..), PutInputsInStats(..))
  import qualified Buildsome.Chart as Chart
  import qualified Buildsome.ClangCommands as ClangCommands
  import qualified Buildsome.Color as Color
  import qualified Buildsome.CompatMakefile as CompatMakefile
  import           Buildsome.Db (Db, Reason)
  import qualified Buildsome.Db as Db
  import           Buildsome.Opts (Opts(..), Opt(..))
  import qualified Buildsome.Opts as Opts
  import qualified Buildsome.Print as Print
  import qualified Control.Exception as E
  import           Control.Monad (forM_)
  import           Data.ByteString (ByteString)
  import qualified Data.ByteString.Char8 as BS8
  import           Data.Functor.Identity (Identity(..))
  import           Data.List (foldl')
  import qualified Data.Map as M
  import           Data.Maybe (mapMaybe, isJust)
  import           Data.Monoid
  import           Data.String (IsString(..))
  import           Data.Typeable (Typeable)
  import           GHC.Conc (setNumCapabilities, getNumProcessors)
  import           Lib.ByteString (unprefixed)
  import           Lib.ColorText (ColorText)
  import qualified Lib.ColorText as ColorText
  import           Lib.Directory (getMFileStatus)
  import           Lib.FilePath (FilePath, (</>))
  import qualified Lib.FilePath as FilePath
  import           Lib.Makefile (Makefile)
  import qualified Lib.Makefile as Makefile
  import           Lib.Printer (Printer)
  import qualified Lib.Printer as Printer
  import           Lib.ScanFileUpwards (scanFileUpwards)
  import           Lib.Show (show)
  import           Lib.TimeIt (timeIt)
  import qualified Lib.Version as Version
  import           System.Exit (exitWith, ExitCode(..))
  import qualified System.IO as IO
  import qualified System.IO.Error as Err
  import qualified System.Posix.ByteString as Posix
  import           System.Posix.IO (stdOutput)
  import           System.Posix.Terminal (queryTerminal)
  
  import qualified Prelude.Compat as Prelude
  import           Prelude.Compat hiding (FilePath, show)
  
  standardMakeFilename :: FilePath
  standardMakeFilename = "Buildsome.mk"
  
  errorShowConcat :: (ColorText -> ByteString) -> [ColorText] -> String
  errorShowConcat render =
      BS8.unpack . render . cError . mconcat
      where
        Color.Scheme{..} = Color.scheme
  
  data SpecifiedInexistentMakefilePath =
      SpecifiedInexistentMakefilePath (ColorText -> ByteString) FilePath
      deriving (Typeable)
  instance Show SpecifiedInexistentMakefilePath where
      show (SpecifiedInexistentMakefilePath render path) =
          errorShowConcat render
          ["Specified makefile path: ", cPath (show path), " does not exist"]
          where
              Color.Scheme{..} = Color.scheme
  instance E.Exception SpecifiedInexistentMakefilePath
  
  specifiedMakefile :: Printer -> FilePath -> IO FilePath
  specifiedMakefile printer path = do
      mStat <- getMFileStatus path
      case mStat of
          Nothing -> E.throwIO $ SpecifiedInexistentMakefilePath (Printer.render printer) path
          Just stat
              | Posix.isDirectory stat -> pure $ path </> standardMakeFilename
              | otherwise -> pure path
  
  data TargetsRequest = TargetsRequest
      { targetsRequestPaths :: [FilePath]
      , targetsRequestReason :: Reason
      , targetsRequestExtraOutputs :: Opts.ExtraOutputs
      }
  
  ntraverseTargetsRequest ::
      Applicative f =>
      ([FilePath] -> f [FilePath]) ->
      (Reason -> f Reason) ->
      (Opts.ExtraOutputs -> f Opts.ExtraOutputs) ->
      TargetsRequest -> f TargetsRequest
  ntraverseTargetsRequest
      onTargetPaths onReason onExtraOutputs
      (TargetsRequest paths reason extraOutputs)
      = TargetsRequest <$> onTargetPaths paths <*> onReason reason <*> onExtraOutputs extraOutputs
  
  data Requested = RequestedClean | RequestedTargets TargetsRequest
  
  traverseRequested ::
      Applicative f => (TargetsRequest -> f TargetsRequest) -> Requested -> f Requested
  traverseRequested _ RequestedClean = pure RequestedClean
  traverseRequested f (RequestedTargets x) = RequestedTargets <$> f x
  
  data BadCommandLine = BadCommandLine (ColorText -> ByteString) String deriving (Typeable)
  instance E.Exception BadCommandLine
  instance Show BadCommandLine where
      show (BadCommandLine render msg) =
          errorShowConcat render ["Invalid command line options: ", fromString msg]
  
  getRequestedTargets :: Printer -> Opts.ExtraOutputs -> [ByteString] -> IO Requested
  getRequestedTargets _ _ ["clean"] = pure RequestedClean
  getRequestedTargets printer extraOutputs ts
      | "clean" `elem` ts =
          E.throwIO $
          BadCommandLine (Printer.render printer) "Clean must be requested exclusively"
      | otherwise =
          pure $ RequestedTargets TargetsRequest
              { targetsRequestPaths = requestPaths
              , targetsRequestReason = reason
              , targetsRequestExtraOutputs = extraOutputs
              }
      where
          (requestPaths, reason) = case ts of
              [] -> (["default"], Db.BecauseRequested "implicit 'default' target")
              _ -> (ts, Db.BecauseRequested "explicit request from cmdline")
  
  setBuffering :: IO ()
  setBuffering = do
      IO.hSetBuffering IO.stdout IO.LineBuffering
      IO.hSetBuffering IO.stderr IO.LineBuffering
  
  switchDirectory :: FilePath -> IO (FilePath, FilePath, FilePath)
  switchDirectory makefilePath = do
      origCwd <- Posix.getWorkingDirectory
      newCwd <-
          if BS8.null cwd then pure origCwd
          else do
              Posix.changeWorkingDirectory cwd
              fullCwd <- FilePath.canonicalizePath $ origCwd </> cwd
              BS8.putStrLn $ "make: Entering directory `" <> fullCwd <> "'"
              pure fullCwd
      pure (origCwd, file, newCwd)
      where
          (cwd, file) = FilePath.splitFileName makefilePath
  
  parseMakefile :: Printer -> Db -> FilePath -> FilePath -> Makefile.Vars -> FilePath -> IO Makefile
  parseMakefile printer _ origMakefilePath finalMakefilePath vars cwd = do
      let absFinalMakefilePath = cwd </> finalMakefilePath
      (parseTime,    makefile) <- timeIt $ do
          rawMakefile <- BMake.parse absFinalMakefilePath vars
          let makefile = runIdentity $ Makefile.onMakefilePaths (Identity . FilePath.canonicalizePathAsRelativeCwd cwd) rawMakefile
          Makefile.verifyPhonies makefile
          pure makefile
      let msg = "Parsed makefile: "
      Printer.rawPrintStrLn printer $ mconcat
          [ msg, cPath (show origMakefilePath)
          , " (took ", cTiming (show parseTime <> "sec"), ")"]
      pure makefile
      where
          Color.Scheme{..} = Color.scheme
  
  newtype MakefileScanFailed = MakefileScanFailed (ColorText -> ByteString) deriving (Typeable)
  instance E.Exception MakefileScanFailed
  instance Show MakefileScanFailed where
      show (MakefileScanFailed render) =
          errorShowConcat render
          [ "ERROR: Cannot find a file named "
          , cPath (show standardMakeFilename)
          , " in this directory or any of its parents"
          ]
          where
              Color.Scheme{..} = Color.scheme
  
  -- TODO: Extract the --enable/disable colors outside of the
  -- version/etc separation.
  getColorRender :: Opts -> IO (ColorText -> ByteString)
  getColorRender GetVersion = pure ColorText.stripColors
  getColorRender (Opts opt) =
      case optColor opt of
      Opts.ColorDisable -> pure ColorText.stripColors
      Opts.ColorEnable -> pure ColorText.render
      Opts.ColorDefault -> do
          isTty <- queryTerminal stdOutput
          pure $
              if isTty
              then ColorText.render
              else ColorText.stripColors
  
  flagPrefix :: ByteString
  flagPrefix = "FLAG_"
  
  optVars :: Opt -> Makefile.Vars
  optVars opt = M.fromList $ withs ++ withouts
      where
          asVars val = map $ \name -> (flagPrefix <> name, val)
          withs = asVars "enable" $ optWiths opt
          withouts = asVars "disable" $ optWithouts opt
  
  flagsOfVars :: Makefile.Vars -> Makefile.Vars
  flagsOfVars = M.fromList . mapMaybe filterFlag . M.toList
      where
          filterFlag (key, value) =
              flip (,) value <$> unprefixed flagPrefix key
  
  ljust :: Int -> ByteString -> ByteString
  ljust padding bs = bs <> BS8.replicate (padding - l) ' '
      where
          l = BS8.length bs
  
  showHelpFlags :: Makefile.Vars -> IO ()
  showHelpFlags flags = do
      BS8.putStrLn "Available flags:"
      -- TODO: Colors (depends on --enable/disbale color being outside)
      let varNameWidth = 1 + (foldl' max 0 . map BS8.length . M.keys) flags
      forM_ (M.toList flags) $ \(varName, defaultVal) ->
          BS8.putStrLn $ mconcat
              ["    ", ljust varNameWidth varName, "(default = ", show defaultVal, ")"]
  
  verifyValidFlags :: Makefile.Vars -> [ByteString] -> IO ()
  verifyValidFlags validFlags userFlags
      | null invalidUserFlags = pure ()
      | otherwise = fail $ "Given non-existent flags: " ++ show invalidUserFlags
      where
          invalidUserFlags = filter (`M.notMember` validFlags) userFlags
  
  handleOpts ::
      Printer -> Opts ->
      (Db -> Opt -> Requested -> FilePath -> Makefile -> IO ()) -> IO ()
  handleOpts printer GetVersion _ =
      Printer.rawPrintStrLn printer $ "buildsome " <> Version.version
  handleOpts printer (Opts opt) body = do
      origMakefilePath <-
          case optMakefilePath opt of
          Nothing ->
              maybe (E.throwIO (MakefileScanFailed (Printer.render printer))) pure =<<
              scanFileUpwards standardMakeFilename
          Just path -> specifiedMakefile printer path
      (origCwd, finalMakefilePath, cwd) <- switchDirectory origMakefilePath
      let canonCwd =
              FilePath.canonicalizePathAsRelativeCwd cwd
          inOrigCwd = canonCwd . (origCwd </>)
          targetInOrigCwd = canonCwd .
              case optMakefilePath opt of
              -- If we found the makefile by scanning upwards, prepend
              -- original cwd to avoid losing it:
              Nothing -> (origCwd </>)
              -- Otherwise: there's no useful original cwd:
              Just _ -> id
      rawRequested <-
          getRequestedTargets printer (optExtraOutputs opt) (optRequestedTargets opt)
      requested <-
          traverseRequested
          (ntraverseTargetsRequest
           (pure . map targetInOrigCwd) -- <- on target paths
           pure                                     -- <- on reason
           (Opts.extraOutputsAtFilePaths (pure . inOrigCwd)) -- <- onExtraOutputs
          ) rawRequested
      Buildsome.withDb finalMakefilePath $ \db -> do
          makefile <-
              parseMakefile printer db origMakefilePath finalMakefilePath (optVars opt) cwd
          let flags = flagsOfVars (Makefile.makefileWeakVars makefile)
          if optHelpFlags opt
              then showHelpFlags flags
              else do
                  verifyValidFlags flags (optWiths opt ++ optWithouts opt)
                  body db opt requested finalMakefilePath makefile
  
  handleRequested :: Buildsome -> Printer -> Requested -> IO ()
  handleRequested buildsome printer RequestedClean = Buildsome.clean printer buildsome
  handleRequested
      buildsome printer
      (RequestedTargets
       (TargetsRequest requestedTargetPaths reason
          (Opts.ExtraOutputs mChartPath mClangCommandsPath compatMakefile)))
      = do
              Buildsome.BuiltTargets rootTargets slaveStats <-
                  Buildsome.want printer buildsome collectStats reason requestedTargetPaths
              maybe (pure ()) (Chart.make slaveStats) mChartPath
              cwd <- Posix.getWorkingDirectory
              maybe (pure ()) (ClangCommands.make cwd slaveStats rootTargets) mClangCommandsPath
              whenCompat $
                  CompatMakefile.make (Buildsome.bsPhoniesSet buildsome) cwd slaveStats rootTargets "compat-makefile"
      where
          (collectStats, whenCompat) =
              case compatMakefile of
              Opts.CompatMakefile -> (CollectStats PutInputsInStats, id :: IO a -> IO a)
              Opts.NoCompatMakefile
                      | isJust mChartPath || isJust mClangCommandsPath
                          -> (CollectStats DontPutInputsInStats, const (pure ()))
                      | otherwise -> (DontCollectStats, const (pure ()))
  
  -- Includes "fail" and "error" (i.e: userError is part of IOError)
  -- Other error types are trusted to do their own color pretty-printing
  ioErrorHandler :: Printer -> Err.IOError -> IO ()
  ioErrorHandler printer err =
      do
          Printer.rawPrintStrLn printer $ cError $ show err
          exitWith (ExitFailure 1)
      where
          Color.Scheme{..} = Color.scheme
  
  main :: IO ()
  main = do
      setBuffering
      setNumCapabilities =<< getNumProcessors
      opts <- Opts.get
      render <- getColorRender opts
      printer <- Printer.new render $ Printer.Id 0
      E.handle (ioErrorHandler printer) $
          handleOpts printer opts $
          \db opt@Opt{..} requested finalMakefilePath makefile -> do
              Print.buildsomeCreation printer Version.version optWiths optWithouts optVerbosity
              Buildsome.with printer db finalMakefilePath makefile opt $ \buildsome ->
                  handleRequested buildsome printer requested
  