module Stan.Cabal
( createCabalExtensionsMap
, usedCabalFiles
, mergeParsedExtensions
) where
import Relude.Extra.Tuple (toSnd)
import Colourista (errorMessage, infoMessage, warningMessage)
import Control.Exception (catch)
import Extensions (CabalException, ExtensionsError (..), ExtensionsResult, ParsedExtensions (..),
mergeAnyExtensions, parseCabalFileExtensions)
import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, listDirectory,
makeRelativeToCurrentDirectory)
import System.FilePath (takeExtension, (</>))
import System.IO.Unsafe (unsafeInterleaveIO)
import Stan.Hie.Compat (HieFile (..))
import qualified Data.Map.Strict as Map
usedCabalFiles :: [FilePath] -> IO [FilePath]
usedCabalFiles :: [FilePath] -> IO [FilePath]
usedCabalFiles fs :: [FilePath]
fs = do
[FilePath]
cabals <- case [FilePath]
fs of
[] -> IO [FilePath]
findCabalFiles
files :: [FilePath]
files -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath]
files
(FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO FilePath
makeRelativeToCurrentDirectory [FilePath]
cabals
createCabalExtensionsMap
:: Bool
-> [FilePath]
-> [HieFile]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
createCabalExtensionsMap :: Bool
-> [FilePath]
-> [HieFile]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
createCabalExtensionsMap isLoud :: Bool
isLoud cabalPath :: [FilePath]
cabalPath hies :: [HieFile]
hies = case [FilePath]
cabalPath of
[] -> IO [FilePath]
findCabalFiles IO [FilePath]
-> ([FilePath]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Text -> IO ()
warningMessage ".cabal file not found in the current directory."
Text -> IO ()
infoMessage " 💡 Try using --cabal-file-path option to specify the path to the .cabal file.\n"
Map FilePath (Either ExtensionsError ParsedExtensions)
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map FilePath (Either ExtensionsError ParsedExtensions)
forall a. Monoid a => a
mempty
cabals :: [FilePath]
cabals -> [Map FilePath (Either ExtensionsError ParsedExtensions)]
-> Map FilePath (Either ExtensionsError ParsedExtensions)
forall a. Monoid a => [a] -> a
mconcat ([Map FilePath (Either ExtensionsError ParsedExtensions)]
-> Map FilePath (Either ExtensionsError ParsedExtensions))
-> IO [Map FilePath (Either ExtensionsError ParsedExtensions)]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> [FilePath]
-> IO [Map FilePath (Either ExtensionsError ParsedExtensions)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
getExtensionsWithCabal [FilePath]
cabals
cabals :: [FilePath]
cabals -> ([Map FilePath (Either ExtensionsError ParsedExtensions)]
-> Map FilePath (Either ExtensionsError ParsedExtensions))
-> IO [Map FilePath (Either ExtensionsError ParsedExtensions)]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map FilePath (Either ExtensionsError ParsedExtensions)]
-> Map FilePath (Either ExtensionsError ParsedExtensions)
forall a. Monoid a => [a] -> a
mconcat (IO [Map FilePath (Either ExtensionsError ParsedExtensions)]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> IO [Map FilePath (Either ExtensionsError ParsedExtensions)]
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall a b. (a -> b) -> a -> b
$ [FilePath]
-> (FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> IO [Map FilePath (Either ExtensionsError ParsedExtensions)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
ordNub [FilePath]
cabals) ((FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> IO [Map FilePath (Either ExtensionsError ParsedExtensions)])
-> (FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> IO [Map FilePath (Either ExtensionsError ParsedExtensions)]
forall a b. (a -> b) -> a -> b
$ \cabal :: FilePath
cabal ->
IO Bool
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (FilePath -> IO Bool
doesFileExist FilePath
cabal)
(FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
getExtensionsWithCabal FilePath
cabal)
(Text -> IO ()
errorMessage (".cabal file does not exist: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
cabal) IO ()
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (m :: * -> *) a. MonadIO m => m a
exitFailure)
where
getExtensionsWithCabal
:: FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
getExtensionsWithCabal :: FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
getExtensionsWithCabal cabal :: FilePath
cabal = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
infoMessage (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Using the following .cabal file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
cabal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"
(ParsedExtensions -> Either ExtensionsError ParsedExtensions
forall a b. b -> Either a b
Right (ParsedExtensions -> Either ExtensionsError ParsedExtensions)
-> IO (Map FilePath ParsedExtensions)
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>> FilePath -> IO (Map FilePath ParsedExtensions)
parseCabalFileExtensions FilePath
cabal)
IO (Map FilePath (Either ExtensionsError ParsedExtensions))
-> (CabalException
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` CabalException
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
handleCabalErr
where
handleCabalErr
:: CabalException
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
handleCabalErr :: CabalException
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
handleCabalErr err :: CabalException
err = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
errorMessage "Error when parsing cabal file. Stan will continue without information from .cabal file"
Map FilePath (Either ExtensionsError ParsedExtensions)
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map FilePath (Either ExtensionsError ParsedExtensions)
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions)))
-> Map FilePath (Either ExtensionsError ParsedExtensions)
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
forall a b. (a -> b) -> a -> b
$ [(FilePath, Either ExtensionsError ParsedExtensions)]
-> Map FilePath (Either ExtensionsError ParsedExtensions)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FilePath, Either ExtensionsError ParsedExtensions)]
-> Map FilePath (Either ExtensionsError ParsedExtensions))
-> [(FilePath, Either ExtensionsError ParsedExtensions)]
-> Map FilePath (Either ExtensionsError ParsedExtensions)
forall a b. (a -> b) -> a -> b
$
(HieFile -> (FilePath, Either ExtensionsError ParsedExtensions))
-> [HieFile]
-> [(FilePath, Either ExtensionsError ParsedExtensions)]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath -> Either ExtensionsError ParsedExtensions)
-> FilePath -> (FilePath, Either ExtensionsError ParsedExtensions)
forall a b. (a -> b) -> a -> (a, b)
toSnd (Either ExtensionsError ParsedExtensions
-> FilePath -> Either ExtensionsError ParsedExtensions
forall a b. a -> b -> a
const (Either ExtensionsError ParsedExtensions
-> FilePath -> Either ExtensionsError ParsedExtensions)
-> Either ExtensionsError ParsedExtensions
-> FilePath
-> Either ExtensionsError ParsedExtensions
forall a b. (a -> b) -> a -> b
$ ExtensionsError -> Either ExtensionsError ParsedExtensions
forall a b. a -> Either a b
Left (ExtensionsError -> Either ExtensionsError ParsedExtensions)
-> ExtensionsError -> Either ExtensionsError ParsedExtensions
forall a b. (a -> b) -> a -> b
$ CabalException -> ExtensionsError
CabalError CabalException
err) (FilePath -> (FilePath, Either ExtensionsError ParsedExtensions))
-> (HieFile -> FilePath)
-> HieFile
-> (FilePath, Either ExtensionsError ParsedExtensions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> FilePath
hie_hs_file) [HieFile]
hies
findCabalFiles :: IO [FilePath]
findCabalFiles :: IO [FilePath]
findCabalFiles = do
FilePath
dir <- IO FilePath
getCurrentDirectory
Maybe FilePath
curDirCabal <- FilePath -> IO (Maybe FilePath)
findCabalFileDir FilePath
dir
[FilePath]
dirs <- FilePath -> IO [FilePath]
getSubdirsRecursive FilePath
dir
[Maybe FilePath]
subDirsCabals <- (FilePath -> IO (Maybe FilePath))
-> [FilePath] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO (Maybe FilePath)
findCabalFileDir [FilePath]
dirs
[FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath]) -> [Maybe FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
curDirCabal Maybe FilePath -> [Maybe FilePath] -> [Maybe FilePath]
forall a. a -> [a] -> [a]
: [Maybe FilePath]
subDirsCabals
findCabalFileDir :: FilePath -> IO (Maybe FilePath)
findCabalFileDir :: FilePath -> IO (Maybe FilePath)
findCabalFileDir dir :: FilePath
dir = do
[FilePath]
dirContent <- FilePath -> IO [FilePath]
listDirectory FilePath
dir
let cabalFiles :: [FilePath]
cabalFiles = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isCabal [FilePath]
dirContent
Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ case [FilePath]
cabalFiles of
[] -> Maybe FilePath
forall a. Maybe a
Nothing
[cabalFile :: FilePath
cabalFile] -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
cabalFile
x :: FilePath
x:_xs :: [FilePath]
_xs -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
x
where
isCabal :: FilePath -> Bool
isCabal :: FilePath -> Bool
isCabal p :: FilePath
p = FilePath -> FilePath
takeExtension FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ".cabal"
getSubdirsRecursive :: FilePath -> IO [FilePath]
getSubdirsRecursive :: FilePath -> IO [FilePath]
getSubdirsRecursive fp :: FilePath
fp = do
[FilePath]
all' <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
nonGenDir ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
fp
[FilePath]
dirs <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesDirectoryExist (FilePath -> FilePath
mkRel (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
all')
case [FilePath]
dirs of
[] -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
ds :: [FilePath]
ds -> do
[FilePath]
next <- IO [FilePath] -> IO [FilePath]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall b (m :: * -> *) (f :: * -> *) a.
(Semigroup b, Monoid b, Applicative m, Foldable f) =>
(a -> m b) -> f a -> m b
foldMapA FilePath -> IO [FilePath]
getSubdirsRecursive [FilePath]
ds
[FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
dirs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
next
where
nonGenDir :: FilePath -> Bool
nonGenDir :: FilePath -> Bool
nonGenDir d :: FilePath
d =
FilePath
d FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "dist"
Bool -> Bool -> Bool
&& FilePath
d FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "dist-newstyle"
Bool -> Bool -> Bool
&& FilePath
d FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= ".stack-work"
mkRel :: FilePath -> FilePath
mkRel :: FilePath -> FilePath
mkRel = (FilePath
fp FilePath -> FilePath -> FilePath
</>)
mergeParsedExtensions
:: Either ExtensionsError ParsedExtensions
-> Either ExtensionsError ParsedExtensions
-> ExtensionsResult
mergeParsedExtensions :: Either ExtensionsError ParsedExtensions
-> Either ExtensionsError ParsedExtensions -> ExtensionsResult
mergeParsedExtensions (Left err :: ExtensionsError
err) _ = ExtensionsError -> ExtensionsResult
forall a b. a -> Either a b
Left ExtensionsError
err
mergeParsedExtensions _ (Left err :: ExtensionsError
err) = ExtensionsError -> ExtensionsResult
forall a b. a -> Either a b
Left ExtensionsError
err
mergeParsedExtensions (Right exts1 :: ParsedExtensions
exts1) (Right exts2 :: ParsedExtensions
exts2) = ParsedExtensions -> ParsedExtensions -> ExtensionsResult
mergeAnyExtensions ParsedExtensions
exts1 ParsedExtensions
exts2