module Development.IDE.Session.Implicit
  ( loadImplicitCradle
  ) where


import           Control.Applicative       ((<|>))
import           Control.Exception         (handleJust)
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Maybe
import           Data.Bifunctor
import           Data.Functor              ((<&>))
import           Data.Maybe
import           Data.Void
import           System.Directory          hiding (findFile)
import           System.FilePath
import           System.IO.Error

import           Colog.Core                (LogAction (..), WithSeverity (..))
import           HIE.Bios.Config
import           HIE.Bios.Cradle           (defaultCradle, getCradle)
import           HIE.Bios.Types            hiding (ActionName (..))

import           Hie.Cabal.Parser
import           Hie.Locate
import qualified Hie.Yaml                  as Implicit

loadImplicitCradle :: Show a => LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a)
loadImplicitCradle :: forall a.
Show a =>
LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a)
loadImplicitCradle LogAction IO (WithSeverity Log)
l FilePath
wfile = do
  Bool
is_dir <- FilePath -> IO Bool
doesDirectoryExist FilePath
wfile
  let wdir :: FilePath
wdir | Bool
is_dir = FilePath
wfile
           | Bool
otherwise = FilePath -> FilePath
takeDirectory FilePath
wfile
  Maybe (CradleConfig Void, FilePath)
cfg <- MaybeT IO (CradleConfig Void, FilePath)
-> IO (Maybe (CradleConfig Void, FilePath))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (FilePath -> MaybeT IO (CradleConfig Void, FilePath)
forall a. FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig FilePath
wdir)
  case Maybe (CradleConfig Void, FilePath)
cfg of
    Just (CradleConfig Void, FilePath)
bc -> LogAction IO (WithSeverity Log)
-> (Void -> CradleAction a)
-> (CradleConfig Void, FilePath)
-> IO (Cradle a)
forall a b.
Show a =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> (CradleConfig b, FilePath)
-> IO (Cradle a)
getCradle LogAction IO (WithSeverity Log)
l Void -> CradleAction a
forall a. Void -> a
absurd (CradleConfig Void, FilePath)
bc
    Maybe (CradleConfig Void, FilePath)
Nothing -> Cradle a -> IO (Cradle a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cradle a -> IO (Cradle a)) -> Cradle a -> IO (Cradle a)
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log) -> FilePath -> Cradle a
forall a. LogAction IO (WithSeverity Log) -> FilePath -> Cradle a
defaultCradle LogAction IO (WithSeverity Log)
l FilePath
wdir

-- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies
implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig :: forall a. FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig = (((CradleTree a, FilePath) -> (CradleConfig a, FilePath))
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleConfig a, FilePath)
forall a b. (a -> b) -> MaybeT IO a -> MaybeT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CradleTree a, FilePath) -> (CradleConfig a, FilePath))
 -> MaybeT IO (CradleTree a, FilePath)
 -> MaybeT IO (CradleConfig a, FilePath))
-> ((CradleTree a -> CradleConfig a)
    -> (CradleTree a, FilePath) -> (CradleConfig a, FilePath))
-> (CradleTree a -> CradleConfig a)
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleConfig a, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CradleTree a -> CradleConfig a)
-> (CradleTree a, FilePath) -> (CradleConfig a, FilePath)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) ([FilePath] -> CradleTree a -> CradleConfig a
forall a. [FilePath] -> CradleTree a -> CradleConfig a
CradleConfig [FilePath]
noDeps) (MaybeT IO (CradleTree a, FilePath)
 -> MaybeT IO (CradleConfig a, FilePath))
-> (FilePath -> MaybeT IO (CradleTree a, FilePath))
-> FilePath
-> MaybeT IO (CradleConfig a, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> MaybeT IO (CradleTree a, FilePath)
forall a. FilePath -> MaybeT IO (CradleTree a, FilePath)
inferCradleTree
  where
  noDeps :: [FilePath]
  noDeps :: [FilePath]
noDeps = []


inferCradleTree :: FilePath -> MaybeT IO (CradleTree a, FilePath)
inferCradleTree :: forall a. FilePath -> MaybeT IO (CradleTree a, FilePath)
inferCradleTree FilePath
start_dir =
       MaybeT IO (CradleTree a, FilePath)
forall {a}. MaybeT IO (CradleTree a, FilePath)
maybeItsBios
   -- If we have both a config file (cabal.project/stack.yaml) and a work dir
   -- (dist-newstyle/.stack-work), prefer that
   MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
cabalExecutable MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
cabalConfigDir FilePath
start_dir MaybeT IO FilePath
-> (FilePath -> MaybeT IO (CradleTree a, FilePath))
-> MaybeT IO (CradleTree a, FilePath)
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
dir -> FilePath -> MaybeT IO ()
cabalWorkDir FilePath
dir MaybeT IO ()
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CradleTree a, FilePath) -> MaybeT IO (CradleTree a, FilePath)
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> (CradleTree a, FilePath)
forall a. FilePath -> (CradleTree a, FilePath)
simpleCabalCradle FilePath
dir))
   MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
