Use cabal-helper to support Cabal >= 1.22 with any version of ghc

Language/Haskell/GhcMod/CabalApi.hs

@@ -13,6 +13,7 @@ import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, mkGHCCompilerId)
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Logging
 
 import MonadUtils (liftIO)
 import Control.Applicative ((<$>))
@@ -36,14 +37,15 @@ import System.FilePath ((</>))
 ----------------------------------------------------------------
 
 -- | Getting necessary 'CompilerOptions' from three information sources.
-getCompilerOptions :: (IOish m, MonadError GhcModError m)
+getCompilerOptions :: (IOish m, GmError m, GmLog m)
                    => [GHCOption]
                    -> Cradle
+                   -> CabalConfig
                    -> PackageDescription
                    -> m CompilerOptions
-getCompilerOptions ghcopts cradle pkgDesc = do
+getCompilerOptions ghcopts cradle config pkgDesc = do
     gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos
-    depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc)
+    let depPkgs = cabalConfigDependencies config (C.packageId pkgDesc)
     return $ CompilerOptions gopts idirs depPkgs
   where
     wdir       = cradleCurrentDir cradle
@@ -67,14 +69,14 @@ includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
 ----------------------------------------------------------------
 
 -- | Parse a cabal file and return a 'PackageDescription'.
-parseCabalFile :: (IOish m, MonadError GhcModError m)
+parseCabalFile :: (IOish m, GmError m, GmLog m)
-               => Cradle
+               => CabalConfig
                -> FilePath
                -> m PackageDescription
-parseCabalFile cradle file = do
+parseCabalFile  config file = do
     cid <- mkGHCCompilerId <$> liftIO getGHCVersion
     epgd <- liftIO $ readPackageDescription silent file
-    flags <- cabalConfigFlags cradle
+    flags <- cabalConfigFlags config
     case toPkgDesc cid flags epgd of
         Left deps    -> fail $ show deps ++ " are not installed"
         Right (pd,_) -> if nullPkg pd

Language/Haskell/GhcMod/CabalConfig.hs

@@ -4,39 +4,32 @@
 -- 'LocalBuildInfo' (@dist/setup-config@) for different version combinations of
 -- Cabal and GHC.
 module Language.Haskell.GhcMod.CabalConfig (
-    cabalConfigDependencies
+    CabalConfig
+  , cabalGetConfig
+  , cabalConfigDependencies
   , cabalConfigFlags
   ) where
 
-import Control.Applicative
 import Distribution.Package (PackageIdentifier)
 import Distribution.PackageDescription (FlagAssignment)
 
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Error
 
-#if __GLASGOW_HASKELL__ >= 710
+import Language.Haskell.GhcMod.CabalConfig.Extract
-import Language.Haskell.GhcMod.CabalConfig.Ghc710
-#else
-import Language.Haskell.GhcMod.CabalConfig.PreGhc710
-#endif
 
+cabalGetConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig
+cabalGetConfig = getConfig
 
 -- | Get list of 'Package's needed by all components of the current package
-cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
+cabalConfigDependencies :: CabalConfig -> PackageIdentifier -> [Package]
-                        => Cradle
+cabalConfigDependencies config thisPkg =
-                        -> PackageIdentifier
+    configDependencies thisPkg config
-                        -> m [Package]
-cabalConfigDependencies cradle thisPkg =
-    configDependencies thisPkg <$> getConfig cradle
 
 
 -- | Get the flag assignment from the local build info of the given cradle
-cabalConfigFlags :: (IOish m, MonadError GhcModError m)
+cabalConfigFlags :: (IOish m, GmError m) => CabalConfig -> m FlagAssignment
-                 => Cradle
+cabalConfigFlags config = do
-                 -> m FlagAssignment
-cabalConfigFlags cradle = do
-  config <- getConfig cradle
   case configFlags config of
     Right x  -> return x
     Left msg -> throwError (GMECabalFlags (GMEString msg))

Language/Haskell/GhcMod/CabalConfig/Cabal22.hs

@@ -0,0 +1,107 @@
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+-- Copyright   :  Isaac Jones 2003-2004
+-- Copyright   :  (c) The University of Glasgow 2004
+-- Copyright   :  Duncan Coutts 2008
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Isaac Jones nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+-- | ComponentLocalBuildInfo for Cabal >= 1.22
+module Language.Haskell.GhcMod.CabalConfig.Cabal22 (
+    ComponentLocalBuildInfo
+  , PackageIdentifier(..)
+  , PackageName(..)
+  , componentPackageDeps
+  , componentLibraries
+  ) where
+
+import Distribution.Package (InstalledPackageId)
+import Data.Version (Version)
+import Data.Map (Map)
+
+data LibraryName = LibraryName String
+    deriving (Read, Show)
+
+newtype PackageName = PackageName { unPackageName :: String }
+  deriving (Read, Show, Ord, Eq)
+
+data PackageIdentifier
+  = PackageIdentifier {
+    pkgName :: PackageName,
+    pkgVersion :: Version
+  }
+  deriving (Read, Show)
+
+type PackageId = PackageIdentifier
+
+newtype ModuleName = ModuleName [String]
+  deriving (Read, Show)
+
+data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)]
+    deriving (Read, Show)
+
+data OriginalModule
+   = OriginalModule {
+       originalPackageId :: InstalledPackageId,
+       originalModuleName :: ModuleName
+     }
+  deriving (Read, Show)
+
+data ExposedModule
+   = ExposedModule {
+       exposedName      :: ModuleName,
+       exposedReexport  :: Maybe OriginalModule,
+       exposedSignature :: Maybe OriginalModule -- This field is unused for now.
+     }
+  deriving (Read, Show)
+
+data ComponentLocalBuildInfo
+  = LibComponentLocalBuildInfo {
+    -- | Resolved internal and external package dependencies for this component.
+    -- The 'BuildInfo' specifies a set of build dependencies that must be
+    -- satisfied in terms of version ranges. This field fixes those dependencies
+    -- to the specific versions available on this machine for this compiler.
+    componentPackageDeps :: [(InstalledPackageId, PackageId)],
+    componentExposedModules :: [ExposedModule],
+    componentPackageRenaming :: Map PackageName ModuleRenaming,
+    componentLibraries :: [LibraryName]
+  }
+  | ExeComponentLocalBuildInfo {
+    componentPackageDeps :: [(InstalledPackageId, PackageId)],
+    componentPackageRenaming :: Map PackageName ModuleRenaming
+  }
+  | TestComponentLocalBuildInfo {
+    componentPackageDeps :: [(InstalledPackageId, PackageId)],
+    componentPackageRenaming :: Map PackageName ModuleRenaming
+  }
+  | BenchComponentLocalBuildInfo {
+    componentPackageDeps :: [(InstalledPackageId, PackageId)],
+    componentPackageRenaming :: Map PackageName ModuleRenaming
+  }
+  deriving (Read, Show)

