Add language options query

3 files changed, 41 insertions, 13 deletions

diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs
index 2e8ff6a..025380f 100644
--- a/CabalHelper/Common.hs
+++ b/CabalHelper/Common.hs
@@ -63,19 +63,17 @@ align n an str = let
 
 -- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and
 -- compiler version
-getCabalConfigHeader :: FilePath -> IO (Maybe (Version, Version))
+getCabalConfigHeader :: FilePath -> IO (Maybe (Version, (ByteString, Version)))
 getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do
   parseHeader <$> BS.hGetLine h
 
-parseHeader :: ByteString -> Maybe (Version, Version)
+parseHeader :: ByteString -> Maybe (Version, (ByteString, Version))
 parseHeader header = case BS8.words header of
   ["Saved", "package", "config", "for", _pkgId ,
    "written", "by", cabalId,
    "using", compId]
-    -> liftM2 (,) (ver cabalId) (ver compId)
+    -> liftM2 (,) (snd <$> parsePkgId cabalId) (parsePkgId compId)
   _ -> Nothing
- where
-   ver i = snd <$> parsePkgId i
 
 parsePkgId :: ByteString -> Maybe (ByteString, Version)
 parsePkgId bs =
@@ -86,11 +84,11 @@ parsePkgId bs =
 parseVer :: String -> Version
 parseVer vers = runReadP parseVersion vers
 
--- majorVer :: Version -> Version
--- majorVer (Version b _) = Version (take 2 b) []
+majorVer :: Version -> Version
+majorVer (Version b _) = Version (take 2 b) []
 
--- sameMajorVersion :: Version -> Version -> Bool
--- sameMajorVersion a b = majorVer a == majorVer b
+sameMajorVersionAs :: Version -> Version -> Bool
+sameMajorVersionAs a b = majorVer a == majorVer b
 
 runReadP :: ReadP t -> String -> t
 runReadP p i = case filter ((=="") . snd) $ readP_to_S p i of
diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs
index ef3447b..a09a634 100644
--- a/CabalHelper/Main.hs
+++ b/CabalHelper/Main.hs
@@ -92,6 +92,7 @@ usage = do
      ++"         | ghc-options     [--with-inplace]\n"
      ++"         | ghc-src-options [--with-inplace]\n"
      ++"         | ghc-pkg-options [--with-inplace]\n"
+     ++"         | ghc-lang-options [--with-inplace]\n"
      ++"         | entrypoints\n"
      ++"         | source-dirs\n"
      ++"         ) ...\n"
@@ -103,6 +104,7 @@ commands = [ "print-bli"
            , "ghc-options"
            , "ghc-src-options"
            , "ghc-pkg-options"
+           , "ghc-lang-options"
            , "entrypoints"
            , "source-dirs"]
 
@@ -178,7 +180,7 @@ main = do
 
            opts' = mempty {
                -- Not really needed but "unexpected package db stack: []"
-               ghcOptPackageDBs      = [GlobalPackageDB],
+               ghcOptPackageDBs      = [GlobalPackageDB, UserPackageDB],
 
                ghcOptCppOptions      = ghcOptCppOptions opts,
                ghcOptCppIncludePath  = ghcOptCppIncludePath opts,
@@ -207,6 +209,25 @@ main = do
          in renderGhcOptions' lbi v $ opts' `mappend` adopts
       return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])])
 
+    "ghc-lang-options":flags -> do
+      res <- componentsMap lbi v distdir $ \c clbi bi -> let
+           comp = compiler lbi
+           outdir = componentOutDir lbi c
+           (clbi', adopts) = case flags of
+                               ["--with-inplace"] -> (clbi, mempty)
+                               [] -> removeInplaceDeps v lbi pd clbi
+           opts = componentGhcOptions v lbi bi clbi' outdir
+
+           opts' = mempty {
+                       ghcOptPackageDBs      = [GlobalPackageDB, UserPackageDB],
+
+                       ghcOptLanguage = ghcOptLanguage opts,
+                       ghcOptExtensions = ghcOptExtensions opts,
+                       ghcOptExtensionMap = ghcOptExtensionMap opts
+                   }
+         in renderGhcOptions' lbi v $ opts' `mappend` adopts
+      return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])])
+
     "entrypoints":[] -> do
       eps <- componentsMap lbi v distdir $ \c clbi bi ->
                return $ componentEntrypoints c
diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs
index 1a4bc37..6946465 100644
--- a/Distribution/Helper.hs
+++ b/Distribution/Helper.hs
@@ -32,6 +32,7 @@ module Distribution.Helper (
   , ghcOptions
   , ghcSrcOptions
   , ghcPkgOptions
+  , ghcLangOptions
 
   -- * Result types
   , ChModuleName(..)
@@ -87,7 +88,8 @@ data SomeLocalBuildInfo = SomeLocalBuildInfo {
       slbiSourceDirs    :: [(ChComponentName, [String])],
       slbiGhcOptions    :: [(ChComponentName, [String])],
       slbiGhcSrcOptions :: [(ChComponentName, [String])],
-      slbiGhcPkgOptions :: [(ChComponentName, [String])]
+      slbiGhcPkgOptions :: [(ChComponentName, [String])],
+      slbiGhcLangOptions :: [(ChComponentName, [String])]
     } deriving (Eq, Ord, Read, Show)
 
 -- | Caches helper executable result so it doesn't have to be run more than once
@@ -146,11 +148,15 @@ ghcSrcOptions :: MonadIO m => Query m [(ChComponentName, [String])]
 -- access any home modules.
 ghcPkgOptions :: MonadIO m => Query m [(ChComponentName, [String])]
 
+-- | Only language related options, i.e. @-XSomeExtension@
+ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])]
+
 entrypoints   = Query $ slbiEntrypoints   `liftM` getSlbi
 sourceDirs    = Query $ slbiSourceDirs    `liftM` getSlbi
 ghcOptions    = Query $ slbiGhcOptions    `liftM` getSlbi
 ghcSrcOptions = Query $ slbiGhcSrcOptions `liftM` getSlbi
 ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi
+ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi
 
 -- | Run @cabal configure@
 reconfigure :: MonadIO m
@@ -181,6 +187,7 @@ getSomeConfigState = ask >>= \(progs, distdir) -> do
              , "ghc-options"
              , "ghc-src-options"
              , "ghc-pkg-options"
+             , "ghc-lang-options"
              ] ++ progArgs
 
   res <- liftIO $ do
@@ -195,9 +202,11 @@ getSomeConfigState = ask >>= \(progs, distdir) -> do
         Just (ChResponseStrings srcDirs),
         Just (ChResponseStrings ghcOpts),
         Just (ChResponseStrings ghcSrcOpts),
-        Just (ChResponseStrings ghcPkgOpts) ] = res
+        Just (ChResponseStrings ghcPkgOpts),
+        Just (ChResponseStrings ghcLangOpts) ] = res
 
-  return $ SomeLocalBuildInfo eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
+  return $ SomeLocalBuildInfo
+             eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcLangOpts
 
 -- | Create @cabal_macros.h@ and @Paths_\<pkg\>@ possibly other generated files
 -- in the usual place.