--------------------------------------------------------------------------------
module Language.Haskell.Stylish.Config.Cabal
    ( findLanguageExtensions
    ) where


--------------------------------------------------------------------------------
import           Control.Monad                            (unless)
import qualified Data.ByteString.Char8                    as BS
import           Data.Either                              (isRight)
import           Data.Foldable                            (traverse_)
import           Data.List                                (nub)
import           Data.Maybe                               (maybeToList)
import qualified Distribution.PackageDescription          as Cabal
import qualified Distribution.PackageDescription.Parsec   as Cabal
import qualified Distribution.Parsec                      as Cabal
import qualified Distribution.Simple.Utils                as Cabal
import qualified Distribution.Verbosity                   as Cabal
import qualified Language.Haskell.Extension               as Language
import           Language.Haskell.Stylish.Verbose
import           System.Directory                         (doesFileExist,
                                                           getCurrentDirectory)


--------------------------------------------------------------------------------
import           Language.Haskell.Stylish.Config.Internal
import GHC.Data.Maybe (mapMaybe)


--------------------------------------------------------------------------------
findLanguageExtensions :: Verbose -> IO [(Language.KnownExtension, Bool)]
findLanguageExtensions :: Verbose -> IO [(KnownExtension, Bool)]
findLanguageExtensions Verbose
verbose =
    Verbose -> IO (Maybe String)
findCabalFile Verbose
verbose forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Verbose -> String -> IO [(KnownExtension, Bool)]
readDefaultLanguageExtensions Verbose
verbose)


--------------------------------------------------------------------------------
-- | Find the closest .cabal file, possibly going up the directory structure.
findCabalFile :: Verbose -> IO (Maybe FilePath)
findCabalFile :: Verbose -> IO (Maybe String)
findCabalFile Verbose
verbose = do
  [String]
potentialProjectRoots <- String -> [String]
ancestors forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getCurrentDirectory
  [Either String String]
potentialCabalFile <- forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. Either a b -> Bool
isRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO (Either String String)
Cabal.findPackageDesc [String]
potentialProjectRoots
  case [Either String String]
potentialCabalFile of
    [Right String
cabalFile] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
cabalFile)
    [Either String String]
_ -> do
      Verbose
verbose forall a b. (a -> b) -> a -> b
$ String
".cabal file not found, directories searched: " forall a. Semigroup a => a -> a -> a
<>
        forall a. Show a => a -> String
show [String]
potentialProjectRoots
      Verbose
verbose forall a b. (a -> b) -> a -> b
$ String
"Stylish Haskell will work basing on LANGUAGE pragmas in source files."
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
-- | Extract @default-extensions@ fields from a @.cabal@ file
readDefaultLanguageExtensions :: Verbose -> FilePath -> IO [(Language.KnownExtension, Bool)]
readDefaultLanguageExtensions :: Verbose -> String -> IO [(KnownExtension, Bool)]
readDefaultLanguageExtensions Verbose
verbose String
cabalFile = do
  Verbose
verbose forall a b. (a -> b) -> a -> b
$ String
"Parsing " forall a. Semigroup a => a -> a -> a
<> String
cabalFile forall a. Semigroup a => a -> a -> a
<> String
"..."
  GenericPackageDescription
packageDescription <- Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
Cabal.silent String
cabalFile
  let library :: [Cabal.Library]
      library :: [Library]
library = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c v.
(Semigroup a, Semigroup c) =>
CondTree v c a -> (a, c)
Cabal.ignoreConditions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
Cabal.condLibrary GenericPackageDescription
packageDescription

      subLibraries :: [Cabal.Library]
      subLibraries :: [Library]
subLibraries = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c v.
(Semigroup a, Semigroup c) =>
CondTree v c a -> (a, c)
Cabal.ignoreConditions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
Cabal.condSubLibraries GenericPackageDescription
packageDescription

      executables :: [Cabal.Executable]
      executables :: [Executable]
executables = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c v.
(Semigroup a, Semigroup c) =>
CondTree v c a -> (a, c)
Cabal.ignoreConditions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
Cabal.condExecutables GenericPackageDescription
packageDescription

      testSuites :: [Cabal.TestSuite]
      testSuites :: [TestSuite]
testSuites = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c v.
(Semigroup a, Semigroup c) =>
CondTree v c a -> (a, c)
Cabal.ignoreConditions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
Cabal.condTestSuites GenericPackageDescription
packageDescription

      benchmarks :: [Cabal.Benchmark]
      benchmarks :: [Benchmark]
