{-# 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.Maybe
import Data.Void
import HIE.Bios.Config hiding (cabalComponent, stackComponent)
import HIE.Bios.Cradle
import HIE.Bios.Types hiding (ActionName (..))
import Hie.Cabal.Parser
import Hie.Locate
import Hie.Yaml
import System.Directory hiding (findFile)
import System.FilePath
import System.IO.Error (isPermissionError)

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

implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig :: forall a. FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig FilePath
fp = do
  (CradleType a
crdType, FilePath
wdir) <- forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
implicitConfig' FilePath
fp
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [FilePath] -> CradleType a -> CradleConfig a
CradleConfig [] CradleType a
crdType, FilePath
wdir)

implicitConfig' :: FilePath -> MaybeT IO (CradleType a, FilePath)
implicitConfig' :: forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
implicitConfig' FilePath
fp =
  ( \FilePath
wdir ->
      (forall a.
Callable -> Maybe Callable -> Maybe FilePath -> CradleType a
Bios (FilePath -> Callable
Program forall a b. (a -> b) -> a -> b
$ FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
".hie-bios") forall a. Maybe a
Nothing forall a. Maybe a
Nothing, FilePath
wdir)
  )
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> MaybeT IO FilePath
biosWorkDir FilePath
fp
    --   <|> (Obelisk,) <$> obeliskWorkDir fp
    --   <|> (Bazel,) <$> rulesHaskellWorkDir fp
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
cabalExecutable forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
cabalProjectDir FilePath
fp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
cabalDistDir FilePath
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
cabal)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
stackExecutable forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
stackYamlDir FilePath
fp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
stackWorkDir FilePath
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
stack)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
cabalExecutable forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (FilePath -> MaybeT IO FilePath
cabalProjectDir FilePath
fp forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePath -> MaybeT IO FilePath
cabalDistDir FilePath
fp) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
cabal)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
stackExecutable forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
stackYamlDir FilePath
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
stack)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
cabalExecutable forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> MaybeT IO FilePath
cabalFile FilePath
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
cabal)
  where
    readPkgs :: (Name -> Component -> b)
-> (FilePath -> m [FilePath]) -> FilePath -> m [b]
readPkgs Name -> Component -> b
f FilePath -> m [FilePath]
gp FilePath
p = do
      [FilePath]
cfs <- FilePath -> m [FilePath]
gp FilePath
p
      [Package]
pkgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> FilePath -> IO (Maybe Package)
nestedPkg FilePath
p) [FilePath]
cfs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {b}. (Name -> Component -> b) -> Package -> [b]
components Name -> Component -> b
f) [Package]
pkgs
    build :: ([b] -> a)
-> (Name -> Component -> b)
-> (FilePath -> m [FilePath])
-> FilePath
-> m (a, FilePath)
build [b] -> a
cn Name -> Component -> b
cc FilePath -> m [FilePath]
gp FilePath
p = do
      a
c <- [b] -> a
cn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {b}.
MonadIO m =>
(Name -> Component -> b)
-> (FilePath -> m [FilePath]) -> FilePath -> m [b]
readPkgs Name -> Component -> b
cc FilePath -> m [FilePath]
gp FilePath
p
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
c, FilePath
p)
    cabal :: FilePath -> MaybeT IO (CradleType a, FilePath)
    cabal :: forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
cabal = forall {m :: * -> *} {b} {a}.
MonadIO m =>
([b] -> a)
-> (Name -> Component -> b)
-> (FilePath -> m [FilePath])
-> FilePath
-> m (a, FilePath)
build (forall a. CabalType -> [(FilePath, CabalType)] -> CradleType a
CabalMulti forall a. Monoid a => a
mempty) Name -> Component -> (FilePath, CabalType)
cabalComponent' FilePath -> MaybeT IO [FilePath]
cabalPkgs
    stack :: FilePath -> MaybeT IO (CradleType a, FilePath)
    stack :: forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
stack = forall {m :: * -> *} {b} {a}.
MonadIO m =>
([b] -> a)
-> (Name -> Component -> b)
-> (FilePath -> m [FilePath])
-> FilePath
-> m (a, FilePath)
build (forall a. StackType -> [(FilePath, StackType)] -> CradleType a
StackMulti forall a. Monoid a => a
mempty) Name -> Component -> (FilePath, StackType)
stackComponent' FilePath -> MaybeT IO [FilePath]
stackYamlPkgs
    components :: (Name -> Component -> b) -> Package -> [b]
components Name -> Component -> b
f (Package Name
n [Component]
cs) = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Component -> b
f Name
n) [Component]
cs

    cabalComponent' :: Name -> Component -> (FilePath, CabalType)
