Add language options query

2 files changed, 29 insertions, 10 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