{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Ormolu.Utils.Extensions
  ( Extension (..),
    getExtensionsFromCabalFile,
    findCabalFile,
    getCabalExtensionDynOptions,
  )
where

import Control.Exception
import Control.Monad.IO.Class
import qualified Data.ByteString as B
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Maybe (maybeToList)
import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec
import qualified Distribution.Types.CondTree as CT
import Language.Haskell.Extension
import Ormolu.Config
import Ormolu.Exception
import System.Directory
import System.FilePath
import System.IO (hPutStrLn, stderr)
import System.IO.Error (isDoesNotExistError)

-- | Get a map from Haskell source file paths (without any extensions)
-- to its default language extensions
getExtensionsFromCabalFile ::
  MonadIO m =>
  -- | Path to cabal file
  FilePath ->
  m (Map FilePath [DynOption])
getExtensionsFromCabalFile :: FilePath -> m (Map FilePath [DynOption])
getExtensionsFromCabalFile FilePath
cabalFile = IO (Map FilePath [DynOption]) -> m (Map FilePath [DynOption])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map FilePath [DynOption]) -> m (Map FilePath [DynOption]))
-> IO (Map FilePath [DynOption]) -> m (Map FilePath [DynOption])
forall a b. (a -> b) -> a -> b
$ do
  GenericPackageDescription {[(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
[(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
[(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
[(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
[(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
[PackageFlag]
Maybe Version
Maybe (CondTree ConfVar [Dependency] Library)
PackageDescription
packageDescription :: GenericPackageDescription -> PackageDescription
gpdScannedVersion :: GenericPackageDescription -> Maybe Version
genPackageFlags :: GenericPackageDescription -> [PackageFlag]
condLibrary :: GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condSubLibraries :: GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condForeignLibs :: GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
condExecutables :: GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
condTestSuites :: GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condBenchmarks :: GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
condForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
condSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
genPackageFlags :: [PackageFlag]
gpdScannedVersion :: Maybe Version
packageDescription :: PackageDescription
..} <-
    ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe (ByteString -> Maybe GenericPackageDescription)
-> IO ByteString -> IO (Maybe GenericPackageDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
B.readFile FilePath
cabalFile IO (Maybe GenericPackageDescription)
-> (Maybe GenericPackageDescription
    -> IO GenericPackageDescription)
-> IO GenericPackageDescription
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just GenericPackageDescription
gpd -> GenericPackageDescription -> IO GenericPackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd
      Maybe GenericPackageDescription
Nothing -> OrmoluException -> IO GenericPackageDescription
forall e a. Exception e => e -> IO a
throwIO (OrmoluException -> IO GenericPackageDescription)
-> OrmoluException -> IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ FilePath -> OrmoluException
OrmoluCabalFileParsingFailed FilePath
cabalFile
  let lib :: [CondTree ConfVar [Dependency] Library]
lib = Maybe (CondTree ConfVar [Dependency] Library)
-> [CondTree ConfVar [Dependency] Library]
forall a. Maybe a -> [a]
maybeToList Maybe (CondTree ConfVar [Dependency] Library)
condLibrary
      sublibs :: [CondTree ConfVar [Dependency] Library]
sublibs = (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> CondTree ConfVar [Dependency] Library
forall a b. (a, b) -> b
snd ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> CondTree ConfVar [Dependency] Library)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [CondTree ConfVar [Dependency] Library]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries
  Map FilePath [DynOption] -> IO (Map FilePath [DynOption])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map FilePath [DynOption] -> IO (Map FilePath [DynOption]))
-> ([[Map FilePath [DynOption]]] -> Map FilePath [DynOption])
-> [[Map FilePath [DynOption]]]
-> IO (Map FilePath [DynOption])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Map FilePath [DynOption]] -> Map FilePath [DynOption]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ([Map FilePath [DynOption]] -> Map FilePath [DynOption])
-> ([[Map FilePath [DynOption]]] -> [Map FilePath [DynOption]])
-> [[Map FilePath [DynOption]]]
-> Map FilePath [DynOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Map FilePath [DynOption]]] -> [Map FilePath [DynOption]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Map FilePath [DynOption]]] -> IO (Map FilePath [DynOption]))
-> [[Map FilePath [DynOption]]] -> IO (Map FilePath [DynOption])
forall a b. (a -> b) -> a -> b
$
    [ (Library -> ([FilePath], [DynOption]))
-> CondTree ConfVar [Dependency] Library
-> Map FilePath [DynOption]
forall k a b a v.
(Ord k, Semigroup a, Semigroup b) =>
(a -> ([k], a)) -> CondTree v b a -> Map k a
buildMap Library -> ([FilePath], [DynOption])
extractFromLibrary (CondTree ConfVar [Dependency] Library -> Map FilePath [DynOption])
-> [CondTree ConfVar [Dependency] Library]
-> [Map FilePath [DynOption]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CondTree ConfVar [Dependency] Library]
lib [CondTree ConfVar [Dependency] Library]
-> [CondTree ConfVar [Dependency] Library]
-> [CondTree ConfVar [Dependency] Library]
forall a. [a] -> [a] -> [a]
++ [CondTree ConfVar [Dependency] Library]
sublibs,
      (Executable -> ([FilePath], [DynOption]))
-> CondTree ConfVar [Dependency] Executable
-> Map FilePath [DynOption]
forall k a b a v.
(Ord k, Semigroup a, Semigroup b) =>
(a -> ([k], a)) -> CondTree v b a -> Map k a
buildMap Executable -> ([FilePath], [DynOption])
extractFromExecutable (CondTree ConfVar [Dependency] Executable
 -> Map FilePath [DynOption])
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
    -> CondTree ConfVar [Dependency] Executable)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> Map FilePath [DynOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> CondTree ConfVar [Dependency] Executable
forall a b. (a, b) -> b
snd ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> Map FilePath [DynOption])
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [Map FilePath [DynOption]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
condExecutables,
      (TestSuite -> ([FilePath], [DynOption]))
-> CondTree ConfVar [Dependency] TestSuite
-> Map FilePath [DynOption]
forall k a b a v.
(Ord k, Semigroup a, Semigroup b) =>
(a -> ([k], a)) -> CondTree v b a -> Map k a
buildMap TestSuite -> ([FilePath], [DynOption])
extractFromTestSuite (CondTree ConfVar [Dependency] TestSuite
 -> Map FilePath [DynOption])
-> ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
    -> CondTree ConfVar [Dependency] TestSuite)
-> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> Map FilePath [DynOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> CondTree ConfVar [Dependency] TestSuite
forall a b. (a, b) -> b
snd ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> Map FilePath [DynOption])
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [Map FilePath [DynOption]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites,
      (Benchmark -> ([FilePath], [DynOption]))
-> CondTree ConfVar [Dependency] Benchmark
-> Map FilePath [DynOption]
forall k a b a v.
(Ord k, Semigroup a, Semigroup b) =>
(a -> ([k], a)) -> CondTree v b a -> Map k a
buildMap Benchmark -> ([FilePath], [DynOption])
extractFromBenchmark (CondTree ConfVar [Dependency] Benchmark
 -> Map FilePath [DynOption])
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
    -> CondTree ConfVar [Dependency] Benchmark)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> Map FilePath [DynOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> CondTree ConfVar [Dependency] Benchmark
forall a b. (a, b) -> b
snd ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> Map FilePath [DynOption])
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [Map FilePath [DynOption]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks
    ]
  where
    buildMap :: (a -> ([k], a)) -> CondTree v b a -> Map k a
buildMap a -> ([k], a)
f CondTree v b a
a = let ([k]
files, a
exts) = a -> ([k], a)
f a
mergedA in [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(k, a)] -> Map k a) -> [(k, a)] -> Map k a
forall a b. (a -> b) -> a -> b
$ (,a
exts) (k -> (k, a)) -> [k] -> [(k, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [k]
files
      where
        (a
mergedA, b
_) = CondTree v b a -> (a, b)
forall a c v.
(Semigroup a, Semigroup c) =>
CondTree v c a -> (a, c)
CT.ignoreConditions CondTree v b a
a

    extractFromBuildInfo :: [FilePath] -> BuildInfo -> ([FilePath], [DynOption])
extractFromBuildInfo [FilePath]
extraModules BuildInfo {Bool
[FilePath]
[(FilePath, FilePath)]
[Language]
[Extension]
[Dependency]
[ExeDependency]
[LegacyExeDependency]
[Mixin]
[ModuleName]
[PkgconfigDependency]
Maybe Language
PerCompilerFlavor [FilePath]
buildable :: BuildInfo -> Bool
buildTools :: BuildInfo -> [LegacyExeDependency]
buildToolDepends :: BuildInfo -> [ExeDependency]
cppOptions :: BuildInfo -> [FilePath]
asmOptions :: BuildInfo -> [FilePath]
cmmOptions :: BuildInfo -> [FilePath]
ccOptions :: BuildInfo -> [FilePath]
cxxOptions :: BuildInfo -> [FilePath]
ldOptions :: BuildInfo -> [FilePath]
pkgconfigDepends :: BuildInfo -> [PkgconfigDependency]
frameworks :: BuildInfo -> [FilePath]
extraFrameworkDirs :: BuildInfo -> [FilePath]
asmSources :: BuildInfo -> [FilePath]
cmmSources :: BuildInfo -> [FilePath]
cSources :: BuildInfo -> [FilePath]
cxxSources :: BuildInfo -> [FilePath]
jsSources :: BuildInfo -> [FilePath]
hsSourceDirs :: BuildInfo -> [FilePath]
otherModules :: BuildInfo -> [ModuleName]
virtualModules :: BuildInfo -> [ModuleName]
autogenModules :: BuildInfo -> [ModuleName]
defaultLanguage :: BuildInfo -> Maybe Language
otherLanguages :: BuildInfo -> [Language]
defaultExtensions :: BuildInfo -> [Extension]
otherExtensions :: BuildInfo -> [Extension]
oldExtensions :: BuildInfo -> [Extension]
extraLibs :: BuildInfo -> [FilePath]
extraGHCiLibs :: BuildInfo -> [FilePath]
extraBundledLibs :: BuildInfo -> [FilePath]
extraLibFlavours :: BuildInfo -> [FilePath]
extraDynLibFlavours :: BuildInfo -> [FilePath]
extraLibDirs :: BuildInfo -> [FilePath]
includeDirs :: BuildInfo -> [FilePath]
includes :: BuildInfo -> [FilePath]
autogenIncludes :: BuildInfo -> [FilePath]
installIncludes :: BuildInfo -> [FilePath]
options :: BuildInfo -> PerCompilerFlavor [FilePath]
profOptions :: BuildInfo -> PerCompilerFlavor [FilePath]
sharedOptions :: BuildInfo -> PerCompilerFlavor [FilePath]
staticOptions :: BuildInfo -> PerCompilerFlavor [FilePath]
customFieldsBI :: BuildInfo -> [(FilePath, FilePath)]
targetBuildDepends :: BuildInfo -> [Dependency]
mixins :: BuildInfo -> [Mixin]
mixins :: [Mixin]
targetBuildDepends :: [Dependency]
customFieldsBI :: [(FilePath, FilePath)]
staticOptions :: PerCompilerFlavor [FilePath]
sharedOptions :: PerCompilerFlavor [FilePath]
profOptions :: PerCompilerFlavor [FilePath]
options :: PerCompilerFlavor [FilePath]
installIncludes :: [FilePath]
autogenIncludes :: [FilePath]
includes :: [FilePath]
includeDirs :: [FilePath]
extraLibDirs :: [FilePath]
extraDynLibFlavours :: [FilePath]
extraLibFlavours :: [FilePath]
extraBundledLibs :: [FilePath]
extraGHCiLibs :: [FilePath]
extraLibs :: [FilePath]
oldExtensions :: [Extension]
otherExtensions :: [Extension]
defaultExtensions :: [Extension]
otherLanguages :: [Language]
defaultLanguage :: Maybe Language
autogenModules :: [ModuleName]
virtualModules :: [ModuleName]
otherModules :: [ModuleName]
hsSourceDirs :: [FilePath]
jsSources :: [FilePath]
cxxSources :: [FilePath]
cSources :: [FilePath]
cmmSources :: [FilePath]
asmSources :: [FilePath]
extraFrameworkDirs :: [FilePath]
frameworks :: [FilePath]
pkgconfigDepends :: [PkgconfigDependency]
ldOptions :: [FilePath]
cxxOptions :: [FilePath]
ccOptions :: [FilePath]
cmmOptions :: [FilePath]
asmOptions :: [FilePath]
cppOptions :: [FilePath]
buildToolDepends :: [ExeDependency]
buildTools :: [LegacyExeDependency]
buildable :: Bool
..} = (,[DynOption]
exts) ([FilePath] -> ([FilePath], [DynOption]))
-> [FilePath] -> ([FilePath], [DynOption])
forall a b. (a -> b) -> a -> b
$ do
      FilePath
m <- [FilePath]
extraModules [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (ModuleName -> FilePath
ModuleName.toFilePath (ModuleName -> FilePath) -> [ModuleName] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
otherModules)
      (FilePath -> FilePath
takeDirectory FilePath
cabalFile FilePath -> FilePath -> FilePath
</>) (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath]
prependSrcDirs (FilePath -> FilePath
dropExtensions FilePath
m)
      where
        prependSrcDirs :: FilePath -> [FilePath]
prependSrcDirs FilePath
f
          | [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
hsSourceDirs = [FilePath
f]
          | Bool
otherwise = (FilePath -> FilePath -> FilePath
</> FilePath
f) (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
hsSourceDirs
        exts :: [DynOption]
exts = [DynOption]
-> (Language -> [DynOption]) -> Maybe Language -> [DynOption]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Language -> [DynOption]
langExt Maybe Language
defaultLanguage [DynOption] -> [DynOption] -> [DynOption]
forall a. [a] -> [a] -> [a]
++ (Extension -> DynOption) -> [Extension] -> [DynOption]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> DynOption
extToDynOption [Extension]
defaultExtensions
        langExt :: Language -> [DynOption]
langExt =
          DynOption -> [DynOption]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynOption -> [DynOption])
-> (Language -> DynOption) -> Language -> [DynOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> DynOption
DynOption (FilePath -> DynOption)
-> (Language -> FilePath) -> Language -> DynOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
            Language
Haskell98 -> FilePath
"-XHaskell98"
            Language
Haskell2010 -> FilePath
"-XHaskell2010"
            UnknownLanguage FilePath
lan -> FilePath
"-X" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
lan
        extToDynOption :: Extension -> DynOption
extToDynOption =
          FilePath -> DynOption
DynOption (FilePath -> DynOption)
-> (Extension -> FilePath) -> Extension -> DynOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
            EnableExtension KnownExtension
e -> FilePath
"-X" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ KnownExtension -> FilePath
forall a. Show a => a -> FilePath
show KnownExtension
e
            DisableExtension KnownExtension
e -> FilePath
"-XNo" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ KnownExtension -> FilePath
forall a. Show a => a -> FilePath
show KnownExtension
e
            UnknownExtension FilePath
e -> FilePath
"-X" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
e

    extractFromLibrary :: Library -> ([FilePath], [DynOption])
extractFromLibrary Library {Bool
[ModuleReexport]
[ModuleName]
BuildInfo
LibraryName
LibraryVisibility
libName :: Library -> LibraryName
exposedModules :: Library -> [ModuleName]
reexportedModules :: Library -> [ModuleReexport]
signatures :: Library -> [ModuleName]
libExposed :: Library -> Bool
libVisibility :: Library -> LibraryVisibility
libBuildInfo :: Library -> BuildInfo
libBuildInfo :: BuildInfo
libVisibility :: LibraryVisibility
libExposed :: Bool
signatures :: [ModuleName]
reexportedModules :: [ModuleReexport]
exposedModules :: [ModuleName]
libName :: LibraryName
..} =
      [FilePath] -> BuildInfo -> ([FilePath], [DynOption])
extractFromBuildInfo (ModuleName -> FilePath
ModuleName.toFilePath (ModuleName -> FilePath) -> [ModuleName] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
exposedModules) BuildInfo
libBuildInfo
    extractFromExecutable :: Executable -> ([FilePath], [DynOption])
extractFromExecutable Executable {FilePath
BuildInfo
ExecutableScope
UnqualComponentName
exeName :: Executable -> UnqualComponentName
modulePath :: Executable -> FilePath
exeScope :: Executable -> ExecutableScope
buildInfo :: Executable -> BuildInfo
buildInfo :: BuildInfo
exeScope :: ExecutableScope
modulePath :: FilePath
exeName :: UnqualComponentName
..} =
      [FilePath] -> BuildInfo -> ([FilePath], [DynOption])
extractFromBuildInfo [FilePath
modulePath] BuildInfo
buildInfo
    extractFromTestSuite :: TestSuite -> ([FilePath], [DynOption])
extractFromTestSuite TestSuite {BuildInfo
TestSuiteInterface
UnqualComponentName
testName :: TestSuite -> UnqualComponentName
testInterface :: TestSuite -> TestSuiteInterface
testBuildInfo :: TestSuite -> BuildInfo
testBuildInfo :: BuildInfo
testInterface :: TestSuiteInterface
testName :: UnqualComponentName
..} =
      [FilePath] -> BuildInfo -> ([FilePath], [DynOption])
extractFromBuildInfo [FilePath]
mainPath BuildInfo
testBuildInfo
      where
        mainPath :: [FilePath]
mainPath = case TestSuiteInterface
testInterface of
          TestSuiteExeV10 Version
_ FilePath
p -> [FilePath
p]
          TestSuiteLibV09 Version
_ ModuleName
p -> [ModuleName -> FilePath
ModuleName.toFilePath ModuleName
p]
          TestSuiteUnsupported {} -> []
    extractFromBenchmark :: Benchmark -> ([FilePath], [DynOption])
extractFromBenchmark Benchmark {BuildInfo
BenchmarkInterface
UnqualComponentName
benchmarkName :: Benchmark -> UnqualComponentName
benchmarkInterface :: Benchmark -> BenchmarkInterface
benchmarkBuildInfo :: Benchmark -> BuildInfo
benchmarkBuildInfo :: BuildInfo
benchmarkInterface :: BenchmarkInterface
benchmarkName :: UnqualComponentName
..} =
      [FilePath] -> BuildInfo -> ([FilePath], [DynOption])
extractFromBuildInfo [FilePath]
mainPath BuildInfo
benchmarkBuildInfo
      where
        mainPath :: [FilePath]
mainPath = case BenchmarkInterface
benchmarkInterface of
          BenchmarkExeV10 Version
_ FilePath
p -> [FilePath
p]
          BenchmarkUnsupported {} -> []

-- | Find the path to an appropriate .cabal file for a Haskell
-- source file, if available
findCabalFile ::
  MonadIO m =>
  -- | Absolute path to a Haskell source file in a project with a .cabal file
  FilePath ->
  m (Maybe FilePath)
findCabalFile :: FilePath -> m (Maybe FilePath)
findCabalFile FilePath
p = IO (Maybe FilePath) -> m (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> m (Maybe FilePath))
-> IO (Maybe FilePath) -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ do
  let parentDir :: FilePath
parentDir = FilePath -> FilePath
takeDirectory FilePath
p
  [FilePath]
dirEntries <-
    FilePath -> IO [FilePath]
listDirectory FilePath
parentDir IO [FilePath] -> (IOError -> IO [FilePath]) -> IO [FilePath]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \case
      (IOError -> Bool
isDoesNotExistError -> Bool
True) -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      IOError
e -> IOError -> IO [FilePath]
forall e a. Exception e => e -> IO a
throwIO IOError
e
  let findDotCabal :: [FilePath] -> IO (Maybe FilePath)
findDotCabal = \case
        [] -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
        FilePath
e : [FilePath]
es
          | FilePath -> FilePath
takeExtension FilePath
e FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal" ->
            FilePath -> IO Bool
doesFileExist (FilePath
parentDir FilePath -> FilePath -> FilePath
</> FilePath
e) IO Bool -> (Bool -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Bool
True -> 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
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
e
              Bool
False -> [FilePath] -> IO (Maybe FilePath)
findDotCabal [FilePath]
es
        FilePath
_ : [FilePath]
es -> [FilePath] -> IO (Maybe FilePath)
findDotCabal [FilePath]
es
  [FilePath] -> IO (Maybe FilePath)
findDotCabal [FilePath]
dirEntries IO (Maybe FilePath)
-> (Maybe FilePath -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just FilePath
cabalFile -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> (FilePath -> Maybe FilePath) -> FilePath -> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> IO (Maybe FilePath))
-> FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
parentDir FilePath -> FilePath -> FilePath
</> FilePath
cabalFile
    Maybe FilePath
Nothing ->
      if FilePath -> Bool
isDrive FilePath
parentDir
        then Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
        else FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
findCabalFile FilePath
parentDir

-- | Get the default language extensions of a Haskell source file.
-- The .cabal file can be provided explicitly or auto-detected.
getCabalExtensionDynOptions ::
  MonadIO m =>
  -- | Haskell source file
  FilePath ->
  m [DynOption]
getCabalExtensionDynOptions :: FilePath -> m [DynOption]
getCabalExtensionDynOptions FilePath
sourceFile' = IO [DynOption] -> m [DynOption]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [DynOption] -> m [DynOption])
-> IO [DynOption] -> m [DynOption]
forall a b. (a -> b) -> a -> b
$ do
  FilePath
sourceFile <- FilePath -> IO FilePath
makeAbsolute FilePath
sourceFile'
  FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
findCabalFile FilePath
sourceFile IO (Maybe FilePath)
-> (Maybe FilePath -> IO [DynOption]) -> IO [DynOption]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just FilePath
cabalFile -> do
      Map FilePath [DynOption]
extsByFile <- FilePath -> IO (Map FilePath [DynOption])
forall (m :: * -> *).
MonadIO m =>
FilePath -> m (Map FilePath [DynOption])
getExtensionsFromCabalFile FilePath
cabalFile
      case FilePath -> Map FilePath [DynOption] -> Maybe [DynOption]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (FilePath -> FilePath
dropExtensions FilePath
sourceFile) Map FilePath [DynOption]
extsByFile of
        Just [DynOption]
exts -> [DynOption] -> IO [DynOption]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DynOption]
exts
        Maybe [DynOption]
Nothing -> do
          FilePath
relativeCabalFile <- FilePath -> IO FilePath
makeRelativeToCurrentDirectory FilePath
cabalFile
          FilePath -> IO [DynOption]
forall a. FilePath -> IO [a]
note (FilePath -> IO [DynOption]) -> FilePath -> IO [DynOption]
forall a b. (a -> b) -> a -> b
$
            FilePath
"Found .cabal file "
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
relativeCabalFile
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
", but it did not mention "
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
sourceFile'
    Maybe FilePath
Nothing -> FilePath -> IO [DynOption]
forall a. FilePath -> IO [a]
note (FilePath -> IO [DynOption]) -> FilePath -> IO [DynOption]
forall a b. (a -> b) -> a -> b
$ FilePath
"Could not find a .cabal file for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
sourceFile'
  where
    note :: FilePath -> IO [a]
note FilePath
msg = [] [a] -> IO () -> IO [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
msg