Introducing cabal-helper-wrapper

The idea here is to build cabal-helper with whatever version of Cabal
the user happens to be using (which we find by looking at
dist/setup-config) at runtime.

This way we can support literally any version of Cabal as long as the
actual cabal-helper still compiles.

I tried to only use interfaces in Cabal that have been there since at
least 1.16 so I'm hoping this shouldn't break too much.

cabal-helper/Common.hs

@@ -0,0 +1,41 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+module Common where
+
+import Control.Applicative
+import Data.List
+import Data.Maybe
+import System.Environment
+import System.IO
+
+errMsg :: String -> IO ()
+errMsg str = do
+  prog <- getProgName
+  hPutStrLn stderr $ prog ++ ": " ++ str
+
+align :: String -> String -> String -> String
+align n an str = let
+    h:rest = lines str
+    [hm]   = match n h
+    rest'  = [ move (hm - rm) r | r <- rest, rm <- match an r]
+    in
+      unlines (h:rest')
+ where
+   match p str' = maybeToList $
+     fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str')
+   move i str' | i > 0  = replicate i ' ' ++ str'
+   move i str' = drop i str'

cabal-helper/Main.hs

@@ -0,0 +1,345 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE CPP, BangPatterns, RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+import Distribution.Simple.Utils (cabalVersion)
+import Distribution.Simple.Configure
+
+import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId)
+import Distribution.PackageDescription (PackageDescription,
+                                        FlagAssignment,
+                                        Executable(..),
+                                        Library(..),
+                                        TestSuite(..),
+                                        Benchmark(..),
+                                        BuildInfo(..),
+                                        TestSuiteInterface(..),
+                                        BenchmarkInterface(..),
+                                        withLib)
+import Distribution.PackageDescription.Parse (readPackageDescription)
+import Distribution.PackageDescription.Configuration (flattenPackageDescription)
+
+import Distribution.Simple.Configure (getPersistBuildConfig)
+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
+                                           Component(..),
+                                           ComponentName(..),
+                                           ComponentLocalBuildInfo(..),
+                                           componentBuildInfo,
+                                           externalPackageDeps,
+                                           withComponentsLBI,
+                                           inplacePackageId)
+
+import Distribution.Simple.GHC (componentGhcOptions)
+import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions)
+
+import Distribution.Simple.Setup (ConfigFlags(..),Flag(..))
+import Distribution.Simple.Build (initialBuildSteps)
+import Distribution.Simple.BuildPaths (autogenModuleName, cppHeaderName, exeExtension)
+import Distribution.Simple.Compiler (PackageDB(..))
+
+import Distribution.ModuleName (components)
+import qualified Distribution.ModuleName as C (ModuleName)
+import Distribution.Text (display)
+import Distribution.Verbosity (Verbosity, silent, deafening)
+
+import Control.Applicative ((<$>))
+import Control.Monad
+import Control.Exception (catch, PatternMatchFail(..))
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import System.Environment
+import System.Directory
+import System.FilePath
+import System.Exit
+import System.IO
+import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)
+import Text.Printf
+import Common
+
+--- \ / These types MUST be in sync with the copies in lib:ghc-mod
+data GmComponentName = GmSetupHsName
+                     | GmLibName
+                     | GmExeName String
+                     | GmTestName String
+                     | GmBenchName String
+  deriving (Eq, Ord, Read, Show)
+data GmCabalHelperResponse
+    = GmCabalHelperStrings [(GmComponentName, [String])]
+    | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [ModuleName])]
+    | GmCabalHelperLbi String
+  deriving (Read, Show)
+--- ^ These types MUST be in sync with the copies in ../Types.hs
+
+
+-- MUST be compatible to the one in GHC
+newtype ModuleName = ModuleName String
+  deriving (Eq, Ord, Read, Show)
+
+usage = do
+  prog <- getProgName
+  hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg)
+ where
+   usageMsg = ""
+     ++"DIST_DIR ( version\n"
+     ++"         | print-lbi\n"
+     ++"         | write-autogen-files\n"
+     ++"         | ghc-options [--with-inplace]\n"
+     ++"         | ghc-src-options [--with-inplace]\n"
+     ++"         | ghc-pkg-options [--with-inplace]\n"
+     ++"         | entrypoints\n"
+     ++"         | source-dirs\n"
+     ++"         ) ...\n"
+
+commands :: [String]
+commands = [ "print-bli"
+           , "write-autogen-files"
+           , "component-from-file"
+           , "ghc-options"
+           , "ghc-src-options"
+           , "ghc-pkg-options"
+           , "entrypoints"
+           , "source-dirs"]
+
+main :: IO ()
+main = do
+  args <- getArgs
+
+  distdir:args' <- case args of
+                    [] -> usage >> exitFailure
+                    _ -> return args
+
+  ddexists <- doesDirectoryExist distdir
+  when (not ddexists) $ do
+         errMsg $ "distdir '"++distdir++"' does not exist"
+         exitFailure
+
+  v <- maybe silent (const deafening) <$> lookupEnv "GHC_MOD_DEBUG"
+  lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir
+  let pd = localPkgDescr lbi
+
+  let
+      -- a =<< b $$ c   ==  (a =<< b) $$ c
+      -- a <$$> b $$ c  ==  a <$$> (b $$ c)
+      infixr 2 $$
+      ($$) = ($)
+      infixr 1 <$$>
+      (<$$>) = (<$>)
+
+      collectCmdOptions :: [String] -> [[String]]
+      collectCmdOptions =
+          reverse . map reverse . foldl f [] . dropWhile isOpt
+       where
+         isOpt = ("--" `isPrefixOf`)
+         f [] x = [[x]]
+         f (a:as) x
+             | isOpt x = (x:a):as
+             | otherwise = [x]:(a:as)
+
+  let cmds = collectCmdOptions args'
+
+  if any (["version"] `isPrefixOf`) cmds
+    then do
+      putStrLn $
+       printf "using version %s of the Cabal library" (display cabalVersion)
+      exitSuccess
+    else return ()
+
+  print =<< flip mapM cmds $$ \cmd -> do
+  case cmd of
+    "write-autogen-files":[] -> do
+      let pd = localPkgDescr lbi
+       -- calls writeAutogenFiles
+      initialBuildSteps distdir pd lbi v
+      return Nothing
+
+    "ghc-options":flags ->
+      Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
+      \c clbi bi -> let
+           outdir = componentOutDir lbi c
+           (clbi', adopts) = case flags of
+                               ["--with-inplace"] -> (clbi, mempty)
+                               [] -> removeInplaceDeps pd clbi
+           opts = componentGhcOptions v lbi bi clbi' outdir
+           in
+              renderGhcOptions (compiler lbi) $ opts `mappend` adopts
+
+    "ghc-src-options":flags ->
+      Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
+      \c clbi bi -> let
+           outdir = componentOutDir lbi c
+           (clbi', adopts) = case flags of
+                               ["--with-inplace"] -> (clbi, mempty)
+                               [] -> removeInplaceDeps pd clbi
+           opts = componentGhcOptions v lbi bi clbi' outdir
+           comp = compiler lbi
+
+           opts' = mempty {
+               -- Not really needed but "unexpected package db stack: []"
+               ghcOptPackageDBs      = [GlobalPackageDB],
+               ghcOptCppOptions      = ghcOptCppOptions opts,
+               ghcOptCppIncludePath  = ghcOptCppIncludePath opts,
+               ghcOptCppIncludes     = ghcOptCppIncludes opts,
+               ghcOptFfiIncludes     = ghcOptFfiIncludes opts,
+               ghcOptSourcePathClear = ghcOptSourcePathClear opts,
+               ghcOptSourcePath      = ghcOptSourcePath opts
+              }
+            in
+              renderGhcOptions comp $ opts `mappend` adopts
+
+    "ghc-pkg-options":flags ->
+      Just . GmCabalHelperStrings <$$> 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 pd clbi
+           opts = componentGhcOptions v lbi bi clbi' outdir
+
+           opts' = mempty {
+                       ghcOptPackageDBs = ghcOptPackageDBs opts,
+                       ghcOptPackages   = ghcOptPackages opts,
+                       ghcOptHideAllPackages = ghcOptHideAllPackages opts
+                   }
+           in
+             renderGhcOptions (compiler lbi) $ opts' `mappend` adopts
+
+    "entrypoints":[] -> do
+      eps <- componentsMap lbi v distdir $ \c clbi bi ->
+               componentEntrypoints c
+      -- MUST append Setup component at the end otherwise CabalHelper gets
+      -- confused
+      let eps' = eps ++ [(GmSetupHsName, Right [ModuleName "Setup"])]
+      return $ Just $ GmCabalHelperEntrypoints eps'
+
+    "source-dirs":[] ->
+      Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
+      \c clbi bi -> hsSourceDirs bi
+
+    "print-lbi":[] ->
+      return $ Just $ GmCabalHelperLbi $ show lbi
+
+    cmd:_ | not (cmd `elem` commands) ->
+            errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure
+    _ ->
+            errMsg "Invalid usage!" >> usage >> exitFailure
+
+
+getLibrary :: PackageDescription -> Library
+getLibrary pd = unsafePerformIO $ do
+  lr <- newIORef (error "libraryMap: empty IORef")
+  withLib pd (writeIORef lr)
+  readIORef lr
+
+componentsMap :: LocalBuildInfo
+              -> Verbosity
+              -> FilePath
+              -> (   Component
+                  -> ComponentLocalBuildInfo
+                  -> BuildInfo
+                  -> a)
+              -> IO [(GmComponentName, a)]
+componentsMap lbi v distdir f = do
+    let pd = localPkgDescr lbi
+
+    lr <- newIORef []
+
+    withComponentsLBI pd lbi $ \c clbi -> do
+        let bi = componentBuildInfo c
+            name = componentNameFromComponent c
+
+        l' <- readIORef lr
+        writeIORef lr $ (componentNameToGm name, f c clbi bi):l'
+    reverse <$> readIORef lr
+
+componentNameToGm CLibName = GmLibName
+componentNameToGm (CExeName n) = GmExeName n
+componentNameToGm (CTestName n) = GmTestName n
+componentNameToGm (CBenchName n) = GmBenchName n
+
+componentNameFromComponent (CLib Library {}) = CLibName
+componentNameFromComponent (CExe Executable {..}) = CExeName exeName
+componentNameFromComponent (CTest TestSuite {..}) = CTestName testName
+componentNameFromComponent (CBench Benchmark {..}) = CBenchName benchmarkName
+
+componentOutDir lbi (CLib Library {..})= buildDir lbi
+componentOutDir lbi (CExe Executable {..})= exeOutDir lbi exeName
+componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteExeV10 _ _, ..}) =
+    exeOutDir lbi testName
+componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) =
+    exeOutDir lbi (testName ++ "Stub")
+componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})=
+    exeOutDir lbi benchmarkName
+
+gmModuleName :: C.ModuleName -> ModuleName
+gmModuleName = ModuleName . intercalate "." . components
+
+componentEntrypoints :: Component -> Either FilePath [ModuleName]
+componentEntrypoints (CLib Library {..})
+    = Right $ map gmModuleName exposedModules
+componentEntrypoints (CExe Executable {..})
+    = Left modulePath
+componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp })
+    = Left fp
+componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn })
+    = Right [gmModuleName mn]
+componentEntrypoints (CTest TestSuite {})
+    = Right []
+componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _  fp})
+    = Left fp
+componentEntrypoints (CBench Benchmark {})
+    = Left []
+
+exeOutDir :: LocalBuildInfo -> String -> FilePath
+exeOutDir lbi exeName =
+  ----- Copied from Distribution/Simple/GHC.hs:buildOrReplExe
+  -- exeNameReal, the name that GHC really uses (with .exe on Windows)
+  let exeNameReal = exeName <.>
+                    (if takeExtension exeName /= ('.':exeExtension)
+                       then exeExtension
+                       else "")
+
+      targetDir = (buildDir lbi) </> exeName
+  in targetDir
+
+
+removeInplaceDeps :: PackageDescription
+                  -> ComponentLocalBuildInfo
+                  -> (ComponentLocalBuildInfo, GhcOptions)
+removeInplaceDeps pd clbi = let
+    (ideps, deps) = partition isInplaceDep (componentPackageDeps clbi)
+    hasIdeps = not $ null ideps
+    clbi' = clbi { componentPackageDeps = deps }
+    lib = getLibrary pd
+    src_dirs = hsSourceDirs (libBuildInfo lib)
+    adopts = mempty {
+               ghcOptSourcePath      =
+#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22
+                   toNubListR src_dirs
+#else
+                   src_dirs
+#endif
+
+             }
+
+  in (clbi', if hasIdeps then adopts else mempty)
+
+ where
+   isInplaceDep :: (InstalledPackageId, PackageId) -> Bool
+   isInplaceDep (ipid, pid) = inplacePackageId pid == ipid

cabal-helper/Wrapper.hs

@@ -0,0 +1,258 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-}
+module Main where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Control.Monad.Trans.Maybe
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.String
+import Data.Version
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import Text.Printf
+import Text.ParserCombinators.ReadP
+import System.Environment
+import System.Directory
+import System.FilePath
+import System.Process
+import System.Exit
+import System.IO
+
+import Distribution.System (buildPlatform)
+import Distribution.Text (display)
+
+import NotCPP.Declarations
+
+import Paths_ghc_mod
+import Common
+import Utils
+
+ifD [d| getExecutablePath = getProgName |]
+
+usage :: IO ()
+usage = do
+  prog <- getProgName
+  hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg)
+ where
+   usageMsg = "\
+\( print-appdatadir\n\
+\| print-build-platform\n\
+\| DIST_DIR [CABAL_HELPER_ARGS...]\n\
+\)\n"
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    "print-appdatadir":[] -> putStrLn =<< appDataDir
+    "print-build-platform":[] -> putStrLn $ display buildPlatform
+    distdir:_ -> do
+      cfgf <- canonicalizePath (distdir </> "setup-config")
+      mhdr <- (parseHeader =<<) . listToMaybe . BS8.lines <$> BS.readFile cfgf
+      case mhdr of
+        Nothing -> error $ printf "\
+\Could not read Cabal's persistent setup configuration header\n\
+\- Check first line of: %s\n\
+\- Maybe try: $ cabal configure" cfgf
+
+        Just Header {..} -> do
+          eexe <- compileHelper hdrCabalVersion
+          case eexe of
+              Left e -> exitWith e
+              Right exe -> do
+                  (_,_,_,h) <- createProcess $ proc exe args
+                  exitWith =<< waitForProcess h
+
+    _ -> usage
+
+appDataDir :: IO FilePath
+appDataDir = (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
+
+tryFindSrcDirInGhcModTree :: IO (Maybe FilePath)
+tryFindSrcDirInGhcModTree  = do
+  dir <- (!!4) . iterate takeDirectory <$> getExecutablePath
+  exists <- doesFileExist $ dir </> "ghc-mod.cabal"
+  src_exists <- doesFileExist $ dir </> "cabal-helper/Main.hs"
+  if exists && src_exists
+     then return $ Just (dir </> "cabal-helper")
+     else return Nothing
+
+tryFindRealSrcDir :: IO (Maybe FilePath)
+tryFindRealSrcDir = do
+    datadir <- getDataDir
+    exists <- doesFileExist $ datadir </> "cabal-helper/Main.hs"
+    return $ if exists
+               then Just $ datadir </> "cabal-helper"
+               else Nothing
+
+findCabalHelperSourceDir :: IO FilePath
+findCabalHelperSourceDir = do
+    msrcdir <- runMaybeT $  MaybeT tryFindSrcDirInGhcModTree
+                        <|> MaybeT tryFindRealSrcDir
+    case msrcdir of
+      Nothing -> getDataDir >>= errorNoMain
+      Just datadir -> return datadir
+
+compileHelper :: Version -> IO (Either ExitCode FilePath)
+compileHelper cabalVer = do
+  chdir <- findCabalHelperSourceDir
+  mver <- find (sameMajorVersion cabalVer) <$> listCabalVersions
+  couldBeSrcDir <- takeDirectory <$> getDataDir
+
+  case mver of
+    Nothing -> do
+      let cabalFile = couldBeSrcDir </> "Cabal.cabal"
+      cabal <- doesFileExist cabalFile
+      if cabal
+        then do
+          ver <- cabalFileVersion <$> readFile cabalFile
+          compile $ Compile chdir (Just couldBeSrcDir) ver []
+        else errorNoCabal cabalVer
+    Just ver ->
+        compile $ Compile chdir Nothing ver [cabalPkgId ver]
+ where
+   cabalPkgId v = "Cabal-" ++ showVersion v
+
+errorNoCabal :: Version -> a
+errorNoCabal cabalVer = error $ printf "\
+\No appropriate Cabal package found, wanted version %s.\n\
+\- Check output of: $ ghc-pkg list Cabal\n\
+\- Maybe try: $ cabal install Cabal --constraint 'Cabal == %s.*'" sver mjver
+ where
+   sver = showVersion cabalVer
+   mjver = showVersion $ majorVer cabalVer
+
+errorNoMain :: FilePath -> a
+errorNoMain datadir = error $ printf "\
+\Could not find $datadir/cabal-helper/Main.hs!\n\
+\\n\
+\If you are a developer you can use the environment variable `ghc_mod_datadir'\n\
+\to override $datadir[1], `$ export ghc_mod_datadir=$PWD' will work in the\n\
+\ghc-mod tree.\n\
+\[1]: %s\n\
+\\n\
+\If you don't know what I'm talking about something went wrong with your\n\
+\installation. Please report this problem here:\n\
+\    https://github.com/kazu-yamamoto/ghc-mod/issues" datadir
+
+data Compile = Compile {
+      cabalHelperSourceDir :: FilePath,
+      cabalSourceDir :: Maybe FilePath,
+      cabalVersion   :: Version,
+      packageDeps    :: [String]
+    }
+
+compile :: Compile -> IO (Either ExitCode FilePath)
+compile Compile {..} = do
+    outdir <- appDataDir
+    createDirectoryIfMissing True outdir
+
+    let exe = outdir </> "cabal-helper-" ++ showVersion (majorVer cabalVersion)
+
+    recompile <-
+      case cabalSourceDir of
+        Nothing -> do
+          tsrcs <- timeHsFiles cabalHelperSourceDir
+          texe <- timeMaybe exe
+          return $ any ((texe <) . Just) tsrcs
+        Just _ -> return True -- let ghc do the difficult recomp checking
+
+    let Version (mj:mi:_) _ = cabalVersion
+    let ghc_opts =
+             concat [
+          [ "-outputdir", outdir
+          , "-o", exe
+          , "-optP-DCABAL_MAJOR=" ++ show mj
+          , "-optP-DCABAL_MINOR=" ++ show mi
+          ],
+          map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir,
+          concatMap (\p -> ["-package", p]) packageDeps,
+          [ "--make",  cabalHelperSourceDir </> "Main.hs" ]
+         ]
+
+    if recompile
+       then do
+         (_, _, _, h) <- createProcess
+           (proc "ghc" ghc_opts) { std_out = UseHandle stderr }
+         rv <- waitForProcess h
+         return $ case rv of
+                    ExitSuccess -> Right exe
+                    e@(ExitFailure _) -> Left e
+      else return $ Right exe
+
+timeHsFiles :: FilePath -> IO [TimedFile]
+timeHsFiles dir = do
+    fs <- map (dir</>) <$> getDirectoryContents dir
+    mapM timeFile =<< filterM isHsFile fs
+ where
+   isHsFile f = do
+     exists <- doesFileExist f
+     return $ exists && ".hs" `isSuffixOf` f
+
+
+
+-- TODO: Include sandbox? Probably only relevant for build-type:custom projects.
+listCabalVersions :: IO [Version]
+listCabalVersions = do
+  catMaybes . map (fmap snd . parsePkgId . fromString) . words
+          <$> readProcess "ghc-pkg" ["list", "--simple-output", "Cabal"] ""
+
+data Header = Header { hdrCabalVersion    :: Version
+                     , hdrCompilerVersion :: Version
+                     }
+
+-- | Find @version: XXX@ delcaration in a cabal file
+cabalFileVersion :: String -> Version
+cabalFileVersion cabalFile = do
+  fromJust $ parseVer . extract <$> find ("version" `isPrefixOf`) ls
+ where
+  ls = map (map toLower) $ lines cabalFile
+  extract = dropWhile (/=':') >>> dropWhile isSpace >>> takeWhile (not . isSpace)
+
+parseHeader :: ByteString -> Maybe Header
+parseHeader header = case BS8.words header of
+  ["Saved", "package", "config", "for", _pkgId ,
+   "written", "by", cabalId,
+   "using", compId]
+    -> liftM2 Header (ver cabalId) (ver compId)
+  _ -> error "parsing setup-config header failed"
+ where
+   ver i = snd <$> parsePkgId i
+
+parsePkgId :: ByteString -> Maybe (ByteString, Version)
+parsePkgId bs =
+    case BS8.split '-' bs of
+      [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers)
+      _ -> Nothing
+
+parseVer :: String -> Version
+parseVer vers = runReadP parseVersion vers
+
+majorVer :: Version -> Version
+majorVer (Version b _) = Version (take 2 b) []
+
+sameMajorVersion :: Version -> Version -> Bool
+sameMajorVersion a b = majorVer a == majorVer b
+
+runReadP :: ReadP t -> String -> t
+runReadP p i = let (a,""):[] = filter ((=="") . snd) $ readP_to_S p i in a

ghc-mod.cabal

@@ -186,20 +186,25 @@ Executable ghc-modi
                       , ghc
                       , ghc-mod
 
-Executable cabal-helper
+Executable cabal-helper-wrapper
   Default-Language:     Haskell2010
-  Main-Is:              GHCModCabal.hs
+  Other-Extensions:     TemplateHaskell
+  Main-Is:              Wrapper.hs
+  Other-Modules:        Paths_ghc_mod
   GHC-Options:          -Wall
-  HS-Source-Dirs:       src
+  HS-Source-Dirs:       cabal-helper, .
   X-Install-Target:     $libexecdir
   Build-Depends:        base >= 4.0 && < 5
                       , bytestring
                       , binary
+                      , containers
+                      , Cabal >= 1.16
                       , directory
-  if flag(cabal-122)
+                      , filepath
-    Build-Depends:      Cabal >= 1.22
+                      , process
-  else
+                      , transformers
-    Buildable:          False
+                      , template-haskell
+                      , time
 
 Test-Suite doctest
   Type:                 exitcode-stdio-1.0

src/GHCModCabal.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-module Main where
-
-import Control.Applicative
-
-import Distribution.Simple.Utils (cabalVersion)
-import Distribution.Simple.Configure
-import Distribution.Text ( display )
-import System.Environment
-import System.Directory
-
-main :: IO ()
-main = do
-  args <- getArgs
-  case args of
-    "version":[] -> do
-        putStrLn $ "using version " ++ display cabalVersion ++ " of the Cabal library"
-    "print-setup-config":args' -> do
-        mfile <- findFile ["dist"] "setup-config"
-
-        let file = case mfile of
-                     Just f -> f
-                     Nothing -> let !(f:[]) = args' in f
-
-        putStrLn =<< show <$> getConfigStateFile file
-
-    cmd:_ -> error $ "Unknown command: " ++ cmd
-    [] -> error "No command given"