Language/Haskell/GhcMod/CabalConfig/Extract.hs

@@ -0,0 +1,223 @@
+{-# LANGUAGE RecordWildCards, CPP, OverloadedStrings #-}
+
+-- | This module facilitates extracting information from Cabal's on-disk
+-- 'LocalBuildInfo' (@dist/setup-config@).
+module Language.Haskell.GhcMod.CabalConfig.Extract (
+    CabalConfig
+  , configDependencies
+  , configFlags
+  , getConfig
+  ) where
+
+import Language.Haskell.GhcMod.Error
+import Language.Haskell.GhcMod.GhcPkg
+import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.Read
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils
+import Language.Haskell.GhcMod.World
+
+import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16
+import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18
+import qualified Language.Haskell.GhcMod.CabalConfig.Cabal22 as C22
+
+#ifndef MIN_VERSION_mtl
+#define MIN_VERSION_mtl(x,y,z) 1
+#endif
+
+import Control.Applicative ((<$>))
+import Control.Monad (void, mplus, when)
+#if MIN_VERSION_mtl(2,2,1)
+import Control.Monad.Except ()
+#else
+import Control.Monad.Error ()
+#endif
+import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
+import Data.Version
+import Distribution.Package (InstalledPackageId(..)
+                           , PackageIdentifier(..)
+                           , PackageName(..))
+import Distribution.PackageDescription (FlagAssignment)
+import Distribution.Simple.LocalBuildInfo (ComponentName)
+import MonadUtils (liftIO)
+import Text.ParserCombinators.ReadP
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
+----------------------------------------------------------------
+
+-- | 'Show'ed cabal 'LocalBuildInfo' string
+newtype CabalConfig = CabalConfig { unCabalConfig :: String }
+
+-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
+-- exist run @cabal configure@ i.e. configure with default options like @cabal
+-- build@ would do.
+getConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig
+getConfig crdl = do
+    liftIO (getCurrentWorld crdl) >>= \world ->
+        when (isSetupConfigOutOfDate world) configure
+
+    cfg <- liftIO (BS.readFile file) `tryFix` \_ ->
+             configure `modifyError'` GMECabalConfigure
+
+    liftIO (getCurrentWorld crdl) >>= \world ->
+        decodeConfig crdl world file cfg
+ where
+   file = setupConfigFile crdl
+   prjDir = cradleRootDir crdl
+
+   configure :: (IOish m, GmError m) => m ()
+   configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
+
+decodeConfig :: (IOish m, GmError m)
+             => Cradle -> World -> FilePath -> ByteString -> m CabalConfig
+decodeConfig _crdl _world file bs = CabalConfig <$> gen
+
+--  if cacheOutdated world
+--     then
+--       gmLog $ "Regenerating pretty setup-config cache: " ++ prettyConfigCache
+--       liftIO $ writeFile prettyConfigCache cfg
+--     else CabalConfig <$> liftIO (readFile prettyConfigCache)
+
+ where
+   -- cacheOutdated World {..} =
+   --     case (worldCabalConfig, worldPrettyCabalConfigCache) of
+   --       (Nothing, _) -> error "decodeConfig: setup-config does not exist."
+   --       (Just _, Nothing) -> True
+   --       (Just s, Just p) -> s > p
+
+   gen = case BS8.lines bs of
+           header:_ -> do
+               ((_,cabalVer), _) <- parseHeader header
+               if cabalVer >= (Version [1,22] [])
+                 then prettyPrintBinaryConfig file
+                 else return $ bsToStr bs
+           [] -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader
+
+prettyPrintBinaryConfig :: (IOish m, GmError m)
+                             => String -> m String
+prettyPrintBinaryConfig file = do
+  exe <- liftIO $ findLibexecExe "ghc-mod-cabal"
+  slbi <- readProcess' exe ["print-setup-config", file]
+  return slbi
+
+parseHeader :: GmError m
+            => ByteString -> m ((ByteString, Version), (ByteString, Version))
+parseHeader header = case BS8.words header of
+  ["Saved", "package", "config", "for", _pkgId , "written", "by", cabalId, "using", compId] -> modifyError (\_ -> GMECabalStateFile GMConfigStateFileBadHeader) $ do
+          cabalId' <- parsePkgId cabalId
+          compId' <- parsePkgId  compId
+          return (cabalId', compId')
+
+  _ -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader
+
+parsePkgId :: (Error e, MonadError e m) => ByteString -> m (ByteString, Version)
+parsePkgId bs =
+    case BS8.split '-' bs of
+      [pkg, vers] -> return (pkg, parseVer vers)
+      _ -> throwError noMsg
+ where
+   parseVer vers =
+       let (ver,""):[] =
+               filter ((=="") . snd) $ readP_to_S parseVersion (bsToStr vers)
+       in ver
+
+bsToStr :: ByteString -> String
+bsToStr = T.unpack . T.decodeUtf8
+
+-- strToBs :: String -> ByteString
+-- strToBs = T.encodeUtf8 . T.pack
+
+-- | Extract list of depencenies for all components from 'CabalConfig'
+configDependencies :: PackageIdentifier -> CabalConfig -> [Package]
+configDependencies thisPkg config = map fromInstalledPackageId deps
+ where
+    deps :: [InstalledPackageId]
+    deps = case deps16 `mplus` deps18 `mplus` deps22 of
+        Right ps -> ps
+        Left msg -> error msg
+
+    -- True if this dependency is an internal one (depends on the library
+    -- defined in the same package).
+    internal pkgid = pkgid == thisPkg
+
+    -- Cabal >= 1.22
+    deps22 :: Either String [InstalledPackageId]
+    deps22 =
+        map fst
+      <$> filterInternal22
+      <$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs")
+
+    filterInternal22
+        :: [(ComponentName, C22.ComponentLocalBuildInfo, [ComponentName])]
+        -> [(InstalledPackageId, C22.PackageIdentifier)]
+
+    filterInternal22 ccfg = [ (ipkgid, pkgid)
+                          | (_,clbi,_)      <- ccfg
+                          , (ipkgid, pkgid) <- C22.componentPackageDeps clbi
+                          , not (internal . packageIdentifierFrom22 $ pkgid) ]
+
+    packageIdentifierFrom22 :: C22.PackageIdentifier -> PackageIdentifier
+    packageIdentifierFrom22 (C22.PackageIdentifier (C22.PackageName myName) myVersion) =
+        PackageIdentifier (PackageName myName) myVersion
+
+    -- Cabal >= 1.18 && < 1.20
+    deps18 :: Either String [InstalledPackageId]
+    deps18 =
+          map fst
+      <$> filterInternal
+      <$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs")
+
+    filterInternal
+        :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])]
+        -> [(InstalledPackageId, PackageIdentifier)]
+
+    filterInternal ccfg = [ (ipkgid, pkgid)
+                          | (_,clbi,_)      <- ccfg
+                          , (ipkgid, pkgid) <- C18.componentPackageDeps clbi
+                          , not (internal pkgid) ]
+
+    -- Cabal 1.16 and below
+    deps16 :: Either String [InstalledPackageId]
+    deps16 = map fst <$> filter (not . internal . snd) . nub <$> do
+        cbi <- concat <$> sequence [ extract "executableConfigs"
+                                   , extract "testSuiteConfigs"
+                                   , extract "benchmarkConfigs" ]
+                        :: Either String [(String, C16.ComponentLocalBuildInfo)]
+
+        return $ maybe [] C16.componentPackageDeps libraryConfig
+              ++ concatMap (C16.componentPackageDeps . snd) cbi
+     where
+       libraryConfig :: Maybe C16.ComponentLocalBuildInfo
+       libraryConfig = do
+         field <- find ("libraryConfig" `isPrefixOf`) (tails $ unCabalConfig config)
+         clbi <- stripPrefix " = " field
+         if "Nothing" `isPrefixOf` clbi
+             then Nothing
+             else case readMaybe =<< stripPrefix "Just " clbi of
+                    Just x -> x
+                    Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi)
+
+       extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)]
+       extract field = readConfigs field <$> extractField (unCabalConfig config) field
+
+       readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)]
+       readConfigs f s = case readEither s of
+           Right x -> x
+           Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")"
+
+-- | Extract the cabal flags from the 'CabalConfig'
+configFlags :: CabalConfig -> Either String FlagAssignment
+configFlags (CabalConfig config) = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags"
+
+-- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable
+-- error message with lots of context on failure.
+extractField :: String -> String -> Either String String
+extractField content field =
+    case extractParens <$> find (field `isPrefixOf`) (tails content) of
+        Just f -> Right f
+        Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` content)

Language/Haskell/GhcMod/CabalConfig/Ghc710.hs

@@ -17,6 +17,7 @@ import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.World
 
@@ -24,19 +25,18 @@ import Language.Haskell.GhcMod.World
 -- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
 -- exist run @cabal configure@ i.e. configure with default options like @cabal
 -- build@ would do.
-getConfig :: (IOish m, MonadError GhcModError m)
+getConfig :: (IOish m, GmError m)
           => Cradle
           -> m LocalBuildInfo
-getConfig cradle = do
+getConfig cradle = liftIO (getCurrentWorld cradle) >>= \world -> do
-    outOfDate <- liftIO $ isSetupConfigOutOfDate cradle
+    when (isSetupConfigOutOfDate world) configure
-    when outOfDate configure
     liftIO (getConfigStateFile file) `tryFix` \_ ->
         configure `modifyError'` GMECabalConfigure
  where
    file = setupConfigFile cradle
    prjDir = cradleRootDir cradle
 
