content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  
  module Development.Debug.Session.Setup
    (
    -- * Setting up a hie-bios session
      HieBiosFlags(..)
    , hieBiosSetup
  
    -- * Logging
    , FlagsLog(..)
    ) where
  
  import Control.Applicative ((<|>))
  import Control.Exception (handleJust)
  import Control.Monad
  import Control.Monad.Except
  import Control.Monad.IO.Class
  import Control.Monad.Trans.Maybe
  import Data.Bifunctor
  import Data.Function
  import Data.Functor ((<&>))
  import Data.Maybe
  import Data.Version
  import Data.Void
  import System.Directory hiding (findFile)
  import System.FilePath
  import System.IO.Error
  import Text.ParserCombinators.ReadP (readP_to_S)
  import Prettyprinter
  
  import qualified Data.Text as T
  
  import qualified HIE.Bios as HIE
  import qualified HIE.Bios.Config as Config
  import qualified HIE.Bios.Cradle as HIE
  import qualified HIE.Bios.Environment as HIE
  import qualified HIE.Bios.Types as HIE
  import qualified Hie.Cabal.Parser as Implicit
  import qualified Hie.Locate as Implicit
  import qualified Hie.Yaml as Implicit
  
  import GHC.Debugger.Logger
  
  data FlagsLog
    = HieBiosLog HIE.Log
    | LogCradle (HIE.Cradle Void)
    | LogSetupMsg T.Text
  
  instance Pretty FlagsLog where
    pretty = \ case
      HieBiosLog msg -> pretty msg
      LogCradle crdl -> "Determined Cradle:" <+> viaShow crdl
      LogSetupMsg txt -> pretty txt
  
  -- | Flags inferred by @hie-bios@ to invoke GHC
  data HieBiosFlags = HieBiosFlags
        { ghcInvocation :: [String]
        , libdir :: FilePath
        , units :: [String]
        , rootDir :: FilePath
        -- ^ Root dir as reported by the 'Cradle'
        , componentDir :: FilePath
        -- ^ Root dir of the loaded 'ComponentOptions'.
        -- Important for multi-package cabal projects, as packages are not in the
        -- root of the cradle, but in some sub-directory.
        }
  
  -- | Prepare a GHC session using hie-bios from scratch
  hieBiosSetup :: Recorder (WithSeverity FlagsLog)
               -> FilePath -- ^ project root
               -> FilePath -- ^ entry file
               -> ExceptT String IO (Either String HieBiosFlags)
  hieBiosSetup logger projectRoot entryFile = do
  
    cradle <- hieBiosCradle logger projectRoot entryFile & ExceptT
  
    -- GHC is found in PATH (by hie-bios as well).
    logT "Checking GHC version against debugger version..."
    _version <- hieBiosRuntimeGhcVersion logger cradle
  
    logT "Discovering session flags with hie-bios..."
    r <- hieBiosFlags logger cradle projectRoot entryFile     & liftIO
  
    logT "Session setup with hie-bios was successful."
    return r
  
    where
      logT = logWith logger Info . LogSetupMsg . T.pack
  
  -- | Try implicit-hie and the builtin search to come up with a @'HIE.Cradle'@
  hieBiosCradle :: Recorder (WithSeverity FlagsLog) {-^ Logger -}
                -> FilePath {-^ Project root -}
                -> FilePath {-^ Entry file relative to root -}
                -> IO (Either String (HIE.Cradle Void))
  hieBiosCradle logger root relTarget = runExceptT $ do
    let target = root </> relTarget
    explicitCradle <- HIE.findCradle target & liftIO
    cradle <- maybe (loadImplicitCradle hieBiosLogger target)
                    (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO
    logWith logger Info $ LogCradle cradle
    pure cradle
    where
      hieBiosLogger = toCologAction $ cmapWithSev HieBiosLog logger
  
  -- | Fetch the runtime GHC version, according to hie-bios, and check it is the
  -- same as the compile time GHC version
  hieBiosRuntimeGhcVersion :: Recorder (WithSeverity FlagsLog)
                           -> HIE.Cradle Void
                           -> ExceptT String IO Version
  hieBiosRuntimeGhcVersion _logger cradle = do
    out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version"
  
    case versionMaybe out of
      Nothing -> throwError $ "Failed to parse GHC version: " <> out
      Just actualVersion -> do
  
        -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1):
        when (compileTimeGhcWithoutPatchVersion /= forgetPatchVersion actualVersion) $ do
          throwError $
            "Aborting...! The GHC version must be the same which " ++
              "ghc-debug-adapter was compiled against (" ++
                showVersion compileTimeGhcWithoutPatchVersion++
                  "). Instead, got " ++ (showVersion actualVersion) ++ "."
  
        pure actualVersion
  
  -- | Make 'HieBiosFlags' from the given target file
  hieBiosFlags :: Recorder (WithSeverity FlagsLog) {-^ Logger -}
               -> HIE.Cradle Void {-^ Project cradle the entry file belongs to -}
               -> FilePath {-^ Project root -}
               -> FilePath {-^ Entry file relative to root -}
               -> IO (Either String HieBiosFlags)
  hieBiosFlags _logger cradle root relTarget = runExceptT $ do
    let target = root </> relTarget
    libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir"
  
    -- To determine the flags we MUST set the current directory to the root
    -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does)
    -- (HIE.getCompilerOptions depends on CWD being the proper root dir)
    let compilerOpts = liftIO $ withCurrentDirectory root $
  #if MIN_VERSION_hie_bios(0,14,0)
                            HIE.getCompilerOptions target (HIE.LoadWithContext [target]) cradle
  #else
                            HIE.getCompilerOptions target [] cradle
  #endif
    componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"
  #if __GLASGOW_HASKELL__ >= 913
    -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading
    -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch.
    -- ["-fwrite-if-simplified-core"] ++
  #endif
  
    let (units', flags') = extractUnits (HIE.componentOptions componentOpts)
    return HieBiosFlags
      { ghcInvocation = flags' ++ ghcDebuggerFlags
      , libdir = libdir
      , units  = units'
      , rootDir = HIE.cradleRootDir cradle
      , componentDir = HIE.componentRoot componentOpts
      }
  
  unwrapCradleResult :: MonadError String m => [Char] -> HIE.CradleLoadResult a -> m a
  unwrapCradleResult m = \case
    HIE.CradleNone      -> throwError $ "HIE.CradleNone\n" ++ m
    HIE.CradleFail err  -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m
    HIE.CradleSuccess x -> return x
  
  extractUnits :: [String] -> ([String], [String])
  extractUnits = go [] []
    where
      -- TODO: we should likely use the 'processCmdLineP' instead
      go units rest ("-unit" : x : xs) = go (x : units) rest xs
      go units rest (x : xs)           = go units (x : rest) xs
      go units rest []                 = (reverse units, reverse rest)
  
  -- | Flags specific to haskell-debugger to append to all GHC invocations.
  ghcDebuggerFlags :: [String]
  ghcDebuggerFlags =
    [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt
    ]
  
  
  -- ----------------------------------------------------------------------------
  -- Utilities
  -- ----------------------------------------------------------------------------
  
  versionMaybe :: String -> Maybe Version
  versionMaybe xs = case reverse $ readP_to_S parseVersion xs of
    [] -> Nothing
    (x:_) -> Just (fst x)
  
  -- ----------------------------------------------------------------------------
  -- Implicit cradle discovery logic mirroring the one used by HLS.
  -- The code itself is copy-pasted from HLS.
  -- Obviously, we want to reuse the logic without having to depend on HLS.
  -- We should factor out a common sub-component from HLS and use it here as well.
  -- ----------------------------------------------------------------------------
  
  loadImplicitCradle :: Show a => LogAction IO (WithSeverity HIE.Log) -> FilePath -> IO (HIE.Cradle a)
  loadImplicitCradle l wfile = do
    is_dir <- doesDirectoryExist wfile
    let wdir | is_dir = wfile
             | otherwise = takeDirectory wfile
    cfg <- runMaybeT (implicitConfig wdir)
    case cfg of
      Just bc -> HIE.getCradle l absurd bc
      Nothing -> return $ HIE.defaultCradle l wdir
  
  -- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies
  implicitConfig :: FilePath -> MaybeT IO (Config.CradleConfig a, FilePath)
  implicitConfig = (fmap . first) (Config.CradleConfig noDeps) . inferCradleTree
    where
    noDeps :: [FilePath]
    noDeps = []
  
  
  inferCradleTree :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)
  inferCradleTree start_dir =
         maybeItsBios
     -- If we have both a config file (cabal.project/stack.yaml) and a work dir
     -- (dist-newstyle/.stack-work), prefer that
     <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir))
     <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir)
     -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal
     <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle)
     -- If we have a stack.yaml, use stack
     <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle)
     -- If we have a cabal file, use cabal
     <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle)
  
    where
    maybeItsBios = (\wdir -> (Config.Bios (Config.Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir
  
    cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir)
  
  -- | Generate a stack cradle given a filepath.
  --
  -- Since we assume there was proof that this file belongs to a stack cradle
  -- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files.
  -- We do not look for package.yaml, as we assume the corresponding .cabal has
  -- been generated already.
  --
  -- We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then
  -- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to
  -- component names.
  stackCradle :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)
  stackCradle fp = do
    pkgs <- Implicit.stackYamlPkgs fp
    pkgsWithComps <- liftIO $ catMaybes <$> mapM (Implicit.nestedPkg fp) pkgs
    let yaml = fp </> "stack.yaml"
    pure $ (,fp) $ case pkgsWithComps of
      [] -> Config.Stack (Config.StackType Nothing (Just yaml))
      ps -> Config.StackMulti mempty $ do
        Implicit.Package n cs <- ps
        c <- cs
        let (prefix, comp) = Implicit.stackComponent n c
        pure (prefix, Config.StackType (Just comp) (Just yaml))
  
  -- | By default, we generate a simple cabal cradle which is equivalent to the
  -- following hie.yaml:
  --
  -- @
  --   cradle:
  --     cabal:
  -- @
  --
  -- Note, this only works reliable for reasonably modern cabal versions >= 3.2.
  simpleCabalCradle :: FilePath -> (Config.CradleTree a, FilePath)
  simpleCabalCradle fp = (Config.Cabal $ Config.CabalType Nothing Nothing, fp)
  
  cabalExecutable :: MaybeT IO FilePath
  cabalExecutable = MaybeT $ findExecutable "cabal"
  
  stackExecutable :: MaybeT IO FilePath
  stackExecutable = MaybeT $ findExecutable "stack"
  
  biosWorkDir :: FilePath -> MaybeT IO FilePath
  biosWorkDir = findFileUpwards (".hie-bios" ==)
  
  cabalWorkDir :: FilePath -> MaybeT IO ()
  cabalWorkDir wdir = do
    check <- liftIO $ doesDirectoryExist (wdir </> "dist-newstyle")
    unless check $ fail "No dist-newstyle"
  
  stackWorkDir :: FilePath -> MaybeT IO ()
  stackWorkDir wdir = do
    check <- liftIO $ doesDirectoryExist (wdir </> ".stack-work")
    unless check $ fail "No .stack-work"
  
  cabalConfigDir :: FilePath -> MaybeT IO FilePath
  cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local")
  
  cabalFileDir :: FilePath -> MaybeT IO FilePath
  cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal")
  
  stackConfigDir :: FilePath -> MaybeT IO FilePath
  stackConfigDir = findFileUpwards isStack
    where
      isStack name = name == "stack.yaml"
  
  -- | Searches upwards for the first directory containing a file to match
  -- the predicate.
  findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
  findFileUpwards p dir = do
    cnts <-
      liftIO
      $ handleJust
          -- Catch permission errors
          (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)
          pure
          (findFile p dir)
  
    case cnts of
      [] | dir' == dir -> fail "No cabal files"
              | otherwise   -> findFileUpwards p dir'
      _ : _ -> return dir
    where dir' = takeDirectory dir
  
  -- | Sees if any file in the directory matches the predicate
  findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
  findFile p dir = do
    b <- doesDirectoryExist dir
    if b then getFiles >>= filterM doesPredFileExist else return []
    where
      getFiles = filter p <$> getDirectoryContents dir
      doesPredFileExist file = doesFileExist $ dir </> file
  
  --------------------------------------------------------------------------------
  
  compileTimeGhcWithoutPatchVersion :: Version
  compileTimeGhcWithoutPatchVersion =
    let
      versionNumber = __GLASGOW_HASKELL__ :: Int
      (major, minor) = divMod versionNumber 100
    in
      makeVersion [major, minor]
  
  forgetPatchVersion :: Version -> Version
  forgetPatchVersion v = case versionBranch v of
    (major:minor:_patches) -> makeVersion [major, minor]
    _ -> v
  