diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs --- a/CabalHelper/Common.hs +++ b/CabalHelper/Common.hs @@ -86,3 +86,12 @@ appDataDir :: IO FilePath appDataDir = ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" + +isCabalFile :: FilePath -> Bool +isCabalFile f = takeExtension' f == ".cabal" + +takeExtension' :: FilePath -> String +takeExtension' p = + if takeFileName p == takeExtension p + then "" -- just ".cabal" is not a valid cabal file + else takeExtension p diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -19,8 +19,12 @@ import Distribution.Simple.Utils (cabalVersion) import Distribution.Simple.Configure -import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId) +import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId, + packageName, packageVersion) import Distribution.PackageDescription (PackageDescription, + GenericPackageDescription(..), + Flag(..), + FlagName(..), FlagAssignment, Executable(..), Library(..), @@ -65,9 +69,11 @@ #endif import Control.Applicative ((<$>)) +import Control.Arrow (first, (&&&)) import Control.Monad import Control.Exception (catch, PatternMatchFail(..)) import Data.List +import qualified Data.Map as Map import Data.Maybe import Data.Monoid import Data.IORef @@ -92,6 +98,10 @@ ++"PROJ_DIR DIST_DIR [--with-* ...] (\n" ++" version\n" ++" | print-lbi [--human]\n" + ++" | package-id\n" + ++" | flags\n" + ++" | config-flags\n" + ++" | non-default-config-flags\n" ++" | write-autogen-files\n" ++" | compiler-version\n" ++" | ghc-options [--with-inplace]\n" @@ -107,6 +117,10 @@ commands :: [String] commands = [ "print-bli" + , "package-id" + , "flags" + , "config-flags" + , "non-default-config-flags" , "write-autogen-files" , "compiler-version" , "ghc-options" @@ -131,8 +145,11 @@ errMsg $ "distdir '"++distdir++"' does not exist" exitFailure + [cfile] <- filter isCabalFile <$> getDirectoryContents projdir + v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir + gpd <- unsafeInterleaveIO $ readPackageDescription v (projdir cfile) let pd = localPkgDescr lbi let lvd = (lbi, v, distdir) @@ -162,6 +179,26 @@ print =<< flip mapM cmds $$ \cmd -> do case cmd of + "flags":[] -> do + return $ Just $ ChResponseFlags $ sort $ + map (flagName' &&& flagDefault) $ genPackageFlags gpd + + "config-flags":[] -> do + return $ Just $ ChResponseFlags $ sort $ + map (first unFlagName') $ configConfigurationsFlags $ configFlags lbi + + "non-default-config-flags":[] -> do + let flagDefinitons = genPackageFlags gpd + flagAssgnments = configConfigurationsFlags $ configFlags lbi + nonDefaultFlags = + [ (fn, v) + | MkFlag {flagName=FlagName fn, flagDefault=dv} <- flagDefinitons + , (FlagName fn', v) <- flagAssgnments + , fn == fn' + , v /= dv + ] + return $ Just $ ChResponseFlags $ sort nonDefaultFlags + "write-autogen-files":[] -> do -- calls writeAutogenFiles initialBuildSteps distdir pd lbi v @@ -256,6 +293,8 @@ _ -> errMsg "Invalid usage!" >> usage >> exitFailure +flagName' = unFlagName' . flagName +unFlagName' (FlagName n) = n getLibrary :: PackageDescription -> Library getLibrary pd = unsafePerformIO $ do diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs --- a/CabalHelper/Types.hs +++ b/CabalHelper/Types.hs @@ -35,9 +35,10 @@ | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)] | ChResponseList [String] | ChResponsePkgDbs [ChPkgDb] - | ChResponseLbi String - | ChResponseVersion String Version + | ChResponseLbi String + | ChResponseVersion String Version | ChResponseLicenses [(String, [(String, Version)])] + | ChResponseFlags [(String, Bool)] deriving (Eq, Ord, Read, Show, Generic) data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -35,6 +35,9 @@ import Distribution.System (buildPlatform) import Distribution.Text (display) +import Distribution.Verbosity (silent, deafening) +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Package (packageName, packageVersion) import Paths_cabal_helper (version) import CabalHelper.Common @@ -56,7 +59,7 @@ \ [--with-cabal=CABAL_PATH]\n\ \ [--with-cabal-version=VERSION]\n\ \ [--with-cabal-pkg-db=PKG_DB]\n\ -\ PROJ_DIR DIST_DIR ( print-exe | [CABAL_HELPER_ARGS...] ) )\n" +\ PROJ_DIR DIST_DIR ( print-exe | package-id | [CABAL_HELPER_ARGS...] ) )\n" globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec = @@ -116,6 +119,15 @@ "version":[] -> putStrLn $ showVersion version "print-appdatadir":[] -> putStrLn =<< appDataDir "print-build-platform":[] -> putStrLn $ display buildPlatform + + projdir:_distdir:"package-id":[] -> do + v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment + -- ghc-mod will catch multiple cabal files existing before we get here + [cfile] <- filter isCabalFile <$> getDirectoryContents projdir + gpd <- readPackageDescription v (projdir cfile) + putStrLn $ show $ + [Just $ ChResponseVersion (display (packageName gpd)) (packageVersion gpd)] + projdir:distdir:args' -> do cfgf <- canonicalizePath (distdir "setup-config") mhdr <- getCabalConfigHeader cfgf diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs --- a/Distribution/Helper.hs +++ b/Distribution/Helper.hs @@ -44,6 +44,10 @@ , ghcMergedPkgOptions , ghcLangOptions , pkgLicenses + , flags + , configFlags + , nonDefaultConfigFlags + , packageId -- * Result types , ChModuleName(..) @@ -147,7 +151,10 @@ slbiGhcPkgOptions :: [(ChComponentName, [String])], slbiGhcMergedPkgOptions :: [String], slbiGhcLangOptions :: [(ChComponentName, [String])], - slbiPkgLicenses :: [(String, [(String, Version)])] + slbiPkgLicenses :: [(String, [(String, Version)])], + slbiFlags :: [(String, Bool)], + slbiConfigFlags :: [(String, Bool)], + slbiNonDefaultConfigFlags :: [(String, Bool)] } deriving (Eq, Ord, Read, Show) -- | Caches helper executable result so it doesn't have to be run more than once @@ -212,6 +219,21 @@ -- | Get the licenses of the packages the current project is linking against. pkgLicenses :: MonadIO m => Query m [(String, [(String, Version)])] +-- | Flag definitions from cabal file +flags :: MonadIO m => Query m [(String, Bool)] + +-- | Flag assignments from setup-config +configFlags :: MonadIO m => Query m [(String, Bool)] + +-- | Flag assignments from setup-config which differ from the default +-- setting. This can also include flags which cabal decided to modify, +-- i.e. don't rely on these being the flags set by the user directly. +nonDefaultConfigFlags :: MonadIO m => Query m [(String, Bool)] + +-- | Package identifier, i.e. package name and version +packageId :: MonadIO m => Query m (String, Version) + + packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi entrypoints = Query $ slbiEntrypoints `liftM` getSlbi sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi @@ -221,6 +243,10 @@ ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi pkgLicenses = Query $ slbiPkgLicenses `liftM` getSlbi +flags = Query $ slbiFlags `liftM` getSlbi +configFlags = Query $ slbiConfigFlags `liftM` getSlbi +nonDefaultConfigFlags = Query $ slbiNonDefaultConfigFlags `liftM` getSlbi +packageId = Query $ getPackageId -- | Run @cabal configure@ reconfigure :: MonadIO m @@ -240,8 +266,10 @@ _ <- liftIO $ readProc (cabalProgram progs) ("configure":progOpts) "" return () -getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo -getSomeConfigState = ask >>= \QueryEnv {..} -> do + + +invokeHelper :: MonadQuery m => [String] -> m [Maybe ChResponse] +invokeHelper args = ask >>= \QueryEnv {..} -> do let progs = qePrograms projdir = qeProjectDir distdir = qeDistDir @@ -251,25 +279,37 @@ , "--with-cabal=" ++ cabalProgram progs ] - args = [ "package-db-stack" - , "entrypoints" - , "source-dirs" - , "ghc-options" - , "ghc-src-options" - , "ghc-pkg-options" - , "ghc-merged-pkg-options" - , "ghc-lang-options" - , "licenses" - ] - - res <- liftIO $ do + liftIO $ do exe <- findLibexecExe "cabal-helper-wrapper" - out <- qeReadProcess exe (progArgs ++ projdir:distdir:args) "" + let args' = progArgs ++ projdir:distdir:args + out <- qeReadProcess exe args' "" evaluate (read out) `E.catch` \(SomeException _) -> - error $ concat ["getSomeConfigState", ": ", exe, " " - , intercalate " " (map show $ progArgs ++ projdir:distdir:args) - , " (read failed)"] + error $ concat ["invokeHelper", ": ", exe, " " + , intercalate " " (map show args') + , " (read failed)" + ] +getPackageId :: MonadQuery m => m (String, Version) +getPackageId = ask >>= \QueryEnv {..} -> do + [ Just (ChResponseVersion pkgName pkgVer) ] <- invokeHelper [ "package-id" ] + return (pkgName, pkgVer) + + +getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo +getSomeConfigState = ask >>= \QueryEnv {..} -> do + res <- invokeHelper [ "package-db-stack" + , "entrypoints" + , "source-dirs" + , "ghc-options" + , "ghc-src-options" + , "ghc-pkg-options" + , "ghc-merged-pkg-options" + , "ghc-lang-options" + , "licenses" + , "flags" + , "config-flags" + , "non-default-config-flags" + ] let [ Just (ChResponsePkgDbs pkgDbs), Just (ChResponseEntrypoints eps), Just (ChResponseCompList srcDirs), @@ -278,11 +318,14 @@ Just (ChResponseCompList ghcPkgOpts), Just (ChResponseList ghcMergedPkgOpts), Just (ChResponseCompList ghcLangOpts), - Just (ChResponseLicenses pkgLics) + Just (ChResponseLicenses pkgLics), + Just (ChResponseFlags fls), + Just (ChResponseFlags cfls), + Just (ChResponseFlags ndcfls) ] = res return $ SomeLocalBuildInfo - pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts pkgLics + pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts pkgLics fls cfls ndcfls -- | Make sure the appropriate helper executable for the given project is -- installed and ready to run queries. diff --git a/cabal-helper.cabal b/cabal-helper.cabal --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -1,5 +1,5 @@ name: cabal-helper -version: 0.6.0.0 +version: 0.6.1.0 synopsis: Simple interface to some of Cabal's configuration state used by ghc-mod description: @cabal-helper@ provides a library which wraps the internal use of