stackExecutable MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
stackConfigDir FilePath
start_dir MaybeT IO FilePath
-> (FilePath -> MaybeT IO (CradleTree a, FilePath))
-> MaybeT IO (CradleTree a, FilePath)
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
dir -> FilePath -> MaybeT IO ()
stackWorkDir FilePath
dir MaybeT IO ()
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO (CradleTree a, FilePath)
forall a. FilePath -> MaybeT IO (CradleTree a, FilePath)
stackCradle FilePath
dir)
   -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal
   MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
cabalExecutable MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (FilePath -> MaybeT IO FilePath
cabalConfigDir FilePath
start_dir MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO FilePath
cabalFileAndWorkDir) MaybeT IO FilePath
-> (FilePath -> (CradleTree a, FilePath))
-> MaybeT IO (CradleTree a, FilePath)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FilePath -> (CradleTree a, FilePath)
forall a. FilePath -> (CradleTree a, FilePath)
simpleCabalCradle)
   -- If we have a stack.yaml, use stack
   MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
stackExecutable MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
stackConfigDir FilePath
start_dir MaybeT IO FilePath
-> (FilePath -> MaybeT IO (CradleTree a, FilePath))
-> MaybeT IO (CradleTree a, FilePath)
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> MaybeT IO (CradleTree a, FilePath)
forall a. FilePath -> MaybeT IO (CradleTree a, FilePath)
stackCradle)
   -- If we have a cabal file, use cabal
   MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
-> MaybeT IO (CradleTree a, FilePath)
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
cabalExecutable MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
cabalFileDir FilePath
start_dir MaybeT IO FilePath
-> (FilePath -> (CradleTree a, FilePath))
-> MaybeT IO (CradleTree a, FilePath)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> FilePath -> (CradleTree a, FilePath)
forall a. FilePath -> (CradleTree a, FilePath)
simpleCabalCradle)

  where
  maybeItsBios :: MaybeT IO (CradleTree a, FilePath)
maybeItsBios = (\FilePath
wdir -> (Callable -> Maybe Callable -> Maybe FilePath -> CradleTree a
forall a.
Callable -> Maybe Callable -> Maybe FilePath -> CradleTree a
Bios (FilePath -> Callable
Program (FilePath -> Callable) -> FilePath -> Callable
forall a b. (a -> b) -> a -> b
$ FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
".hie-bios") Maybe Callable
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing, FilePath
wdir)) (FilePath -> (CradleTree a, FilePath))
-> MaybeT IO FilePath -> MaybeT IO (CradleTree a, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> MaybeT IO FilePath
biosWorkDir FilePath
start_dir

  cabalFileAndWorkDir :: MaybeT IO FilePath
cabalFileAndWorkDir = FilePath -> MaybeT IO FilePath
cabalFileDir FilePath
start_dir MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\FilePath
dir -> FilePath -> MaybeT IO ()
cabalWorkDir FilePath
dir MaybeT IO () -> MaybeT IO FilePath -> MaybeT IO FilePath
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
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 (CradleTree a, FilePath)
stackCradle :: forall a. FilePath -> MaybeT IO (CradleTree a, FilePath)
stackCradle FilePath
fp = do
  [FilePath]
pkgs <- FilePath -> MaybeT IO [FilePath]
stackYamlPkgs FilePath
fp
  [Package]
pkgsWithComps <- IO [Package] -> MaybeT IO [Package]
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Package] -> MaybeT IO [Package])
-> IO [Package] -> MaybeT IO [Package]
forall a b. (a -> b) -> a -> b
$ [Maybe Package] -> [Package]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Package] -> [Package])
-> IO [Maybe Package] -> IO [Package]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe Package))
-> [FilePath] -> IO [Maybe Package]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> FilePath -> IO (Maybe Package)
nestedPkg FilePath
fp) [FilePath]
pkgs
  let yaml :: FilePath
yaml = FilePath
fp FilePath -> FilePath -> FilePath
</> FilePath
"stack.yaml"
  (CradleTree a, FilePath) -> MaybeT IO (CradleTree a, FilePath)
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CradleTree a, FilePath) -> MaybeT IO (CradleTree a, FilePath))
-> (CradleTree a, FilePath) -> MaybeT IO (CradleTree a, FilePath)
forall a b. (a -> b) -> a -> b
$ (,FilePath
fp) (CradleTree a -> (CradleTree a, FilePath))
-> CradleTree a -> (CradleTree a, FilePath)
forall a b. (a -> b) -> a -> b
$ case [Package]
pkgsWithComps of
    [] -> StackType -> CradleTree a
forall a. StackType -> CradleTree a
Stack (Maybe FilePath -> Maybe FilePath -> StackType
StackType Maybe FilePath
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
yaml))
    [Package]