benchmarks = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c v.
(Semigroup a, Semigroup c) =>
CondTree v c a -> (a, c)
Cabal.ignoreConditions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
Cabal.condBenchmarks GenericPackageDescription
packageDescription

      gatherBuildInfos :: [Cabal.BuildInfo]
      gatherBuildInfos :: [BuildInfo]
gatherBuildInfos = forall a b. (a -> b) -> [a] -> [b]
map Library -> BuildInfo
Cabal.libBuildInfo [Library]
library forall a. Semigroup a => a -> a -> a
<>
                         forall a b. (a -> b) -> [a] -> [b]
map Library -> BuildInfo
Cabal.libBuildInfo [Library]
subLibraries forall a. Semigroup a => a -> a -> a
<>
                         forall a b. (a -> b) -> [a] -> [b]
map Executable -> BuildInfo
Cabal.buildInfo [Executable]
executables forall a. Semigroup a => a -> a -> a
<>
                         forall a b. (a -> b) -> [a] -> [b]
map TestSuite -> BuildInfo
Cabal.testBuildInfo [TestSuite]
testSuites forall a. Semigroup a => a -> a -> a
<>
                         forall a b. (a -> b) -> [a] -> [b]
map Benchmark -> BuildInfo
Cabal.benchmarkBuildInfo [Benchmark]
benchmarks

      defaultExtensions :: [(Language.KnownExtension, Bool)]
      defaultExtensions :: [(KnownExtension, Bool)]
defaultExtensions = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Extension -> Maybe (KnownExtension, Bool)
toPair forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BuildInfo -> [Extension]
Cabal.defaultExtensions [BuildInfo]
gatherBuildInfos
        where toPair :: Extension -> Maybe (KnownExtension, Bool)
toPair (Language.EnableExtension KnownExtension
x)  = forall a. a -> Maybe a
Just (KnownExtension
x, Bool
True)
              toPair (Language.DisableExtension KnownExtension
x) = forall a. a -> Maybe a
Just (KnownExtension
x, Bool
False)
              toPair Extension
_                             = forall a. Maybe a
Nothing
  Verbose
verbose forall a b. (a -> b) -> a -> b
$ String
"Gathered default-extensions: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [(KnownExtension, Bool)]
defaultExtensions
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [(KnownExtension, Bool)]
defaultExtensions

readGenericPackageDescription :: Cabal.Verbosity -> FilePath -> IO Cabal.GenericPackageDescription
readGenericPackageDescription :: Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription = forall {b}.
(ByteString -> ParseResult b) -> Verbosity -> String -> IO b
readAndParseFile ByteString -> ParseResult GenericPackageDescription
Cabal.parseGenericPackageDescription
  where
    readAndParseFile :: (ByteString -> ParseResult b) -> Verbosity -> String -> IO b
readAndParseFile ByteString -> ParseResult b
parser Verbosity
verbosity String
fpath = do
      Bool
exists <- String -> IO Bool
doesFileExist String
fpath
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$
        forall a. Verbosity -> String -> IO a
Cabal.die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
          String
"Error Parsing: file \"" forall a. [a] -> [a] -> [a]
++ String
fpath forall a. [a] -> [a] -> [a]
++ String
"\" doesn't exist. Cannot continue."
      ByteString
bs <- String -> IO ByteString
BS.readFile String
fpath
      forall {p} {b}.
(p -> ParseResult b) -> Verbosity -> String -> p -> IO b
parseString ByteString -> ParseResult b
parser Verbosity
verbosity String
fpath ByteString
bs

    parseString :: (p -> ParseResult b) -> Verbosity -> String -> p -> IO b
parseString p -> ParseResult b
parser Verbosity
verbosity String
name p
bs = do
      let ([PWarning]
warnings, Either (Maybe Version, NonEmpty PError) b
result) = forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
Cabal.runParseResult (p -> ParseResult b
parser p
bs)
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> Verbose
Cabal.warn Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PWarning -> String
Cabal.showPWarning String
name) [PWarning]
warnings
      case Either (Maybe Version, NonEmpty PError) b
result of
          Right b
x -> forall (m :: * -> *) a. Monad m => a -> m a
return b
x
          Left (Maybe Version
_, NonEmpty PError
errors) -> do
              forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> Verbose
Cabal.warn Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PError -> String
Cabal.showPError String
name) NonEmpty PError
errors
              forall a. Verbosity -> String -> IO a
Cabal.die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Failed parsing \"" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"\"."