-   configure :: (IOish m, MonadError GhcModError m) => m ()
+   configure :: (IOish m, GmError m) => m ()
    configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
 
 configDependencies :: a -> LocalBuildInfo -> [Package]

Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs

@@ -1,154 +0,0 @@
-{-# LANGUAGE RecordWildCards, CPP #-}
-
--- | This module facilitates extracting information from Cabal's on-disk
--- 'LocalBuildInfo' (@dist/setup-config@).
-module Language.Haskell.GhcMod.CabalConfig.PreGhc710 (
-    configDependencies
-  , configFlags
-  , getConfig
-  ) where
-
-import Language.Haskell.GhcMod.Error
-import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.PathsAndFiles
-import Language.Haskell.GhcMod.Read
-import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Utils
-import Language.Haskell.GhcMod.World
-
-import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16
-import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18
-import qualified Language.Haskell.GhcMod.CabalConfig.Cabal21 as C21
-
-#ifndef MIN_VERSION_mtl
-#define MIN_VERSION_mtl(x,y,z) 1
-#endif
-
-import Control.Applicative ((<$>))
-import Control.Monad (void, mplus, when)
-#if MIN_VERSION_mtl(2,2,1)
-import Control.Monad.Except ()
-#else
-import Control.Monad.Error ()
-#endif
-import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
-import Distribution.Package (InstalledPackageId(..)
-                           , PackageIdentifier(..)
-                           , PackageName(..))
-import Distribution.PackageDescription (FlagAssignment)
-import Distribution.Simple.LocalBuildInfo (ComponentName)
-import MonadUtils (liftIO)
-
-----------------------------------------------------------------
-
--- | 'Show'ed cabal 'LocalBuildInfo' string
-type CabalConfig = String
-
--- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
--- exist run @cabal configure@ i.e. configure with default options like @cabal
--- build@ would do.
-getConfig :: (IOish m, MonadError GhcModError m)
-          => Cradle
-          -> m CabalConfig
-getConfig cradle = do
-    outOfDate <- liftIO $ isSetupConfigOutOfDate cradle
-    when outOfDate configure
-    liftIO (readFile file) `tryFix` \_ ->
-        configure `modifyError'` GMECabalConfigure
- where
-   file = setupConfigFile cradle
-   prjDir = cradleRootDir cradle
-
-   configure :: (IOish m, MonadError GhcModError m) => m ()
-   configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
-
-
--- | Extract list of depencenies for all components from 'CabalConfig'
-configDependencies :: PackageIdentifier -> CabalConfig -> [Package]
-configDependencies thisPkg config = map fromInstalledPackageId deps
- where
-    deps :: [InstalledPackageId]
-    deps = case deps21 `mplus` deps18 `mplus` deps16 of
-        Right ps -> ps
-        Left msg -> error msg
-
-    -- True if this dependency is an internal one (depends on the library
-    -- defined in the same package).
-    internal pkgid = pkgid == thisPkg
-
-    -- Cabal >= 1.21
-    deps21 :: Either String [InstalledPackageId]
-    deps21 =
-        map fst
-      <$> filterInternal21
-      <$> (readEither =<< extractField config "componentsConfigs")
-
-    filterInternal21
-        :: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])]
-        -> [(InstalledPackageId, C21.PackageIdentifier)]
-
-    filterInternal21 ccfg = [ (ipkgid, pkgid)
-                          | (_,clbi,_)      <- ccfg
-                          , (ipkgid, pkgid) <- C21.componentPackageDeps clbi
-                          , not (internal . packageIdentifierFrom21 $ pkgid) ]
-
-    packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier
-    packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) =
-        PackageIdentifier (PackageName myName) myVersion
-
-    -- Cabal >= 1.18 && < 1.21
-    deps18 :: Either String [InstalledPackageId]
-    deps18 =
-          map fst
-      <$> filterInternal
-      <$> (readEither =<< extractField config "componentsConfigs")
-
-    filterInternal
-        :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])]
-        -> [(InstalledPackageId, PackageIdentifier)]
-
-    filterInternal ccfg = [ (ipkgid, pkgid)
-                          | (_,clbi,_)      <- ccfg
-                          , (ipkgid, pkgid) <- C18.componentPackageDeps clbi
-                          , not (internal pkgid) ]
-
-    -- Cabal 1.16 and below
-    deps16 :: Either String [InstalledPackageId]
-    deps16 = map fst <$> filter (not . internal . snd) . nub <$> do
-        cbi <- concat <$> sequence [ extract "executableConfigs"
-                                   , extract "testSuiteConfigs"
-                                   , extract "benchmarkConfigs" ]
-                        :: Either String [(String, C16.ComponentLocalBuildInfo)]
-
-        return $ maybe [] C16.componentPackageDeps libraryConfig
-              ++ concatMap (C16.componentPackageDeps . snd) cbi
-     where
-       libraryConfig :: Maybe C16.ComponentLocalBuildInfo
-       libraryConfig = do
-         field <- find ("libraryConfig" `isPrefixOf`) (tails config)
-         clbi <- stripPrefix " = " field
-         if "Nothing" `isPrefixOf` clbi
-             then Nothing
-             else case readMaybe =<< stripPrefix "Just " clbi of
-                    Just x -> x
-                    Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi)
-
-       extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)]
-       extract field = readConfigs field <$> extractField config field
-
-       readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)]
-       readConfigs f s = case readEither s of
-           Right x -> x
-           Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")"
-
--- | Extract the cabal flags from the 'CabalConfig'
-configFlags :: CabalConfig -> Either String FlagAssignment
-configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags"
-
--- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable
--- error message with lots of context on failure.
-extractField :: CabalConfig -> String -> Either String String
-extractField config field =
-    case extractParens <$> find (field `isPrefixOf`) (tails config) of
-        Just f -> Right f
-        Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)

