{-# LANGUAGE ScopedTypeVariables #-}

-- Code is derived from https://github.com/mpickering/hie-bios/blob/master/src/HIE/Bios/Cradle.hs
-- git commit: 6460ab40709fe5cc6209b2094d32f80d46c889fd
-- Derived code subject to hie-bios's BSD 3-Clause "New" or "Revised" License
-- Hie-bios's license is distributed with the hie-bios dependency
-- Initial differences can be found at https://github.com/mpickering/hie-bios/pull/178

module Hie.Implicit.Cradle
  ( loadImplicitHieCradle,
  )
where

import Control.Applicative ((<|>))
import Control.Exception (handleJust)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Data.List
import Data.Maybe
import Data.Ord (Down (..))
import qualified Data.Text as T
import Data.Void
import qualified Data.Yaml as Yaml
import GHC.Fingerprint (fingerprintString)
import HIE.Bios.Config hiding (cabalComponent, stackComponent)
import HIE.Bios.Cradle
import HIE.Bios.Environment (getCacheDir)
import HIE.Bios.Types hiding (ActionName (..))
import qualified HIE.Bios.Types as Types
import HIE.Bios.Wrappers
import Hie.Cabal.Parser
import Hie.Locate
import Hie.Yaml
import System.Directory hiding (findFile)
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error (isPermissionError)
import System.IO.Temp
import System.Info.Extra (isWindows)
import System.PosixCompat.Files
import System.Process

-- | Given root\/foo\/bar.hs, load an implicit cradle
loadImplicitHieCradle :: FilePath -> IO (Cradle a)
loadImplicitHieCradle wfile = do
  let wdir = takeDirectory wfile
  cfg <- runMaybeT (implicitConfig wdir)
  return $ case cfg of
    Just bc -> getCradle absurd bc
    Nothing -> defaultCradle wdir

implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig fp = do
  (crdType, wdir) <- implicitConfig' fp
  return (CradleConfig [] crdType, wdir)

implicitConfig' :: FilePath -> MaybeT IO (CradleType a, FilePath)
implicitConfig' fp =
  ( \wdir ->
      (Bios (Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)
  )
    <$> biosWorkDir fp
    --   <|> (Obelisk,) <$> obeliskWorkDir fp
    --   <|> (Bazel,) <$> rulesHaskellWorkDir fp
    <|> (cabalExecutable >> cabalProjectDir fp >> cabalDistDir fp >>= cabal)
    <|> (stackExecutable >> stackYamlDir fp >> stackWorkDir fp >>= stack)
    <|> (cabalExecutable >> cabalProjectDir fp >>= cabal)
    <|> (stackExecutable >> stackYamlDir fp >>= stack)
    <|> (cabalExecutable >> cabalFile fp >>= cabal)
  where
    readPkgs f gp p = do
      cfs <- gp p
      pkgs <- liftIO $ catMaybes <$> mapM (nestedPkg p) cfs
      pure $ concatMap (components f) pkgs
    build cn cc gp p = do
      c <- cn <$> readPkgs cc gp p
      pure (c, p)
    cabal :: FilePath -> MaybeT IO (CradleType a, FilePath)
    cabal = build (CabalMulti mempty) cabalComponent' cabalPkgs
    stack :: FilePath -> MaybeT IO (CradleType a, FilePath)
    stack = build (StackMulti mempty) stackComponent' stackYamlPkgs
    components f (Package n cs) = map (f n) cs

    cabalComponent' n c = CabalType . Just <$> cabalComponent n c
    stackComponent' n c = flip StackType Nothing . Just <$> stackComponent n c
------------------------------------------------------------------------
-- Cabal Cradle
-- Works for new-build by invoking `v2-repl` does not support components
-- yet.
cabalCradleDependencies :: FilePath -> IO [FilePath]
cabalCradleDependencies rootDir = do
  cabalFiles <- findCabalFiles rootDir
  return $ cabalFiles ++ ["cabal.project", "cabal.project.local"]

findCabalFiles :: FilePath -> IO [FilePath]
findCabalFiles wdir = do
  dirContent <- listDirectory wdir
  return $ filter ((== ".cabal") . takeExtension) dirContent

-- | GHC process information.
-- Consists of the filepath to the ghc executable and
-- arguments to the executable.
type GhcProc = (FilePath, [String])

cabalExecutable :: MaybeT IO FilePath
cabalExecutable = MaybeT $ findExecutable "cabal"

cabalDistDir :: FilePath -> MaybeT IO FilePath
cabalDistDir = findFileUpwards isCabal
  where
    -- TODO do old style dist builds work?
    isCabal name = name == "dist-newstyle" || name == "dist"

cabalProjectDir :: FilePath -> MaybeT IO FilePath
cabalProjectDir = findFileUpwards isCabal
  where
    isCabal name = name == "cabal.project"

cabalFile :: FilePath -> MaybeT IO FilePath
cabalFile = findFileUpwards isCabal
  where
    isCabal = (".cabal" ==) . takeExtension

------------------------------------------------------------------------
-- Stack Cradle
-- Works for by invoking `stack repl` with a wrapper script

stackCradleDependencies :: FilePath -> IO [FilePath]
stackCradleDependencies wdir = do
  cabalFiles <- findCabalFiles wdir
  return $ cabalFiles ++ ["package.yaml", "stack.yaml"]

combineExitCodes :: [ExitCode] -> ExitCode
combineExitCodes = foldr go ExitSuccess
  where
    go ExitSuccess b = b
    go a _ = a

stackExecutable :: MaybeT IO FilePath
stackExecutable = MaybeT $ findExecutable "stack"

stackWorkDir :: FilePath -> MaybeT IO FilePath
stackWorkDir = findFileUpwards isStack
  where
    isStack name = name == ".stack-work"

stackYamlDir :: FilePath -> MaybeT IO FilePath
stackYamlDir = 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 else pure []
  where
    getFiles = filter p <$> getDirectoryContents dir
    doesPredFileExist file = doesFileExist $ dir </> file

biosWorkDir :: FilePath -> MaybeT IO FilePath
biosWorkDir = findFileUpwards (".hie-bios" ==)