{-# LANGUAGE ScopedTypeVariables #-}
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)
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
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
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
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"
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
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
(\(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
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
==)