diff options
| -rw-r--r-- | CabalHelper/Main.hs | 55 | ||||
| -rw-r--r-- | CabalHelper/Types.hs | 5 | ||||
| -rw-r--r-- | Distribution/Helper.hs | 39 |
3 files changed, 93 insertions, 6 deletions
diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs index 9dca50d..48a6ed4 100644 --- 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 @@ import Distribution.Utils.NubList #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 @@ usage = do ++"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 @@ usage = do commands :: [String] commands = [ "print-bli" + , "package-id" + , "flags" + , "config-flags" + , "non-default-config-flags" , "write-autogen-files" , "compiler-version" , "ghc-options" @@ -131,8 +145,12 @@ main = do errMsg $ "distdir '"++distdir++"' does not exist" exitFailure + -- ghc-mod will catch multiple cabal files existing before we get here + [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 +180,30 @@ main = do print =<< flip mapM cmds $$ \cmd -> do case cmd of + "package-id":[] -> + return $ Just $ + ChResponseVersion (display (packageName pd)) (packageVersion pd) + + "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 +298,8 @@ main = do _ -> errMsg "Invalid usage!" >> usage >> exitFailure +flagName' = unFlagName' . flagName +unFlagName' (FlagName n) = n getLibrary :: PackageDescription -> Library getLibrary pd = unsafePerformIO $ do @@ -397,3 +441,12 @@ renderGhcOptions' lbi v opts = do #else return $ renderGhcOptions (compiler lbi) opts #endif + +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/Types.hs b/CabalHelper/Types.hs index c5282d7..6b2ac70 100644 --- a/CabalHelper/Types.hs +++ b/CabalHelper/Types.hs @@ -35,9 +35,10 @@ data ChResponse | 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/Distribution/Helper.hs b/Distribution/Helper.hs index d2093ca..279ef42 100644 --- a/Distribution/Helper.hs +++ b/Distribution/Helper.hs @@ -44,6 +44,10 @@ module Distribution.Helper ( , ghcMergedPkgOptions , ghcLangOptions , pkgLicenses + , packageId + , flags + , configFlags + , nonDefaultConfigFlags -- * Result types , ChModuleName(..) @@ -147,7 +151,11 @@ data SomeLocalBuildInfo = SomeLocalBuildInfo { slbiGhcPkgOptions :: [(ChComponentName, [String])], slbiGhcMergedPkgOptions :: [String], slbiGhcLangOptions :: [(ChComponentName, [String])], - slbiPkgLicenses :: [(String, [(String, Version)])] + slbiPkgLicenses :: [(String, [(String, Version)])], + slbiPackageId :: (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 +220,20 @@ ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])] -- | Get the licenses of the packages the current project is linking against. pkgLicenses :: MonadIO m => Query m [(String, [(String, Version)])] +-- | Package identifier, i.e. package name and version +packageId :: MonadIO m => Query m (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)] + packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi entrypoints = Query $ slbiEntrypoints `liftM` getSlbi sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi @@ -221,6 +243,10 @@ ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi pkgLicenses = Query $ slbiPkgLicenses `liftM` getSlbi +packageId = Query $ slbiPackageId `liftM` getSlbi +flags = Query $ slbiFlags `liftM` getSlbi +configFlags = Query $ slbiConfigFlags `liftM` getSlbi +nonDefaultConfigFlags = Query $ slbiNonDefaultConfigFlags `liftM` getSlbi -- | Run @cabal configure@ reconfigure :: MonadIO m @@ -260,6 +286,9 @@ getSomeConfigState = ask >>= \QueryEnv {..} -> do , "ghc-merged-pkg-options" , "ghc-lang-options" , "licenses" + , "flags" + , "config-flags" + , "non-default-config-flags" ] res <- liftIO $ do @@ -278,11 +307,15 @@ getSomeConfigState = ask >>= \QueryEnv {..} -> do Just (ChResponseCompList ghcPkgOpts), Just (ChResponseList ghcMergedPkgOpts), Just (ChResponseCompList ghcLangOpts), - Just (ChResponseLicenses pkgLics) + Just (ChResponseLicenses pkgLics), + Just (ChResponseVersion pkgName pkgVer), + 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 (pkgName, pkgVer) fls cfls ndcfls -- | Make sure the appropriate helper executable for the given project is -- installed and ready to run queries. |