Move package-id to wrapper

we need it before dist/setup-config exists so we can't run it as part of
the other queries anyways, might as well go in the wrapper.

4 files changed, 61 insertions, 45 deletions

diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs
index 3a6d4b6..154441e 100644
--- a/CabalHelper/Common.hs
+++ b/CabalHelper/Common.hs
@@ -86,3 +86,12 @@ runReadP p i = case filter ((=="") . snd) $ readP_to_S p i of
 
 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
index 48a6ed4..59c3e91 100644
--- a/CabalHelper/Main.hs
+++ b/CabalHelper/Main.hs
@@ -145,7 +145,6 @@ 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
@@ -180,10 +179,6 @@ 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
@@ -441,12 +436,3 @@ 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/Wrapper.hs b/CabalHelper/Wrapper.hs
index 5cd3ef8..1987e6c 100644
--- a/CabalHelper/Wrapper.hs
+++ b/CabalHelper/Wrapper.hs
@@ -35,6 +35,9 @@ import Prelude
 
 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 @@ usage = do
 \  [--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 @@ main = handlePanic $ do
     "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
index 5964d5e..4a4bfde 100644
--- a/Distribution/Helper.hs
+++ b/Distribution/Helper.hs
@@ -44,10 +44,10 @@ module Distribution.Helper (
   , ghcMergedPkgOptions
   , ghcLangOptions
   , pkgLicenses
-  , packageId
   , flags
   , configFlags
   , nonDefaultConfigFlags
+  , packageId
 
   -- * Result types
   , ChModuleName(..)
@@ -152,7 +152,6 @@ data SomeLocalBuildInfo = SomeLocalBuildInfo {
       slbiGhcMergedPkgOptions :: [String],
       slbiGhcLangOptions      :: [(ChComponentName, [String])],
       slbiPkgLicenses         :: [(String, [(String, Version)])],
-      slbiPackageId           :: (String, Version),
       slbiFlags               :: [(String, Bool)],
       slbiConfigFlags         :: [(String, Bool)],
       slbiNonDefaultConfigFlags :: [(String, Bool)]
@@ -220,9 +219,6 @@ 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)]
 
@@ -234,6 +230,10 @@ configFlags :: MonadIO m => Query m [(String, Bool)]
 -- 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
@@ -243,10 +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
+packageId           = Query $ getPackageId
 
 -- | Run @cabal configure@
 reconfigure :: MonadIO m
@@ -266,8 +266,10 @@ reconfigure readProc progs cabalOpts = do
     _ <- 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
@@ -277,29 +279,37 @@ getSomeConfigState = ask >>= \QueryEnv {..} -> do
                  , "--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"
-             , "package-id"
-             , "flags"
-             , "config-flags"
-             , "non-default-config-flags"
-             ]
-
-  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),
@@ -309,14 +319,13 @@ getSomeConfigState = ask >>= \QueryEnv {..} -> do
         Just (ChResponseList     ghcMergedPkgOpts),
         Just (ChResponseCompList ghcLangOpts),
         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 (pkgName, pkgVer) fls cfls ndcfls
+    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.