{- |
Copyright: (c) 2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Functions to work with cabal files and cabal extension maps.
-}

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


{- | Gets the list of @.cabal@ file paths that were used in the project.
-}
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

{- | From a given path to cabal files and 'HieFile's create the map from modules
(that are in .cabal file) to the resulting parsed extensions for each.
-}
createCabalExtensionsMap
    :: Bool  -- ^ Do print into terminal?
    -> [FilePath]  -- ^ @.cabal@ files
    -> [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
    -- if cabal files are not specified via CLI option
    -- try to find cabal files in current directory
    [] -> 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
        -- if cabal file is not found, pass the empty map instead
        [] -> 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
        -- else concat map for each @.cabal@ file.
        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
    -- if cabal file specified via CLI option
    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)
        {- then -} (FilePath
-> IO (Map FilePath (Either ExtensionsError ParsedExtensions))
getExtensionsWithCabal FilePath
cabal)
        {- else -} (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

{- | Recursively find all @.cabal@ files in the current directory and its
subdirectories. It returns maximum 1 @.cabal@ file from each directory.
-}
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

-- | Find a @.cabal@ file in the given directory.
-- TODO: better error handling in stan.
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 -- throwError $ NoCabalFile dirPath
        [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 -- throwError $ MultipleCabalFiles (x :| xs)
  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
            -- unsafeInterleaveIO is required here for performance reasons
            [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