Add support for querying flags

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.