cabalComponent' Name
n Component
c = Maybe FilePath -> CabalType
CabalType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Component -> (FilePath, FilePath)
cabalComponent Name
n Component
c
    stackComponent' :: Name -> Component -> (FilePath, StackType)
stackComponent' Name
n Component
c = forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe FilePath -> Maybe FilePath -> StackType
StackType forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Component -> (FilePath, FilePath)
stackComponent Name
n Component
c

------------------------------------------------------------------------

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

cabalDistDir :: FilePath -> MaybeT IO FilePath
cabalDistDir :: FilePath -> MaybeT IO FilePath
cabalDistDir = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findSubdirUpwards FilePath -> Bool
isCabal
  where
    -- TODO do old style dist builds work?
    isCabal :: FilePath -> Bool
isCabal FilePath
name = FilePath
name forall a. Eq a => a -> a -> Bool
== FilePath
"dist-newstyle" Bool -> Bool -> Bool
|| FilePath
name forall a. Eq a => a -> a -> Bool
== FilePath
"dist"

cabalProjectDir :: FilePath -> MaybeT IO FilePath
cabalProjectDir :: FilePath -> MaybeT IO FilePath
cabalProjectDir = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath -> Bool
isCabal
  where
    isCabal :: FilePath -> Bool
isCabal FilePath
"cabal.project" = Bool
True
    isCabal FilePath
"cabal.project.local" = Bool
True
    isCabal FilePath
_ = Bool
False

cabalFile :: FilePath -> MaybeT IO FilePath
cabalFile :: FilePath -> MaybeT IO FilePath
cabalFile = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath -> Bool
isCabal
  where
    isCabal :: FilePath -> Bool
isCabal = (FilePath
".cabal" forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension

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

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

stackWorkDir :: FilePath -> MaybeT IO FilePath
stackWorkDir :: FilePath -> MaybeT IO FilePath
stackWorkDir = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findSubdirUpwards FilePath -> Bool
isStack
  where
    isStack :: FilePath -> Bool
isStack FilePath
name = FilePath
name forall a. Eq a => a -> a -> Bool
== FilePath
".stack-work"

stackYamlDir :: FilePath -> MaybeT IO FilePath
stackYamlDir :: FilePath -> MaybeT IO FilePath
stackYamlDir = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath -> Bool
isStack
  where
    isStack :: FilePath -> Bool
isStack FilePath
name = FilePath
name forall a. Eq a => a -> a -> Bool
== FilePath
"stack.yaml"

-- | Searches upwards for the first directory containing a subdirectory
-- to match the predicate.
findSubdirUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findSubdirUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findSubdirUpwards FilePath -> Bool
p FilePath
dir = (FilePath -> IO Bool) -> FilePath -> MaybeT IO FilePath
findContentUpwards FilePath -> IO Bool
p' FilePath
dir
  where
    p' :: FilePath -> IO Bool
p' FilePath
subdir = do
      Bool
exists <- FilePath -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
subdir
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool
p FilePath
subdir) Bool -> Bool -> Bool
&& Bool
exists

-- | 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 = (FilePath -> IO Bool) -> FilePath -> MaybeT IO FilePath
findContentUpwards FilePath -> IO Bool
p' FilePath
dir
  where
    p' :: FilePath -> IO Bool
p' FilePath
file = do
      Bool
exists <- FilePath -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool
p FilePath
file) Bool -> Bool -> Bool
&& Bool
exists

findContentUpwards :: (FilePath -> IO Bool) -> FilePath -> MaybeT IO FilePath
findContentUpwards :: (FilePath -> IO Bool) -> FilePath -> MaybeT IO FilePath
findContentUpwards FilePath -> IO Bool
p FilePath
dir = do
  [FilePath]
cnts <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      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 forall a. a -> Maybe a
Just [] else forall a. Maybe a
Nothing)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ((FilePath -> IO Bool) -> FilePath -> IO [FilePath]
findContent FilePath -> IO Bool
p FilePath
dir)
  case [FilePath]
cnts of
    []
      | FilePath
dir' forall a. Eq a => a -> a -> Bool
== FilePath
dir -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No cabal files"
      | Bool
otherwise -> (FilePath -> IO Bool) -> FilePath -> MaybeT IO FilePath
findContentUpwards FilePath -> IO Bool
p FilePath
dir'
    FilePath
_ : [FilePath]
_ -> 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
findContent :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
findContent :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
findContent FilePath -> IO Bool
p FilePath
dir = do
  Bool
b <- FilePath -> IO Bool
doesDirectoryExist FilePath
dir
  if Bool
b then IO [FilePath]
getFiles else forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    getFiles :: IO [FilePath]
getFiles = FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
p

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