Language/Haskell/GhcMod/Debug.hs

@@ -6,6 +6,7 @@ import Data.Maybe (isJust, fromJust)
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.CabalConfig
 import Language.Haskell.GhcMod.Internal
 
 ----------------------------------------------------------------
@@ -30,9 +31,10 @@ debugInfo = cradle >>= \c -> convert' =<< do
   where
     simpleCompilerOption = options >>= \op ->
         return $ CompilerOptions (ghcUserOptions op) [] []
-    fromCabalFile c = options >>= \opts -> do
+    fromCabalFile crdl = options >>= \opts -> do
-        pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c
+        config <- cabalGetConfig crdl
-        getCompilerOptions (ghcUserOptions opts) c pkgDesc
+        pkgDesc <- parseCabalFile config $ fromJust $ cradleCabalFile crdl
+        getCompilerOptions (ghcUserOptions opts) crdl config pkgDesc
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/Error.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-}
 module Language.Haskell.GhcMod.Error (
     GhcModError(..)
+  , GMConfigStateFileError(..)
+  , GmError
   , gmeDoc
   , modifyError
   , modifyError'
@@ -15,26 +17,81 @@ import Data.Typeable
 import Exception
 import Text.PrettyPrint
 
+type GmError m = MonadError GhcModError m
+
 data GhcModError = GMENoMsg
                  -- ^ Unknown error
+
                  | GMEString String
                  -- ^ Some Error with a message. These are produced mostly by
                  -- 'fail' calls on GhcModT.
+
                  | GMEIOException IOException
                  -- ^ IOExceptions captured by GhcModT's MonadIO instance
+
                  | GMECabalConfigure GhcModError
                  -- ^ Configuring a cabal project failed.
+
                  | GMECabalFlags GhcModError
                  -- ^ Retrieval of the cabal configuration flags failed.
+
                  | GMEProcess [String] GhcModError
                  -- ^ Launching an operating system process failed. The first
                  -- field is the command.
+
                  | GMENoCabalFile
                  -- ^ No cabal file found.
+
                  | GMETooManyCabalFiles [FilePath]
                  -- ^ Too many cabal files found.
+
+                 | GMECabalStateFile GMConfigStateFileError
+                 -- ^ Reading Cabal's state configuration file falied somehow.
                    deriving (Eq,Show,Typeable)
 
+data GMConfigStateFileError
+    = GMConfigStateFileNoHeader
+    | GMConfigStateFileBadHeader
+    | GMConfigStateFileNoParse
+    | GMConfigStateFileMissing
+--    | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
+  deriving (Eq, Show, Read, Typeable)
+
+gmCsfeDoc :: GMConfigStateFileError -> Doc
+gmCsfeDoc GMConfigStateFileNoHeader = text $
+        "Saved package config file header is missing. "
+        ++ "Try re-running the 'configure' command."
+
+gmCsfeDoc GMConfigStateFileBadHeader = text $
+        "Saved package config file header is corrupt. "
+        ++ "Try re-running the 'configure' command."
+
+gmCsfeDoc GMConfigStateFileNoParse = text $
+        "Saved package config file body is corrupt. "
+        ++ "Try re-running the 'configure' command."
+
+gmCsfeDoc GMConfigStateFileMissing = text $
+    "Run the 'configure' command first."
+
+-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $
+--         "You need to re-run the 'configure' command. "
+--         ++ "The version of Cabal being used has changed (was "
+--         ++ display oldCabal ++ ", now "
+--         ++ display currentCabalId ++ ")."
+--         ++ badCompiler
+--       where
+--         badCompiler
+--           | oldCompiler == currentCompilerId = ""
+--           | otherwise =
+--               " Additionally the compiler is different (was "
+--               ++ display oldCompiler ++ ", now "
+--               ++ display currentCompilerId
+--               ++ ") which is probably the cause of the problem."
+
+
+
+
+
 instance Exception GhcModError
 
 instance Error GhcModError where
@@ -61,6 +118,9 @@ gmeDoc e = case e of
     GMETooManyCabalFiles cfs ->
         text $ "Multiple cabal files found. Possible cabal files: \""
                ++ intercalate "\", \"" cfs ++"\"."
+    GMECabalStateFile csfe ->
+        gmCsfeDoc csfe
+
 
 modifyError :: MonadError e m => (e -> e) -> m a -> m a
 modifyError f action = action `catchError` \e -> throwError $ f e

Language/Haskell/GhcMod/Logging.hs

@@ -0,0 +1,21 @@
+module Language.Haskell.GhcMod.Logging where
+
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+
+import Control.Monad.Journal.Class
+import Control.Monad.Trans.Class
+import System.IO
+
+import MonadUtils
+
+--gmSink :: IOish m => (GhcModLog -> IO ()) -> GhcModT m ()
+--gmSink = GhcModT . (lift . lift . sink)
+
+type GmLog m = MonadJournal GhcModLog m
+
+gmJournal :: IOish m => GhcModLog -> GhcModT m ()
+gmJournal = GhcModT . lift . lift . journal
+
+gmLog :: (MonadIO m, MonadJournal GhcModLog m) => String -> m ()
+gmLog str = liftIO (hPutStrLn stderr str) >> (journal $ GhcModLog [str])

Language/Haskell/GhcMod/Monad.hs

@@ -1,9 +1,4 @@
-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
+{-# LANGUAGE CPP, RecordWildCards #-}
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
-{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module Language.Haskell.GhcMod.Monad (
   -- * Monad Types
     GhcModT
@@ -20,41 +15,32 @@ module Language.Haskell.GhcMod.Monad (
   , runGhcModT
   , runGhcModT'
   , hoistGhcModT
-  -- ** Accessing 'GhcModEnv' and 'GhcModState'
+  -- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'
   , gmsGet
   , gmsPut
+  , gmLog
   , options
   , cradle
   , getCompilerMode
   , setCompilerMode
   , withOptions
   , withTempSession
-  , overrideGhcUserOptions
   -- ** Re-exporting convenient stuff
   , liftIO
   , module Control.Monad.Reader.Class
-  , module Control.Monad.Journal.Class
   ) where
 
-#if __GLASGOW_HASKELL__ < 708
--- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
--- classes before ghc 7.8
-#define DIFFERENT_MONADIO 1
-
--- RWST doen't have a MonadIO instance before ghc 7.8
-#define MONADIO_INSTANCES 1
-#endif
-
-
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.CabalApi
+import Language.Haskell.GhcMod.CabalConfig
 import qualified Language.Haskell.GhcMod.Gap as Gap
 
-import DynFlags
 import GHC
 import qualified GHC as G
 import GHC.Paths (libdir)
@@ -69,154 +55,36 @@ import HscTypes
 -- So, RWST automatically becomes an instance of MonadIO.
 import MonadUtils
 
-#if DIFFERENT_MONADIO
-import Control.Monad.Trans.Class (lift)
-import qualified Control.Monad.IO.Class
-import Data.Monoid (Monoid)
-#endif
-
-import Control.Applicative (Alternative)
 import Control.Arrow (first)
-import Control.Monad (MonadPlus, void)
+import Control.Monad (void)
 #if !MIN_VERSION_monad_control(1,0,0)
 import Control.Monad (liftM)
 #endif
-import Control.Monad.Base (MonadBase, liftBase)
+import Control.Monad.Base (liftBase)
 
--- Monad transformer stuff
-import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
-  control, liftBaseOp, liftBaseOp_)
-
-import Control.Monad.Trans.Class
 import Control.Monad.Reader.Class
-import Control.Monad.Writer.Class (MonadWriter)
 import Control.Monad.State.Class (MonadState(..))
 
-import Control.Monad.Error (ErrorT, runErrorT)
+import Control.Monad.Error (runErrorT)
-import Control.Monad.Reader (ReaderT, runReaderT)
+import Control.Monad.Reader (runReaderT)
-import Control.Monad.State.Strict (StateT, runStateT)
+import Control.Monad.State.Strict (runStateT)
-import Control.Monad.Trans.Journal (JournalT, runJournalT)
+import Control.Monad.Trans.Journal (runJournalT)
-#ifdef MONADIO_INSTANCES
-import Control.Monad.Trans.Maybe (MaybeT)
-import Control.Monad.Error (Error(..))
-#endif
-import Control.Monad.Journal.Class
 
 import Data.Maybe (isJust)
-import Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import Data.IORef
 import System.Directory (getCurrentDirectory)
 
 ----------------------------------------------------------------
 
-data GhcModEnv = GhcModEnv {
-      gmGhcSession :: !(IORef HscEnv)
-    , gmOptions    :: Options
-    , gmCradle     :: Cradle
-    }
-
-type GhcModLog = ()
-
-data GhcModState = GhcModState {
-      gmCompilerMode :: CompilerMode
-    } deriving (Eq,Show,Read)
-
-data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
-
-defaultState :: GhcModState
-defaultState = GhcModState Simple
-
-----------------------------------------------------------------
-
--- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'
--- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that
--- means you can run (almost) all functions from the GHC API on top of 'GhcModT'
--- transparently.
---
--- The inner monad @m@ should have instances for 'MonadIO' and
--- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@
--- monads already have 'MonadBaseControl' 'IO' instances, see the
--- @monad-control@ package.
-newtype GhcModT m a = GhcModT {
-      unGhcModT :: StateT GhcModState
-                     (ErrorT GhcModError
-                       (JournalT GhcModLog
-                         (ReaderT GhcModEnv m) ) ) a
-    } deriving ( Functor
-               , Applicative
-               , Alternative
-               , Monad
-               , MonadPlus
-#if DIFFERENT_MONADIO
-               , Control.Monad.IO.Class.MonadIO
-#endif
-               , MonadReader GhcModEnv -- TODO: make MonadReader instance
-                                       -- pass-through like MonadState
-               , MonadWriter w
-               , MonadError GhcModError
-               )
-
-instance MonadIO m => MonadIO (GhcModT m) where
-    liftIO action = do
-      res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action
-      case res of
-        Right a -> return a
-
-        Left e | isIOError e ->
-                   throwError $ GMEIOException (fromEx e :: IOError)
-        Left e | isGhcModError e ->
-                   throwError $ (fromEx e :: GhcModError)
-        Left e -> throw e
-
-     where
-       fromEx :: Exception e => SomeException -> e
-       fromEx se = let Just e = fromException se in e
-       isIOError se =
-           case fromException se of
-             Just (_ :: IOError) -> True
-             Nothing -> False
-
-       isGhcModError se =
-           case fromException se of
-             Just (_ :: GhcModError) -> True
-             Nothing -> False
-
-
-instance MonadTrans (GhcModT) where
-    lift = GhcModT . lift . lift . lift . lift
-
-instance MonadState s m => MonadState s (GhcModT m) where
-    get = GhcModT $ lift $ lift $ lift get
-    put = GhcModT . lift . lift . lift . put
-    state = GhcModT . lift . lift . lift . state
-
-
-#if MONADIO_INSTANCES
-instance MonadIO m => MonadIO (StateT s m) where
-    liftIO = lift . liftIO
-
-instance MonadIO m => MonadIO (ReaderT r m) where
-    liftIO = lift . liftIO
-
-instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where
-    liftIO = lift . liftIO
-
-instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
-    liftIO = lift . liftIO
-
-instance MonadIO m => MonadIO (MaybeT m) where
-    liftIO = lift . liftIO
-#endif
-
-----------------------------------------------------------------
-
 -- | Initialize the 'DynFlags' relating to the compilation of a single
 -- file or GHC session according to the 'Cradle' and 'Options'
 -- provided.
-initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m)
+initializeFlagsWithCradle :: (IOish m, GhcMonad m, GmError m, GmLog m)
         => Options
         -> Cradle
+        -> CabalConfig
         -> m ()
-initializeFlagsWithCradle opt c
+initializeFlagsWithCradle opt c config
   | cabal     = withCabal
   | otherwise = withSandbox
   where
@@ -228,8 +96,8 @@ initializeFlagsWithCradle opt c
 
     withCabal = do
         let Just cabalFile = mCabalFile
-        pkgDesc <- parseCabalFile c cabalFile
+        pkgDesc <- parseCabalFile config cabalFile
-        compOpts <- getCompilerOptions ghcopts c pkgDesc
+        compOpts <- getCompilerOptions ghcopts c config pkgDesc
         initSession CabalPkg opt compOpts
 
     withSandbox = initSession SingleFile opt compOpts
@@ -283,8 +151,9 @@ runGhcModT opt action = gbracket newEnv delEnv $ \env -> do
     r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
         dflags <- getSessionDynFlags
         defaultCleanupHandler dflags $ do
-            initializeFlagsWithCradle opt (gmCradle env)
+            config <- cabalGetConfig =<< cradle
-            action)
+            initializeFlagsWithCradle opt (gmCradle env) config
+            action )
     return r
 
  where