ps -> StackType -> [(FilePath, StackType)] -> CradleTree a
forall a. StackType -> [(FilePath, StackType)] -> CradleTree a
StackMulti StackType
forall a. Monoid a => a
mempty ([(FilePath, StackType)] -> CradleTree a)
-> [(FilePath, StackType)] -> CradleTree a
forall a b. (a -> b) -> a -> b
$ do
      Package Name
n [Component]
cs <- [Package]
ps
      Component
c <- [Component]
cs
      let (FilePath
prefix, FilePath
comp) = Name -> Component -> (FilePath, FilePath)
Implicit.stackComponent Name
n Component
c
      (FilePath, StackType) -> [(FilePath, StackType)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
prefix, Maybe FilePath -> Maybe FilePath -> StackType
StackType (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
comp) (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
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 -> (CradleTree a, FilePath)
simpleCabalCradle :: forall a. FilePath -> (CradleTree a, FilePath)
simpleCabalCradle FilePath
fp = (CabalType -> CradleTree a
forall a. CabalType -> CradleTree a
Cabal (CabalType -> CradleTree a) -> CabalType -> CradleTree a
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Maybe FilePath -> CabalType
CabalType Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing, FilePath
fp)

cabalExecutable :: MaybeT IO FilePath
cabalExecutable :: MaybeT IO FilePath
cabalExecutable = IO (Maybe FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FilePath) -> MaybeT IO FilePath)
-> IO (Maybe FilePath) -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
findExecutable FilePath
"cabal"

stackExecutable :: MaybeT IO FilePath
stackExecutable :: MaybeT IO FilePath
stackExecutable = IO (Maybe FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FilePath) -> MaybeT IO FilePath)
-> IO (Maybe FilePath) -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
findExecutable FilePath
"stack"

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

cabalWorkDir :: FilePath -> MaybeT IO ()
cabalWorkDir :: FilePath -> MaybeT IO ()
cabalWorkDir FilePath
wdir = do
  Bool
check <- IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
"dist-newstyle")
  Bool -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
check (MaybeT IO () -> MaybeT IO ()) -> MaybeT IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> MaybeT IO ()
forall a. FilePath -> MaybeT IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No dist-newstyle"

stackWorkDir :: FilePath -> MaybeT IO ()
stackWorkDir :: FilePath -> MaybeT IO ()
stackWorkDir FilePath
wdir = do
  Bool
check <- IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
".stack-work")
  Bool -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
check (MaybeT IO () -> MaybeT IO ()) -> MaybeT IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> MaybeT IO ()
forall a. FilePath -> MaybeT IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No .stack-work"

cabalConfigDir :: FilePath -> MaybeT IO FilePath
cabalConfigDir :: FilePath -> MaybeT IO FilePath
cabalConfigDir = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards (\FilePath
fp -> FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"cabal.project" Bool -> Bool -> Bool
|| FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"cabal.project.local")

cabalFileDir :: FilePath -> MaybeT IO FilePath
cabalFileDir :: FilePath -> MaybeT IO FilePath
cabalFileDir = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards (\FilePath
fp -> FilePath -> FilePath
takeExtension FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal")

stackConfigDir :: FilePath -> MaybeT IO FilePath
stackConfigDir :: FilePath -> MaybeT IO FilePath
stackConfigDir = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath -> Bool
forall {a}. (Eq a, IsString a) => a -> Bool
isStack
  where
    isStack :: a -> Bool
isStack a
name = a
name a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"stack.yaml"

-- | Searches upwards for the first directory containing a file to match
-- the predicate.
findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath -> Bool
p FilePath
dir = do
  [FilePath]
cnts <-
    IO [FilePath] -> MaybeT IO [FilePath]
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO [FilePath] -> MaybeT IO [FilePath])
-> IO [FilePath] -> MaybeT IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOError -> Maybe [FilePath])
-> ([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust
        -- Catch permission errors
        (\(IOError
e :: IOError) -> if IOError -> Bool
isPermissionError IOError
e then [FilePath] -> Maybe [FilePath]
forall a. a -> Maybe a
Just [] else Maybe [FilePath]
forall a. Maybe a
Nothing)
        [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ((FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile FilePath -> Bool
p FilePath
dir)

  case [FilePath]
cnts of
    [] | FilePath
dir' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
dir -> FilePath -> MaybeT IO FilePath
forall a. FilePath -> MaybeT IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No cabal files"
            | Bool
otherwise   -> (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath -> Bool
p FilePath
dir'
    FilePath
_ : [FilePath]
_ -> FilePath -> MaybeT IO FilePath
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
  where dir' :: FilePath
dir' = FilePath -> FilePath
takeDirectory FilePath
dir

-- | Sees if any file in the directory matches the predicate
findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile FilePath -> Bool
p FilePath
dir = do
  Bool
b <- FilePath -> IO Bool
doesDirectoryExist FilePath
dir
  if Bool
b then IO [FilePath]
getFiles IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesPredFileExist else [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    getFiles :: IO [FilePath]
getFiles = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
p ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir
    doesPredFileExist :: FilePath -> IO Bool
doesPredFileExist FilePath
file = FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file