{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Development.Debug.Session.Setup
  (
  -- * Setting up a hie-bios session
    HieBiosFlags(..)
  , hieBiosSetup

  -- * Logging
  , SessionSetupLog(..)
  , renderSessionSetupLog

  , GhcInvocation(..)
  , DebugRunnerProvider
  , hieDebugRunner
  , DebugRunnerConf(..)
  ) where

import Control.Applicative ((<|>))
import Control.Concurrent (newMVar, MVar, withMVar)
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 (withCurrentDirectory, findFile)
import System.Directory qualified as D
import System.FilePath
import System.IO.Error
import Text.ParserCombinators.ReadP (readP_to_S)
import Data.Functor.Contravariant
import GHC.IO (unsafePerformIO)

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 Colog.Core
import Prettyprinter
import Prettyprinter.Render.Text

import qualified GHC.Debugger.Monad as Debugger
import GHC (Ghc)
import GHC.Debugger.Monad (ProjectDebugSpec(ProjectDebugSpec))

data GhcInvocation = GhcInvocation
  { gi_libdir :: FilePath
  , gi_units :: [String]
  , gi_args :: [String]
  -- ^ includes also the ghcExtraArgs that will be passed to the DebugSession by the DebugRunner.
  }

-- | When successful in setting up a DebugRunner it also returns the GhcInvocation used.
type DebugRunnerProvider a = LogAction IO (WithSeverity SessionSetupLog)
  -> DebugRunnerConf
  -> IO (Either String (GhcInvocation, Debugger.DebugRunner Ghc a))

data DebugRunnerConf = DebugRunnerConf
  { drcProjectRoot :: FilePath
  , drcEntryFile :: FilePath
  , drcExtraGhcArgs :: [String]
  , drcCradleFile :: Maybe FilePath
    -- ^ specified cradle file rather than letting be inferred from
    -- @drcEntryFile@, relative to @drcProjectRoot@ if so. @DebugRunnerProvider@s
    -- must WARN if this field is @Just@ but they do not use hie cradles.
  } deriving Show

data SessionSetupLog
  = HieBiosLog HIE.Log
  | LogCradle (HIE.Cradle Void)
  | LogSetupMsg T.Text
  deriving Show

renderSessionSetupLog :: SessionSetupLog -> T.Text
renderSessionSetupLog = \case
  HieBiosLog l -> renderStrict $ layoutPretty defaultLayoutOptions $ pretty l
  LogCradle c -> T.pack $ "Using cradle: " ++ show c
  LogSetupMsg m -> m

-- | 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 :: LogAction IO (WithSeverity SessionSetupLog)
             -> FilePath -- ^ project root
             -> FilePath -- ^ entry file
             -> Maybe FilePath -- ^ cradle file
             -> ExceptT String IO (Either String HieBiosFlags)
hieBiosSetup logger projectRoot entryFile cradleFile = do

  logInfo "Figuring out the right flags to compile the project using hie-bios..."
  cradle <- hieBiosCradle logger projectRoot entryFile cradleFile & ExceptT

  -- GHC is found in PATH (by hie-bios as well).
  logInfo "Checking GHC version against debugger version..."
  _version <- hieBiosRuntimeGhcVersion cradle

  logInfo "Discovering session flags with hie-bios..."
  r <- hieBiosFlags cradle projectRoot entryFile     & liftIO

  logInfo "Session setup with hie-bios was successful."
  return r

  where
    logInfo m = liftLogIO logger <& WithSeverity (LogSetupMsg (T.pack m)) Info

-- | Try implicit-hie and the builtin search to come up with a @'HIE.Cradle'@
hieBiosCradle :: LogAction IO (WithSeverity SessionSetupLog)
              -> FilePath -- ^ Project root
              -> FilePath -- ^ Entry file relative to root
              -> Maybe FilePath -- ^ Cradle file relative to root
              -> IO (Either String (HIE.Cradle Void))
hieBiosCradle logger root relTarget mrelCradle = runExceptT $ do
  let target = root </> relTarget
  explicitCradle <- case mrelCradle of
    Nothing -> HIE.findCradle target & liftIO
    Just ((root </>) -> cradleFile) -> do
      liftIO (doesFileExist cradleFile) >>= \case
        True -> return $ Just cradleFile
        False -> throwError $ "Specified Cradle file does not exist: " ++ cradleFile
  cradle <- maybe (loadImplicitCradle hieBiosLogger target)
                  (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO
  liftLogIO logger <& WithSeverity (LogCradle cradle) Info
  pure cradle
  where
    hieBiosLogger = contramap (fmap HieBiosLog) logger

-- | Fetch the runtime GHC version, according to hie-bios, and check it is the
-- same as the compile time GHC version
hieBiosRuntimeGhcVersion :: HIE.Cradle Void
                         -> ExceptT String IO Version
hieBiosRuntimeGhcVersion 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 :: HIE.Cradle Void {-^ Project cradle the entry file belongs to -}
             -> FilePath {-^ Project root -}
             -> FilePath {-^ Entry file relative to root -}
             -> IO (Either String HieBiosFlags)
hieBiosFlags 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 $
                          HIE.getCompilerOptions (HIE.TargetWithContext target [target]) HIE.LoadUnitsFromCradle cradle
  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
  ]

hieDebugRunner
  :: LogAction IO (WithSeverity SessionSetupLog)
  -> DebugRunnerConf
  -> IO (Either String (GhcInvocation, Debugger.DebugRunner Ghc a))
hieDebugRunner l (DebugRunnerConf projectRoot entryFile extraGhcArgs cradleFile) = runExceptT $ do
  r <- hieBiosSetup l projectRoot entryFile cradleFile
  HieBiosFlags{..} <- case r of
    Left e -> throwError e
    Right f -> return f
  let absEntryFile = normalise $ projectRoot </> entryFile
  let gI = GhcInvocation libdir units (ghcInvocation ++ extraGhcArgs)
  pure $ (,) gI $ Debugger.withProjectDebugSession ProjectDebugSpec{..}

-- ----------------------------------------------------------------------------
-- 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) Nothing)
    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) Nothing)

-- | 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 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

{-# NOINLINE cwdLock #-}
cwdLock :: MVar ()
cwdLock = unsafePerformIO $ newMVar ()

withCurrentDirectory :: FilePath -> IO b -> IO b
withCurrentDirectory fp m = withMVar cwdLock $ \ _ -> D.withCurrentDirectory fp m