@@ -298,7 +167,7 @@ hoistGhcModT :: IOish m
              => (Either GhcModError a, GhcModLog)
              -> GhcModT m a
 hoistGhcModT (r,l) = do
-  GhcModT (lift $ lift $ journal l) >> case r of
+  gmJournal l >> case r of
     Left e -> throwError e
     Right a -> return a
 
@@ -328,18 +197,6 @@ withTempSession action = do
   liftIO $ writeIORef session savedHscEnv
   return a
 
--- | This is a very ugly workaround don't use it.
-overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b
-overrideGhcUserOptions action = withTempSession $ do
-  env <- ask
-  opt <- options
-  let ghcOpts = ghcUserOptions opt
-      opt' = opt { ghcUserOptions = [] }
-
-  initializeFlagsWithCradle opt' (gmCradle env)
-
-  action ghcOpts
-
 ----------------------------------------------------------------
 
 gmeAsk :: IOish m => GhcModT m GhcModEnv
@@ -373,113 +230,3 @@ withOptions changeOpt action = local changeEnv action
         opt = gmOptions e
 
 ----------------------------------------------------------------
-
-instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
-    liftBase = GhcModT . liftBase
-
-#if MIN_VERSION_monad_control(1,0,0)
-
-instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
-    type StM (GhcModT m) a =
-          StM (StateT GhcModState
-                (ErrorT GhcModError
-                  (JournalT GhcModLog
-                    (ReaderT GhcModEnv m) ) ) ) a
-    liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
-        f $ runInBase . unGhcModT
-
-    restoreM = GhcModT . restoreM
-    {-# INLINE liftBaseWith #-}
-    {-# INLINE restoreM #-}
-
-#else
-
-instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
-    newtype StM (GhcModT m) a = StGhcMod {
-          unStGhcMod :: StM (StateT GhcModState
-                              (ErrorT GhcModError
-                                (JournalT GhcModLog
-                                  (ReaderT GhcModEnv m) ) ) ) a }
-    liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
-        f $ liftM StGhcMod . runInBase . unGhcModT
-
-    restoreM = GhcModT . restoreM . unStGhcMod
-    {-# INLINE liftBaseWith #-}
-    {-# INLINE restoreM #-}
-
-#endif
-
--- GHC cannot prove the following instances to be decidable automatically using
--- the FlexibleContexts extension as they violate the second Paterson Condition,
--- namely that: The assertion has fewer constructors and variables (taken
--- together and counting repetitions) than the head. Specifically the
--- @MonadBaseControl IO m@ constraint is causing this violation.
---
--- Proof of termination:
---
--- Assuming all constraints containing the variable `m' exist and are decidable
--- we show termination by manually replacing the current set of constraints with
--- their own set of constraints and show that this, after a finite number of
--- steps, results in the empty set, i.e. not having to check any more
--- constraints.
---
--- We start by setting the constraints to be those immediate constraints of the
--- instance declaration which cannot be proven decidable automatically for the
--- type under consideration.
---
--- @
--- { MonadBaseControl IO m }
--- @
---
--- Classes used:
---
--- * @class MonadBase b m => MonadBaseControl b m@
---
--- @
--- { MonadBase IO m }
--- @
---
--- Classes used:
---
--- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@
---
--- @
--- { Applicative IO, Applicative m, Monad IO, Monad m }
--- @
---
--- Classes used:
---
--- * @class Monad m@
--- * @class Applicative f => Functor f@
---
--- @
--- { Functor m }
--- @
---
--- Classes used:
---
--- * @class Functor f@
---
--- @
--- { }
--- @
--- ∎
-
-instance (Functor m, MonadIO m, MonadBaseControl IO m)
-      => GhcMonad (GhcModT m) where
-    getSession = (liftIO . readIORef) . gmGhcSession =<< ask
-    setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask
-
-#if __GLASGOW_HASKELL__ >= 706
-instance (Functor m, MonadIO m, MonadBaseControl IO m)
-      => HasDynFlags (GhcModT m) where
-    getDynFlags = getSessionDynFlags
-#endif
-
-instance (MonadIO m, MonadBaseControl IO m)
-      => ExceptionMonad (GhcModT m) where
-    gcatch act handler = control $ \run ->
-        run act `gcatch` (run . handler)
-
-    gmask = liftBaseOp gmask . liftRestore
-     where liftRestore f r = f $ liftBaseOp_ r

Language/Haskell/GhcMod/Monad/Types.hs

@@ -0,0 +1,288 @@
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
+{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Language.Haskell.GhcMod.Monad.Types where
+
+
+#if __GLASGOW_HASKELL__ < 708
+-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
+-- classes before ghc 7.8
+#define DIFFERENT_MONADIO 1
+
+-- RWST doen't have a MonadIO instance before ghc 7.8
+#define MONADIO_INSTANCES 1
+#endif
+
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Error
+
+import GHC
+import DynFlags
+import GhcMonad hiding (withTempSession)
+#if __GLASGOW_HASKELL__ <= 702
+import HscTypes
+#endif
+
+-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
+-- RWST does not automatically become an instance of MonadIO.
+-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
+-- So, RWST automatically becomes an instance of MonadIO.
+import MonadUtils
+
+import Control.Applicative (Alternative)
+import Control.Monad (MonadPlus)
+import Control.Monad.Error (ErrorT)
+import Control.Monad.Reader (ReaderT)
+import Control.Monad.State.Strict (StateT)
+import Control.Monad.Trans.Journal (JournalT)
+
+import Control.Monad.Base (MonadBase, liftBase)
+import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
+  control, liftBaseOp, liftBaseOp_)
+
+import Control.Monad.Trans.Class
+import Control.Monad.Reader.Class
+import Control.Monad.Writer.Class (MonadWriter)
+import Control.Monad.State.Class (MonadState(..))
+import Control.Monad.Journal.Class (MonadJournal(..))
+
+#ifdef MONADIO_INSTANCES
+import Control.Monad.Trans.Maybe (MaybeT)
+import Control.Monad.Error (Error(..))
+#endif
+
+#if DIFFERENT_MONADIO
+import Control.Monad.Trans.Class (lift)
+import qualified Control.Monad.IO.Class
+import Data.Monoid (Monoid)
+#endif
+
+#if !MIN_VERSION_monad_control(1,0,0)
+import Control.Monad (liftM)
+#endif
+
+import Data.Monoid
+import Data.IORef
+
+data GhcModEnv = GhcModEnv {
+      gmGhcSession :: !(IORef HscEnv)
+    , gmOptions    :: Options
+    , gmCradle     :: Cradle
+    }
+
+data GhcModLog = GhcModLog {
+      gmLogMessages :: [String]
+    } deriving (Eq, Show, Read)
+
+instance Monoid GhcModLog where
+    mempty = GhcModLog mempty
+    GhcModLog a `mappend` GhcModLog b = GhcModLog (a `mappend` b)
+
+data GhcModState = GhcModState {
+      gmCompilerMode :: CompilerMode
+    } deriving (Eq,Show,Read)
+
+data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
+
+defaultState :: GhcModState
+defaultState = GhcModState Simple
+
+----------------------------------------------------------------
+
+-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'
+-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that
+-- means you can run (almost) all functions from the GHC API on top of 'GhcModT'
+-- transparently.
+--
+-- The inner monad @m@ should have instances for 'MonadIO' and
+-- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@
+-- monads already have 'MonadBaseControl' 'IO' instances, see the
+-- @monad-control@ package.
+newtype GhcModT m a = GhcModT {
+      unGhcModT :: StateT GhcModState
+                     (ErrorT GhcModError
+                       (JournalT GhcModLog
+                         (ReaderT GhcModEnv m) ) ) a
+    } deriving ( Functor
+               , Applicative
+               , Alternative
+               , Monad
+               , MonadPlus
+#if DIFFERENT_MONADIO
+               , Control.Monad.IO.Class.MonadIO
+#endif
+               , MonadReader GhcModEnv -- TODO: make MonadReader instance
+                                       -- pass-through like MonadState
+               , MonadWriter w
+               , MonadError GhcModError
+               )
+
+instance MonadIO m => MonadIO (GhcModT m) where
+    liftIO action = do
+      res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action
+      case res of
+        Right a -> return a
+
+        Left e | isIOError e ->
+                   throwError $ GMEIOException (fromEx e :: IOError)
+        Left e | isGhcModError e ->
+                   throwError $ (fromEx e :: GhcModError)
+        Left e -> throw e
+
+     where
+       fromEx :: Exception e => SomeException -> e
+       fromEx se = let Just e = fromException se in e
+
+       isIOError se =
+           case fromException se of
+             Just (_ :: IOError) -> True
+             Nothing -> False
+
+       isGhcModError se =
+           case fromException se of
+             Just (_ :: GhcModError) -> True
+             Nothing -> False
+
+instance (Monad m) => MonadJournal GhcModLog (GhcModT m) where
+  journal !w = GhcModT $ lift $ lift $ (journal w)
+  history    = GhcModT $ lift $ lift $ history
+  clear      = GhcModT $ lift $ lift $ clear
+
+instance MonadTrans GhcModT where
+    lift = GhcModT . lift . lift . lift . lift
+
+instance MonadState s m => MonadState s (GhcModT m) where
+    get = GhcModT $ lift $ lift $ lift get
+    put = GhcModT . lift . lift . lift . put
+    state = GhcModT . lift . lift . lift . state
+
+#if MONADIO_INSTANCES
+instance MonadIO m => MonadIO (StateT s m) where
+    liftIO = lift . liftIO
+
+instance MonadIO m => MonadIO (ReaderT r m) where
+    liftIO = lift . liftIO
+
+instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where
+    liftIO = lift . liftIO
+
+instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
+    liftIO = lift . liftIO
+
+instance MonadIO m => MonadIO (MaybeT m) where
+    liftIO = lift . liftIO
+#endif
+
+
+instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
+    liftBase = GhcModT . liftBase
+
+#if MIN_VERSION_monad_control(1,0,0)
+
+instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
+    type StM (GhcModT m) a =
+          StM (StateT GhcModState
+                (ErrorT GhcModError
+                  (JournalT GhcModLog
+                    (ReaderT GhcModEnv m) ) ) ) a
+    liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
+        f $ runInBase . unGhcModT
+
+    restoreM = GhcModT . restoreM
+    {-# INLINE liftBaseWith #-}
+    {-# INLINE restoreM #-}
+
+#else
+
+instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
+    newtype StM (GhcModT m) a = StGhcMod {
+          unStGhcMod :: StM (StateT GhcModState
+                              (ErrorT GhcModError
+                                (JournalT GhcModLog
+                                  (ReaderT GhcModEnv m) ) ) ) a }
+    liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
+        f $ liftM StGhcMod . runInBase . unGhcModT
+
+    restoreM = GhcModT . restoreM . unStGhcMod
+    {-# INLINE liftBaseWith #-}
+    {-# INLINE restoreM #-}
+
+#endif
+
+-- GHC cannot prove the following instances to be decidable automatically using
+-- the FlexibleContexts extension as they violate the second Paterson Condition,
+-- namely that: The assertion has fewer constructors and variables (taken
+-- together and counting repetitions) than the head. Specifically the
+-- @MonadBaseControl IO m@ constraint is causing this violation.
+--
+-- Proof of termination:
+--
+-- Assuming all constraints containing the variable `m' exist and are decidable
+-- we show termination by manually replacing the current set of constraints with
+-- their own set of constraints and show that this, after a finite number of
+-- steps, results in the empty set, i.e. not having to check any more
+-- constraints.
+--
+-- We start by setting the constraints to be those immediate constraints of the
+-- instance declaration which cannot be proven decidable automatically for the
+-- type under consideration.
+--
+-- @
+-- { MonadBaseControl IO m }
+-- @
+--
+-- Classes used:
+--
+-- * @class MonadBase b m => MonadBaseControl b m@
+--
+-- @
+-- { MonadBase IO m }
+-- @
+--
+-- Classes used:
+--
+-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@
+--
+-- @
+-- { Applicative IO, Applicative m, Monad IO, Monad m }
+-- @
+--
+-- Classes used:
+--
+-- * @class Monad m@
+-- * @class Applicative f => Functor f@
+--
+-- @
+-- { Functor m }
+-- @
+--
+-- Classes used:
+--
+-- * @class Functor f@
+--
+-- @
+-- { }
+-- @
+-- ∎
+
+instance (Functor m, MonadIO m, MonadBaseControl IO m)
+      => GhcMonad (GhcModT m) where
+    getSession = (liftIO . readIORef) . gmGhcSession =<< ask
+    setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask
+
+#if __GLASGOW_HASKELL__ >= 706
+instance (Functor m, MonadIO m, MonadBaseControl IO m)
+      => HasDynFlags (GhcModT m) where
+    getDynFlags = getSessionDynFlags
+#endif
+
+instance (MonadIO m, MonadBaseControl IO m)
+      => ExceptionMonad (GhcModT m) where
+    gcatch act handler = control $ \run ->
+        run act `gcatch` (run . handler)
+
+    gmask = liftBaseOp gmask . liftRestore
+     where liftRestore f r = f $ liftBaseOp_ r

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -1,14 +1,15 @@
 {-# LANGUAGE BangPatterns, TupleSections #-}
 module Language.Haskell.GhcMod.PathsAndFiles where
 
-import Config (cProjectVersion, cTargetPlatformString)
+import Config (cProjectVersion)
 import Control.Applicative
 import Control.Monad
 import Data.List
-import Data.List.Split (splitOn)
 import Data.Char
 import Data.Maybe
 import Data.Traversable (traverse)
+import Distribution.System (buildPlatform)
+import Distribution.Text (display)
 import Language.Haskell.GhcMod.Types
 import System.Directory
 import System.FilePath
@@ -88,7 +89,6 @@ findCabalSandboxDir dir = do
  where
    isSandboxConfig = (=="cabal.sandbox.config")
 
-
 appendDir :: DirPath -> [FileName] -> [FilePath]
 appendDir d fs = (d </>) `map` fs
 
@@ -164,6 +164,10 @@ ghcSandboxPkgDbDir =
 packageCache :: String
 packageCache = "package.cache"
 
+-- | Filename of the show'ed Cabal setup-config cache
+prettyConfigCache :: FilePath
+prettyConfigCache = setupConfigPath <.> "ghc-mod-0.pretty-cabal-cache"
+
 -- | Filename of the symbol table cache file.
 symbolCache :: Cradle -> FilePath
 symbolCache crdl = cradleTempDir crdl </> symbolCacheFile

Language/Haskell/GhcMod/World.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards, CPP #-}
 module Language.Haskell.GhcMod.World where
 {-(
   , World
@@ -12,7 +12,8 @@ import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 
-import Control.Applicative (pure,(<$>),(<*>))
+import Control.Applicative (pure, (<$>), (<*>))
+import Control.Monad
 import Data.Maybe
 import Data.Traversable (traverse)
 import System.Directory (getModificationTime)
@@ -45,6 +46,8 @@ data World = World {
     worldPackageCaches :: [TimedFile]
   , worldCabalFile     :: Maybe TimedFile
   , worldCabalConfig   :: Maybe TimedFile
+  , worldSymbolCache   :: Maybe TimedFile
+  , worldPrettyCabalConfigCache :: Maybe TimedFile
   } deriving (Eq, Show)
 
 timedPackageCache :: Cradle -> IO [TimedFile]
@@ -57,15 +60,23 @@ getCurrentWorld :: Cradle -> IO World
 getCurrentWorld crdl = do
     pkgCaches    <- timedPackageCache crdl
     mCabalFile   <- timeFile `traverse` cradleCabalFile crdl
-    mSetupConfig <- mightExist (setupConfigFile crdl)
+    mCabalConfig <- timeMaybe (setupConfigFile crdl)
-    mCabalConfig <- timeFile `traverse` mSetupConfig
+    mSymbolCache <- timeMaybe (symbolCache crdl)
+    mPrettyConfigCache <- timeMaybe prettyConfigCache
 
     return World {
         worldPackageCaches = pkgCaches
       , worldCabalFile     = mCabalFile
       , worldCabalConfig   = mCabalConfig
+      , worldSymbolCache   = mSymbolCache
+      , worldPrettyCabalConfigCache = mPrettyConfigCache
       }
 
+ where
+   timeMaybe :: FilePath -> IO (Maybe TimedFile)
+   timeMaybe f = do
+     join $ (timeFile `traverse`) <$> mightExist f
+
 didWorldChange :: World -> Cradle -> IO Bool
 didWorldChange world crdl = do
     (world /=) <$> getCurrentWorld crdl
@@ -83,7 +94,11 @@ didWorldChange world crdl = do
 --
 -- * Both files exist
 --   @Just cc < Just cf = cc < cf = cc `olderThan` cf@
-isSetupConfigOutOfDate :: Cradle -> IO Bool
+isSetupConfigOutOfDate :: World -> Bool
-isSetupConfigOutOfDate crdl = do
+isSetupConfigOutOfDate World {..} = do
-  world <- getCurrentWorld crdl
+  worldCabalConfig < worldCabalFile
-  return $ worldCabalConfig world < worldCabalFile world
+
+isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
+isYoungerThanSetupConfig file World {..} = do
+  tfile <- timeFile file
+  return $ worldCabalConfig < Just tfile

Setup.hs

@@ -130,7 +130,7 @@ sanityCheckCabalVersions args cf desc lbi = do
         minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10")
 
   when minGhc710 $ do
-    let cabalHelperCabalVer = compCabalVer CLibName
+    let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper")
 
     when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $
          failCabalVersionDifferent cabalVer cabalHelperCabalVer

ghc-mod.cabal

@@ -66,11 +66,13 @@ Library
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   Exposed-Modules:      Language.Haskell.GhcMod
                         Language.Haskell.GhcMod.Internal
-  Other-Modules:        Language.Haskell.GhcMod.Boot
+  Other-Modules:        Paths_ghc_mod
+                        Language.Haskell.GhcMod.Boot
                         Language.Haskell.GhcMod.Browse
                         Language.Haskell.GhcMod.CabalConfig.Cabal16
                         Language.Haskell.GhcMod.CabalConfig.Cabal18
-                        Language.Haskell.GhcMod.CabalConfig.Cabal21
+                        Language.Haskell.GhcMod.CabalConfig.Cabal22
+                        Language.Haskell.GhcMod.CabalConfig.Extract
                         Language.Haskell.GhcMod.CabalConfig
                         Language.Haskell.GhcMod.CabalApi
                         Language.Haskell.GhcMod.CaseSplit
@@ -91,8 +93,10 @@ Library
                         Language.Haskell.GhcMod.Lang
                         Language.Haskell.GhcMod.Lint
                         Language.Haskell.GhcMod.Logger
+                        Language.Haskell.GhcMod.Logging
                         Language.Haskell.GhcMod.Modules
                         Language.Haskell.GhcMod.Monad
+                        Language.Haskell.GhcMod.Monad.Types
                         Language.Haskell.GhcMod.PathsAndFiles
                         Language.Haskell.GhcMod.PkgDoc
                         Language.Haskell.GhcMod.Read
@@ -102,13 +106,9 @@ Library
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.World
 
-  if impl(ghc >= 7.10)
-    Other-Modules:      Language.Haskell.GhcMod.CabalConfig.Ghc710
-  else
-    Other-Modules:      Language.Haskell.GhcMod.CabalConfig.PreGhc710
-
 
   Build-Depends:        base >= 4.0 && < 5
+                      , bytestring
                       , containers
                       , deepseq
                       , directory