Refactoring to use cabal-helper-wrapper

This turned out to be quite involved but save for this huge commit it's
actually quite awesome and squashes quite a few bugs and nasty
problems (hopefully). Most importantly we now have native cabal
component support without the user having to do anything to get it!

To do this we traverse imports starting from each component's
entrypoints (library modules or Main source file for executables) and
use this information to find which component's options each module will
build with. Under the assumption that these modules have to build with
every component they're used in we can now just pick one.

Quite a few internal assumptions have been invalidated by this
change. Most importantly the runGhcModT* family of cuntions now change
the current working directory to `cradleRootDir`.

Language/Haskell/GhcMod.hs

@@ -9,6 +9,11 @@ module Language.Haskell.GhcMod (
   , LineSeparator(..)
   , OutputStyle(..)
   , defaultOptions
+  -- * Logging
+  , GmLogLevel
+  , increaseLogLevel
+  , gmSetLogLevel
+  , gmLog
   -- * Types
   , ModuleString
   , Expression
@@ -61,7 +66,8 @@ import Language.Haskell.GhcMod.Flag
 import Language.Haskell.GhcMod.Info
 import Language.Haskell.GhcMod.Lang
 import Language.Haskell.GhcMod.Lint
-import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Modules
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.PkgDoc
 import Language.Haskell.GhcMod.Types

Language/Haskell/GhcMod/Browse.hs

@@ -4,52 +4,54 @@ module Language.Haskell.GhcMod.Browse (
 
 import Control.Applicative ((<$>))
 import Control.Exception (SomeException(..))
-import Data.Char (isAlpha)
+import Data.Char
-import Data.List (sort)
+import Data.List
-import Data.Maybe (catMaybes)
+import Data.Maybe
-import Exception (ghandle)
+import FastString
-import FastString (mkFastString)
+import GHC
-import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
 import Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Monad (GhcModT, options)
+import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Target (setTargetFiles)
 import Language.Haskell.GhcMod.Types
 import Name (getOccString)
-import Outputable (ppr, Outputable)
+import Outputable
 import TyCon (isAlgTyCon)
 import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
+import Exception (ExceptionMonad, ghandle)
 
 ----------------------------------------------------------------
 
 -- | Getting functions, classes, etc from a module.
 --   If 'detailed' is 'True', their types are also obtained.
 --   If 'operators' is 'True', operators are also returned.
-browse :: IOish m
+browse :: forall m. IOish m
        => ModuleString -- ^ A module name. (e.g. \"Data.List\")
        -> GhcModT m String
-browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
+browse pkgmdl = do
+    convert' . sort =<< go
   where
+    -- TODO: Add API to Gm.Target to check if module is home module without
+    -- bringing up a GHC session as well then this can be made a lot cleaner
+    go = ghandle (\(SomeException _) -> return []) $ do
+      goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)
+
+    goPkgModule = do
+      opt <- options
+      runGmPkgGhc $
+        processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid
+
+    goHomeModule = runGmLoadedT [Right mdlname] $ do
+      opt <- options
+      processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing
+
+    tryModuleInfo m = fromJust <$> G.getModuleInfo m
+
     (mpkg,mdl) = splitPkgMdl pkgmdl
     mdlname = G.mkModuleName mdl
     mpkgid = mkFastString <$> mpkg
-    listExports Nothing       = return []
+
-    listExports (Just mdinfo) = processExports mdinfo
-    -- findModule works only for package modules, moreover,
-    -- you cannot load a package module. On the other hand,
-    -- to browse a local module you need to load it first.
-    -- If CmdLineError is signalled, we assume the user
-    -- tried browsing a local module.
-    getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler
-    browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo
-    browseLocalModule = ghandle handler $ do
-      setTargetFiles [mdl]
-      G.findModule mdlname Nothing >>= G.getModuleInfo
-    fallback (CmdLineError _) = browseLocalModule
-    fallback _                = return Nothing
-    handler (SomeException _) = return Nothing
 -- |
 --
 -- >>> splitPkgMdl "base:Prelude"
@@ -71,22 +73,23 @@ isNotOp :: String -> Bool
 isNotOp (h:_) = isAlpha h || (h == '_')
 isNotOp _ = error "isNotOp"
 
-processExports :: IOish m => ModuleInfo -> GhcModT m [String]
+processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
-processExports minfo = do
+               => Options -> ModuleInfo -> m [String]
-  opt <- options
+processExports opt minfo = do
   let
     removeOps
       | operators opt = id
       | otherwise = filter (isNotOp . getOccString)
   mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
 
-showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String
+showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)
+           => Options -> ModuleInfo -> Name -> m String
 showExport opt minfo e = do
   mtype' <- mtype
   return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
   where
     mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt
-    mtype :: IOish m => GhcModT m (Maybe String)
+    mtype :: m (Maybe String)
     mtype
       | detailed opt = do
         tyInfo <- G.modInfoLookupName minfo e
@@ -101,8 +104,9 @@ showExport opt minfo e = do
       | null nm    = error "formatOp"
       | isNotOp nm = nm
       | otherwise  = "(" ++ nm ++ ")"
-    inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing)
+    inOtherModule :: Name -> m (Maybe TyThing)
-    inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
+    inOtherModule nm = do
+      G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
     justIf :: a -> Bool -> Maybe a
     justIf x True = Just x
     justIf _ False = Nothing

Language/Haskell/GhcMod/CabalApi.hs

@@ -1,144 +0,0 @@
-{-# LANGUAGE OverloadedStrings, CPP #-}
-
-module Language.Haskell.GhcMod.CabalApi (
-    getCompilerOptions
-  , parseCabalFile
-  , cabalAllBuildInfo
-  , cabalSourceDirs
-  , cabalConfigDependencies
-  ) where
-
-import Language.Haskell.GhcMod.CabalConfig
-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 ((<$>))
-import qualified Control.Exception as E
-import Data.Maybe (maybeToList)
-import Data.Set (fromList, toList)
-import Distribution.Package (PackageName(PackageName))
-import qualified Distribution.Package as C
-import Distribution.PackageDescription (PackageDescription, BuildInfo)
-import qualified Distribution.PackageDescription as P
-import Distribution.PackageDescription.Configuration (finalizePackageDescription)
-import Distribution.PackageDescription.Parse (readPackageDescription)
-import Distribution.Simple.Program as C (ghcProgram)
-import Distribution.Simple.Program.Types (programName, programFindVersion)
-import Distribution.System (buildPlatform)
-import Distribution.Text (display)
-import Distribution.Verbosity (silent)
-import Distribution.Version (Version)
-import System.Directory (doesFileExist)
-import System.FilePath ((</>))
-----------------------------------------------------------------
-
--- | Getting necessary 'CompilerOptions' from three information sources.
-getCompilerOptions :: (IOish m, GmError m, GmLog m)
-                   => [GHCOption]
-                   -> Cradle
-                   -> CabalConfig
-                   -> PackageDescription
-                   -> m CompilerOptions
-getCompilerOptions ghcopts cradle config pkgDesc = do
-    gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos
-    let depPkgs = cabalConfigDependencies config (C.packageId pkgDesc)
-    return $ CompilerOptions gopts idirs depPkgs
-  where
-    wdir       = cradleCurrentDir cradle
-    rdir       = cradleRootDir    cradle
-    buildInfos = cabalAllBuildInfo pkgDesc
-    idirs      = includeDirectories rdir wdir $ cabalSourceDirs buildInfos
-
-----------------------------------------------------------------
--- Include directories for modules
-
-cabalBuildDirs :: [FilePath]
-cabalBuildDirs = ["dist/build", "dist/build/autogen"]
-
-includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]
-includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
-  where
-    extdirs = map expand $ dirs ++ cabalBuildDirs
-    expand "."    = cdir
-    expand subdir = cdir </> subdir
-
-----------------------------------------------------------------
-
--- | Parse a cabal file and return a 'PackageDescription'.
-parseCabalFile :: (IOish m, GmError m, GmLog m)
-               => CabalConfig
-               -> FilePath
-               -> m PackageDescription
-parseCabalFile  config file = do
-    cid <- mkGHCCompilerId <$> liftIO getGHCVersion
-    epgd <- liftIO $ readPackageDescription silent file
-    flags <- cabalConfigFlags config
-    case toPkgDesc cid flags epgd of
-        Left deps    -> fail $ show deps ++ " are not installed"
-        Right (pd,_) -> if nullPkg pd
-                        then fail $ file ++ " is broken"
-                        else return pd
-  where
-    toPkgDesc cid flags =
-        finalizePackageDescription flags (const True) buildPlatform cid []
-    nullPkg pd = name == ""
-      where
-        PackageName name = C.pkgName (P.package pd)
-
-getGHCVersion :: IO Version
-getGHCVersion = do
-    mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram)
-    case mv of
-      -- TODO: MonadError it up
-        Nothing -> E.throwIO $ userError "ghc not found"
-        Just v  -> return v
-
-----------------------------------------------------------------
-
-getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]
-getGHCOptions ghcopts cradle rdir binfo = do
-    cabalCpp <- cabalCppOptions rdir
-    let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp
-    return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps
-  where
-    pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle
-    lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo
-    libDirs = map ("-L" ++) $ P.extraLibDirs binfo
-    exts = map (("-X" ++) . display) $ P.usedExtensions binfo
-    libs = map ("-l" ++) $ P.extraLibs binfo
-
-cabalCppOptions :: FilePath -> IO [String]
-cabalCppOptions dir = do
-    exist <- doesFileExist cabalMacro
-    return $ if exist then
-        ["-include", cabalMacro]
-      else
-        []
-  where
-    cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"
-
-----------------------------------------------------------------
-
--- | Extracting all 'BuildInfo' for libraries, executables, and tests.
-cabalAllBuildInfo :: PackageDescription -> [BuildInfo]
-cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI
-  where
-    libBI   = map P.libBuildInfo       $ maybeToList $ P.library pd
-    execBI  = map P.buildInfo          $ P.executables pd
-    testBI  = map P.testBuildInfo      $ P.testSuites pd
-    benchBI = benchmarkBuildInfo pd
-
-----------------------------------------------------------------
-
--- | Extracting include directories for modules.
-cabalSourceDirs :: [BuildInfo] -> [IncludeDir]
-cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis
-
-----------------------------------------------------------------
-
-uniqueAndSort :: [String] -> [String]
-uniqueAndSort = toList . fromList

Language/Haskell/GhcMod/CabalConfig.hs

@@ -1,35 +0,0 @@
-{-# LANGUAGE CPP #-}
-
--- | This module abstracts extracting information from Cabal's on-disk
--- 'LocalBuildInfo' (@dist/setup-config@) for different version combinations of
--- Cabal and GHC.
-module Language.Haskell.GhcMod.CabalConfig (
-    CabalConfig
-  , cabalGetConfig
-  , cabalConfigDependencies
-  , cabalConfigFlags
-  ) where
-
-import Distribution.Package (PackageIdentifier)
-import Distribution.PackageDescription (FlagAssignment)
-
-import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Error
-
-import Language.Haskell.GhcMod.CabalConfig.Extract
-
-cabalGetConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig
-cabalGetConfig = getConfig
-
--- | Get list of 'Package's needed by all components of the current package
-cabalConfigDependencies :: CabalConfig -> PackageIdentifier -> [Package]
-cabalConfigDependencies config thisPkg =
-    configDependencies thisPkg config
-
-
--- | Get the flag assignment from the local build info of the given cradle
-cabalConfigFlags :: (IOish m, GmError m) => CabalConfig -> m FlagAssignment
-cabalConfigFlags config = do
-  case configFlags config of
-    Right x  -> return x
-    Left msg -> throwError (GMECabalFlags (GMEString msg))

Language/Haskell/GhcMod/CabalConfig/Cabal16.hs

@@ -1,45 +0,0 @@
--- Copyright   :  Isaac Jones 2003-2004
-{- 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.16
-module Language.Haskell.GhcMod.CabalConfig.Cabal16 (
-    ComponentLocalBuildInfo
-  , componentPackageDeps
-  ) where
-
-import Distribution.Package (InstalledPackageId, PackageIdentifier)
-
--- From Cabal <= 1.16
-data ComponentLocalBuildInfo = ComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageIdentifier)]
-  }
-  deriving (Read, Show)

Language/Haskell/GhcMod/CabalConfig/Cabal18.hs

@@ -1,58 +0,0 @@
--- Copyright   :  Isaac Jones 2003-2004
-{- 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.18
-module Language.Haskell.GhcMod.CabalConfig.Cabal18 (
-    ComponentLocalBuildInfo
-  , componentPackageDeps
-  , componentLibraries
-  ) where
-
-import Distribution.Package (InstalledPackageId, PackageId)
-
-data LibraryName = LibraryName String
-    deriving (Read, Show)
-
-data ComponentLocalBuildInfo
-  = LibComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageId)],
-    componentLibraries :: [LibraryName]
-  }
-  | ExeComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageId)]
-  }
-  | TestComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageId)]
-  }
-  | BenchComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageId)]
-  }
-  deriving (Read, Show)

Language/Haskell/GhcMod/CabalConfig/Cabal21.hs

@@ -1,73 +0,0 @@
--- Copyright   :  Isaac Jones 2003-2004
-{- 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.21
-module Language.Haskell.GhcMod.CabalConfig.Cabal21 (
-    ComponentLocalBuildInfo
-  , PackageIdentifier(..)
-  , PackageName(..)
-  , componentPackageDeps
-  , componentLibraries
-  ) where
-
-import Distribution.Package (InstalledPackageId)
-import Data.Version (Version)
-
-data LibraryName = LibraryName String
-    deriving (Read, Show)
-
-newtype PackageName = PackageName { unPackageName :: String }
-  deriving (Read, Show)
-
-data PackageIdentifier
-  = PackageIdentifier {
-    pkgName :: PackageName,
-    pkgVersion :: Version
-  }
-  deriving (Read, Show)
-
-type PackageId = PackageIdentifier
-
-data ComponentLocalBuildInfo
-  = LibComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageId)],
-    componentLibraries :: [LibraryName]
-  }
-  | ExeComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageId)]
-  }
-  | TestComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageId)]
-  }
-  | BenchComponentLocalBuildInfo {
-    componentPackageDeps :: [(InstalledPackageId, PackageId)]
-  }
-  deriving (Read, Show)

Language/Haskell/GhcMod/CabalConfig/Cabal22.hs

@@ -1,107 +0,0 @@
-{-# 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

@@ -1,223 +0,0 @@
-{-# 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

@@ -1,49 +0,0 @@
-module Language.Haskell.GhcMod.CabalConfig.Ghc710 (
-    configDependencies
-  , configFlags
-  , getConfig
-  ) where
-
-import Control.Monad
-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, externalPackageDeps)
-import qualified Distribution.Simple.LocalBuildInfo as LBI
-import Distribution.Simple.Configure (getConfigStateFile)
-import Distribution.Simple.Setup (configConfigurationsFlags)
-import Distribution.PackageDescription (FlagAssignment)
-
-import MonadUtils (liftIO)
-
-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
-
-
--- | 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 LocalBuildInfo
-getConfig cradle = liftIO (getCurrentWorld cradle) >>= \world -> do
-    when (isSetupConfigOutOfDate world) configure
-    liftIO (getConfigStateFile file) `tryFix` \_ ->
-        configure `modifyError'` GMECabalConfigure
- where
-   file = setupConfigFile cradle
-   prjDir = cradleRootDir cradle
-
-   configure :: (IOish m, GmError m) => m ()
-   configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
-
-configDependencies :: a -> LocalBuildInfo -> [Package]
-configDependencies _ lbi =
-  [ fromInstalledPackageId instPkgId
-  | (instPkgId, _) <- externalPackageDeps lbi ]
-
-
-configFlags :: LocalBuildInfo -> Either String FlagAssignment
-configFlags = Right . configConfigurationsFlags . LBI.configFlags

Language/Haskell/GhcMod/CabalHelper.hs

@@ -0,0 +1,104 @@
+-- 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 Language.Haskell.GhcMod.CabalHelper (
+    CabalHelper(..)
+  , getComponents
+  , getGhcOptions
+  , getGhcPkgOptions
+  , cabalHelper
+  ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+import Data.List
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Error
+import Language.Haskell.GhcMod.Utils
+import Language.Haskell.GhcMod.World
+import Language.Haskell.GhcMod.PathsAndFiles
+import System.FilePath
+
+-- | Only package related GHC options, sufficient for things that don't need to
+-- access home modules
+getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
+getGhcPkgOptions = chGhcPkgOptions `liftM` cabalHelper
+
+getGhcOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
+getGhcOptions = chGhcOptions `liftM` cabalHelper
+
+-- | Primary interface to cabal-helper and intended single entrypoint to
+-- constructing 'GmComponent's
+--
+-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
+-- 'resolveGmComponents'.
+getComponents :: (MonadIO m, GmEnv m)
+    => m [GmComponent (Either FilePath [ModuleName])]
+getComponents = cabalHelper >>= \CabalHelper {..} -> return $ let
+  ([(scn, sep)], eps) = partition ((GmSetupHsName ==) . fst) chEntrypoints
+  sc = GmComponent scn [] [] sep sep ["."] mempty
+  cs = flip map (zip4 eps chGhcOptions chGhcSrcOptions chSourceDirs) $
+      \((cn, ep), (_, opts), (_, srcOpts), (_, srcDirs)) ->
+          GmComponent cn opts srcOpts ep ep srcDirs mempty
+  in sc:cs
+
+
+withCabal :: (MonadIO m, GmEnv m) => m a -> m a
+withCabal action = do
+    crdl <- cradle
+    Options { cabalProgram } <- options
+
+    liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
+        withDirectory_ (cradleRootDir crdl) $
+            void $ readProcess cabalProgram ["configure"] ""
+
+    action
+
+data CabalHelper = CabalHelper {
+      chEntrypoints   :: [(GmComponentName, Either FilePath [ModuleName])],
+      chSourceDirs    :: [(GmComponentName, [String])],
+      chGhcOptions    :: [(GmComponentName, [String])],
+      chGhcSrcOptions :: [(GmComponentName, [String])],
+      chGhcPkgOptions :: [(GmComponentName, [String])]
+    } deriving (Show)
+
+cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper
+cabalHelper = withCabal $ do
+  let cmds = [ "entrypoints"
+             , "source-dirs"
+             , "ghc-options"
+             , "ghc-src-options"
+             , "ghc-pkg-options" ]
+
+  Cradle {..} <- cradle
+  exe <- liftIO $ findLibexecExe "cabal-helper-wrapper"
+
+  let distdir = cradleRootDir </> "dist"
+
+  res <- liftIO $ cached cradleRootDir (cabalHelperCache cmds) $ do
+           out <- readProcess exe (distdir:cmds) ""
+           evaluate (read out) `catch`
+               \(SomeException _) -> error "cabalHelper: read failed"
+
+  let [ Just (GmCabalHelperEntrypoints eps),
+        Just (GmCabalHelperStrings srcDirs),
+        Just (GmCabalHelperStrings ghcOpts),
+        Just (GmCabalHelperStrings ghcSrcOpts),
+        Just (GmCabalHelperStrings ghcPkgOpts) ] = res
+
+  return $ CabalHelper eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts

Language/Haskell/GhcMod/CaseSplit.hs

@@ -8,17 +8,24 @@ import Data.List (find, intercalate)
 import Data.Maybe (isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T (readFile)
+import System.FilePath
+
 import qualified DataCon as Ty
-import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
 import qualified GHC as G
-import Language.Haskell.GhcMod.Convert
-import qualified Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.SrcUtils
 import Outputable (PprStyle)
 import qualified TyCon as Ty
 import qualified Type as Ty
+import Exception
+
+import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.DynFlags
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.SrcUtils
+import Language.Haskell.GhcMod.Doc
+import Language.Haskell.GhcMod.Logging
+import Language.Haskell.GhcMod.Types
 
 ----------------------------------------------------------------
 -- CASE SPLITTING
@@ -38,23 +45,29 @@ splits :: IOish m
        -> Int          -- ^ Line number.
        -> Int          -- ^ Column number.
        -> GhcModT m String
-splits file lineNo colNo = ghandle handler body
+splits file lineNo colNo =
-  where
+  runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do
-    body = inModuleContext file $ \dflag style -> do
+      opt <- options
-        opt <- options
+      crdl <- cradle
-        modSum <- Gap.fileModSummary file
+      style <- getStyle
-        whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
+      dflag <- G.getSessionDynFlags
-          (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
+      modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
-             let varName' = showName dflag style varName  -- Convert name to string
+      whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
-             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
+        (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
-                                                getTyCons dflag style varName varT)
+          let varName' = showName dflag style varName  -- Convert name to string
-             return (fourInts bndLoc, text)
+          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
-          (TySplitInfo varName bndLoc (varLoc,varT)) -> do
+                                             getTyCons dflag style varName varT)
-             let varName' = showName dflag style varName  -- Convert name to string
+          return (fourInts bndLoc, t)
-             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
+        (TySplitInfo varName bndLoc (varLoc,varT)) -> do
-                                                getTyCons dflag style varName varT)
+          let varName' = showName dflag style varName  -- Convert name to string
-             return (fourInts bndLoc, text)
+          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
-    handler (SomeException _) = emptyResult =<< options
+                                             getTyCons dflag style varName varT)
+          return (fourInts bndLoc, t)
+ where
+   handler (SomeException ex) = do
+     gmLog GmDebug "splits" $
+           text "" $$ nest 4 (showDoc ex)
+     emptyResult =<< options
 
 ----------------------------------------------------------------
 -- a. Code for getting the information of the variable
@@ -180,13 +193,13 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
 
 genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String
 genCaseSplitTextFile file info = liftIO $ do
-  text <- T.readFile file
+  t <- T.readFile file
-  return $ getCaseSplitText (T.lines text) info
+  return $ getCaseSplitText (T.lines t) info
 
 getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
-getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
+getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
                                        , sVarSpan = sVS, sTycons = sT })  =
-  let bindingText = getBindingText text sBS
+  let bindingText = getBindingText t sBS
       difference  = srcSpanDifference sBS sVS
       replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT
       -- The newly generated bindings need to be indented to align with the
@@ -195,9 +208,9 @@ getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
    in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')
 
 getBindingText :: [T.Text] -> SrcSpan -> [T.Text]
-getBindingText text srcSpan =
+getBindingText t srcSpan =
   let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan
-      lines_ = drop (sl - 1) $ take el text
+      lines_ = drop (sl - 1) $ take el t
    in if sl == el
       then -- only one line
            [T.drop (sc - 1) $ T.take ec $ head lines_]
@@ -212,7 +225,7 @@ srcSpanDifference b v =
    in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line
 
 replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]
-replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
+replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon =
   let tycon'      = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon
       lengthDiff  = length tycon' - length varname
       tycon''     = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'
@@ -222,7 +235,7 @@ replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
                           else if n == vsl
                                then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line
                                else T.replicate spacesToAdd (T.pack " ") `T.append` line)
-              [0 ..] text
+              [0 ..] t
 
 indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]
 indentBindingTo bndLoc binds =

Language/Haskell/GhcMod/Check.hs

@@ -9,8 +9,7 @@ import Control.Applicative ((<$>))
 import Language.Haskell.GhcMod.DynFlags
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Logger
-import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
+import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Target (setTargetFiles)
 
 ----------------------------------------------------------------
 
@@ -29,15 +28,12 @@ checkSyntax files = either id id <$> check files
 check :: IOish m
       => [FilePath]  -- ^ The target files.
       -> GhcModT m (Either String String)
-{-
+check files =
-check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
+    runGmLoadedTWith
-  withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
+      (map Left files)
-    _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
+      return
-    setTargetFiles fileNames
+      ((fmap fst <$>) . withLogger (setAllWarningFlags . setNoMaxRelevantBindings))
--}
+      (return ())
-check fileNames =
-  withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $
-    setTargetFiles fileNames
 
 ----------------------------------------------------------------
 
@@ -51,8 +47,10 @@ expandTemplate files = either id id <$> expand files
 ----------------------------------------------------------------
 
 -- | Expanding Haskell Template.
-expand :: IOish m
+expand :: IOish m => [FilePath] -> GhcModT m (Either String String)
-       => [FilePath]  -- ^ The target files.
+expand files =
-       -> GhcModT m (Either String String)
+    runGmLoadedTWith
-expand fileNames = withLogger (Gap.setDumpSplices . setNoWarningFlags) $
+      (map Left files)
-    setTargetFiles fileNames
+      return
+      ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags))
+      (return ())

Language/Haskell/GhcMod/Convert.hs

@@ -2,7 +2,7 @@
 
 module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where
 
-import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
 
 import Control.Applicative ((<$>))
@@ -23,7 +23,7 @@ inter :: Char -> [Builder] -> Builder
 inter _ [] = id
 inter c bs = foldr1 (\x y -> x . (c:) . y) bs
 
-convert' :: (ToString a, IOish m) => a -> GhcModT m String
+convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
 convert' x = flip convert x <$> options
 
 convert :: ToString a => Options -> a -> String

Language/Haskell/GhcMod/Cradle.hs

@@ -1,19 +1,21 @@
 module Language.Haskell.GhcMod.Cradle (
     findCradle
   , findCradle'
-  , findCradleWithoutSandbox
+  , findSpecCradle
   , cleanupCradle
   ) where
 
-import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 
-import Control.Exception.IOChoice ((||>))
+import Control.Applicative
-import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
+import Control.Monad
-import System.FilePath (takeDirectory)
+import Control.Monad.Trans.Maybe
-
+import Data.Maybe
+import System.Directory
+import System.FilePath
 
 ----------------------------------------------------------------
 
@@ -25,51 +27,71 @@ findCradle :: IO Cradle
 findCradle = findCradle' =<< getCurrentDirectory
 
 findCradle' :: FilePath -> IO Cradle
-findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
+findCradle' dir = run $ do
+    (cabalCradle dir `mplus`  sandboxCradle dir `mplus` plainCradle dir)
+ where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
+
+findSpecCradle :: FilePath -> IO Cradle
+findSpecCradle dir = do
+    let cfs = [cabalCradle, sandboxCradle]
+    cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
+    gcs <- filterM isNotGmCradle cs
+    fillTempDir =<< case gcs of
+                      [] -> fromJust <$> runMaybeT (plainCradle dir)
+                      c:_ -> return c
+ where
+   isNotGmCradle :: Cradle -> IO Bool
+   isNotGmCradle crdl = do
+     not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")
 
 cleanupCradle :: Cradle -> IO ()
 cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
 
-cabalCradle :: FilePath -> IO Cradle
+fillTempDir :: MonadIO m => Cradle -> m Cradle
+fillTempDir crdl = do
+  tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
+  return crdl { cradleTempDir = tmpDir }
+
+cabalCradle :: FilePath -> MaybeT IO Cradle
 cabalCradle wdir = do
-    Just cabalFile <- findCabalFile wdir
+    cabalFile <- MaybeT $ findCabalFile wdir
+
     let cabalDir = takeDirectory cabalFile
-    pkgDbStack <- getPackageDbStack cabalDir
+    pkgDbStack <- liftIO $ getPackageDbStack cabalDir
-    tmpDir <- newTempDir cabalDir
+
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = cabalDir
-      , cradleTempDir    = tmpDir
+      , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Just cabalFile
       , cradlePkgDbStack = pkgDbStack
       }
 
-sandboxCradle :: FilePath -> IO Cradle
+sandboxCradle :: FilePath -> MaybeT IO Cradle
 sandboxCradle wdir = do
-    Just sbDir <- findCabalSandboxDir wdir
+    sbDir <- MaybeT $ findCabalSandboxDir wdir
-    pkgDbStack <- getPackageDbStack sbDir
+    pkgDbStack <- liftIO $ getPackageDbStack sbDir
-    tmpDir <- newTempDir sbDir
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = sbDir
-      , cradleTempDir    = tmpDir
+      , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Nothing
       , cradlePkgDbStack = pkgDbStack
       }
 
-plainCradle :: FilePath -> IO Cradle
+plainCradle :: FilePath -> MaybeT IO Cradle
 plainCradle wdir = do
-    tmpDir <- newTempDir wdir
+    return $ Cradle {
-    return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = wdir
-      , cradleTempDir    = tmpDir
+      , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Nothing
       , cradlePkgDbStack = [GlobalDb, UserDb]
       }
 
--- Just for testing
+getPackageDbStack :: FilePath -- ^ Project Directory (where the
-findCradleWithoutSandbox :: IO Cradle
+                                 -- cabal.sandbox.config file would be if it
-findCradleWithoutSandbox = do
+                                 -- exists)
-    cradle <- findCradle
+                  -> IO [GhcPkgDb]
-    return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME
+getPackageDbStack cdir =
+    ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir

Language/Haskell/GhcMod/Debug.hs

@@ -1,41 +1,76 @@
 module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where
 
+import Control.Arrow (first)
 import Control.Applicative ((<$>))
-import Data.List (intercalate)
+import qualified Data.Map as Map
-import Data.Maybe (isJust, fromJust)
+import qualified Data.Set as Set
+import Text.PrettyPrint
 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
+import Language.Haskell.GhcMod.CabalHelper
+import Language.Haskell.GhcMod.Target
+import Language.Haskell.GhcMod.Pretty
 
 ----------------------------------------------------------------
 
 -- | Obtaining debug information.
 debugInfo :: IOish m => GhcModT m String
-debugInfo = cradle >>= \c -> convert' =<< do
+debugInfo = do
-    CompilerOptions gopts incDir pkgs <-
+    Options {..} <- options
-        if isJust $ cradleCabalFile c then
+    Cradle {..} <- cradle
-            fromCabalFile c ||> simpleCompilerOption
-          else
-            simpleCompilerOption
-    return [
-        "Root directory:      " ++ cradleRootDir c
-      , "Current directory:   " ++ cradleCurrentDir c
-      , "Cabal file:          " ++ show (cradleCabalFile c)
-      , "GHC options:         " ++ unwords gopts
-      , "Include directories: " ++ unwords incDir
-      , "Dependent packages:  " ++ intercalate ", " (map showPkg pkgs)
-      , "System libraries:    " ++ ghcLibDir
-      ]
-  where
-    simpleCompilerOption = options >>= \op ->
-        return $ CompilerOptions (ghcUserOptions op) [] []
-    fromCabalFile crdl = options >>= \opts -> do
-        config <- cabalGetConfig crdl
-        pkgDesc <- parseCabalFile config $ fromJust $ cradleCabalFile crdl
-        getCompilerOptions (ghcUserOptions opts) crdl config pkgDesc
 
+    cabal <-
+        case cradleCabalFile of
+          Just _ -> cabalDebug
+          Nothing -> return []
+
+    return $ unlines $
+      [ "Root directory:       " ++ cradleRootDir
+      , "Current directory:    " ++ cradleCurrentDir
+      , "GHC System libraries: " ++ ghcLibDir
+      , "GHC user options:     " ++ render (fsep $ map text ghcUserOptions)
+      ] ++ cabal
+
+cabalDebug :: IOish m => GhcModT m [String]
+cabalDebug = do
+    Cradle {..} <- cradle
+    mcs <- resolveGmComponents Nothing =<< getComponents
+    let entrypoints = Map.map gmcEntrypoints mcs
+        graphs      = Map.map gmcHomeModuleGraph mcs
+        opts        = Map.map gmcGhcOpts mcs
+        srcOpts     = Map.map gmcGhcSrcOpts mcs
+
+    return $
+         [ "Cabal file:           " ++ show cradleCabalFile
+         , "Cabal entrypoints:\n"       ++ render (nest 4 $
+              mapDoc gmComponentNameDoc smpDoc entrypoints)
+         , "Cabal components:\n"        ++ render (nest 4 $
+              mapDoc gmComponentNameDoc graphDoc graphs)
+         , "GHC Cabal options:\n"       ++ render (nest 4 $
+              mapDoc gmComponentNameDoc (fsep . map text) opts)
+         , "GHC search path options:\n" ++ render (nest 4 $
+              mapDoc gmComponentNameDoc (fsep . map text) srcOpts)
+         ]
+
+graphDoc :: GmModuleGraph -> Doc
+graphDoc GmModuleGraph{..} =
+    mapDoc mpDoc' smpDoc' gmgGraph
+ where
+   smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp
+   mpDoc' = text . moduleNameString . mpModule
+
+smpDoc :: Set.Set ModulePath -> Doc
+smpDoc smp = vcat $ map mpDoc $ Set.toList smp
+
+mpDoc :: ModulePath -> Doc
+mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)
+
+
+mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc
+mapDoc kd ad m = vcat $
+    map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m
 ----------------------------------------------------------------
 
 -- | Obtaining root information.

Language/Haskell/GhcMod/Doc.hs

@@ -1,9 +1,8 @@
 module Language.Haskell.GhcMod.Doc where
 
-import GHC (DynFlags, GhcMonad)
+import GHC
-import qualified GHC as G
 import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)
-import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify)
+import Outputable
 import Pretty (Mode(..))
 
 showPage :: DynFlags -> PprStyle -> SDoc -> String
@@ -12,9 +11,14 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style
 showOneLine :: DynFlags -> PprStyle -> SDoc -> String
 showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
 
+showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
+showForUser dflags unqual sdoc =
+    showDocWith dflags PageMode $
+      runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay
+
 getStyle :: GhcMonad m => m PprStyle
 getStyle = do
-    unqual <- G.getPrintUnqual
+    unqual <- getPrintUnqual
     return $ mkUserStyle unqual AllTheWay
 
 styleUnqualified :: PprStyle

Language/Haskell/GhcMod/DynFlags.hs

@@ -12,8 +12,6 @@ import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
 import System.IO.Unsafe (unsafePerformIO)
 
-data Build = CabalPkg | SingleFile deriving Eq
-
 setEmptyLogger :: DynFlags -> DynFlags
 setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
 
@@ -41,37 +39,15 @@ setModeIntelligent df = df {
   , optLevel  = 0
   }
 
-setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags
-setIncludeDirs idirs df = df { importPaths = idirs }
-
-setBuildEnv :: Build -> DynFlags -> DynFlags
-setBuildEnv build = setHideAllPackages build . setCabalPackage build
-
--- | With ghc-7.8 this option simply makes GHC print a message suggesting users
--- add hiddend packages to the build-depends field in their cabal file when the
--- user tries to import a module form a hidden package.
-setCabalPackage :: Build -> DynFlags -> DynFlags
-setCabalPackage CabalPkg df = Gap.setCabalPkg df
-setCabalPackage _ df = df
-
--- | Enable hiding of all package not explicitly exposed (like Cabal does)
-setHideAllPackages :: Build -> DynFlags -> DynFlags
-setHideAllPackages CabalPkg df = Gap.setHideAllPackages df
-setHideAllPackages _ df = df
-
 -- | Parse command line ghc options and add them to the 'DynFlags' passed
 addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags
 addCmdOpts cmdOpts df =
-    tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
+    fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
   where
-    tfst (a,_,_) = a
+    fst3 (a,_,_) = a
 
 ----------------------------------------------------------------
 
--- | Return the 'DynFlags' currently in use in the GHC session.
-getDynamicFlags :: IO DynFlags
-getDynamicFlags = G.runGhc (Just libdir) G.getSessionDynFlags
-
 withDynFlags :: GhcMonad m
              => (DynFlags -> DynFlags)
              -> m a
@@ -119,3 +95,7 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
 #else
 setNoMaxRelevantBindings = id
 #endif
+
+deferErrors :: DynFlags -> Ghc DynFlags
+deferErrors df = return $
+  Gap.setWarnTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df

Language/Haskell/GhcMod/Error.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-}
 -- ghc-mod: Making Haskell development *more* fun
 -- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
 --
@@ -14,64 +13,47 @@
 --
 -- 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 ExistentialQuantification #-}
 module Language.Haskell.GhcMod.Error (
     GhcModError(..)
   , GMConfigStateFileError(..)
   , GmError
   , gmeDoc
+  , ghcExceptionDoc
+  , liftMaybe
+  , overrideError
   , modifyError
   , modifyError'
+  , modifyGmError
   , tryFix
+  , GHandler(..)
+  , gcatches
   , module Control.Monad.Error
-  , module Exception
+  , module Control.Exception
   ) where
 
-import Control.Monad.Error (MonadError(..), Error(..))
+import Control.Arrow
+import Control.Exception
+import Control.Monad.Error
+import qualified Data.Set as Set
 import Data.List
-import Data.Typeable
+import Data.Version
-import Exception
+import System.Process (showCommandForUser)
 import Text.PrettyPrint
+import Text.Printf
+
+import Exception
+import Panic
+import Config (cProjectVersion, cHostPlatformString)
+import Paths_ghc_mod (version)
+
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Pretty
+
 
 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. "
@@ -103,31 +85,45 @@ gmCsfeDoc GMConfigStateFileMissing = text $
 --               ++ display currentCompilerId
 --               ++ ") which is probably the cause of the problem."
 
-
-
-
-
-instance Exception GhcModError
-
-instance Error GhcModError where
-    noMsg = GMENoMsg
-    strMsg = GMEString
-
 gmeDoc :: GhcModError -> Doc
 gmeDoc e = case e of
     GMENoMsg ->
         text "Unknown error"
     GMEString msg ->
         text msg
-    GMEIOException ioe ->
-        text $ show ioe
     GMECabalConfigure msg ->
-        text "cabal configure failed: " <> gmeDoc msg
+        text "Configuring cabal project failed: " <> gmeDoc msg
     GMECabalFlags msg ->
-        text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg
+        text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg
-    GMEProcess cmd msg ->
+    GMECabalComponent cn ->
-        text ("launching operating system process `"++unwords cmd++"` failed: ")
+        text "Cabal component " <> quotes (gmComponentNameDoc cn)
-          <> gmeDoc msg
+                                <> text " could not be found."
+    GMECabalCompAssignment ctx ->
+        text "Could not find a consistent component assignment for modules:" $$
+          (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$
+        empty $$
+        text "Try this and that"
+
+      where
+        ctxDoc = moduleDoc *** compsDoc
+                 >>> first (<> colon) >>> uncurry (flip hang 4)
+
+        moduleDoc (Left fn)   =
+            text "File " <> quotes (text fn)
+        moduleDoc (Right mdl) =
+            text "Module " <> quotes (text $ moduleNameString mdl)
+
+        compsDoc sc | Set.null sc = text "has no known components"
+        compsDoc sc = fsep $ punctuate comma $
+                        map gmComponentNameDoc $ Set.toList sc
+
+    GMEProcess cmd args emsg -> let c = showCommandForUser cmd args in
+        case emsg of
+          Right err ->
+             text (printf "Launching system command `%s` failed: " c)
+                  <> gmeDoc err
+          Left (_out, _err, rv) -> text $
+             printf "Launching system command `%s` failed (exited with %d)" c rv
     GMENoCabalFile ->
         text "No cabal file found."
     GMETooManyCabalFiles cfs ->
@@ -136,6 +132,32 @@ gmeDoc e = case e of
     GMECabalStateFile csfe ->
         gmCsfeDoc csfe
 
+ghcExceptionDoc :: GhcException -> Doc
+ghcExceptionDoc e@(CmdLineError _) =
+    text $ "<command line>: " ++ showGhcException e ""
+ghcExceptionDoc (UsageError str) = strDoc str
+ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\
+\GHC panic! (the 'impossible' happened)\n\
+\  ghc-mod version %s\n\
+\  GHC library version %s for %s:\n\
+\       %s\n\
+\\n\
+\Please report this as a bug: %s\n"
+    gmVer ghcVer platform msg url
+ where
+   gmVer = showVersion version
+   ghcVer = cProjectVersion
+   platform = cHostPlatformString
+   url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String
+
+ghcExceptionDoc e = text $ showGhcException e ""
+
+
+liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a
+liftMaybe e action = maybe (throwError e) return =<< action
+
+overrideError :: MonadError e m => e -> m a -> m a
+overrideError e action = modifyError (const e) action
 
 modifyError :: MonadError e m => (e -> e) -> m a -> m a
 modifyError f action = action `catchError` \e -> throwError $ f e
@@ -144,6 +166,23 @@ infixr 0 `modifyError'`
 modifyError' :: MonadError e m => m a -> (e -> e) -> m a
 modifyError' = flip modifyError
 
+
+modifyGmError :: (MonadIO m, ExceptionMonad m)
+              => (GhcModError -> GhcModError) -> m a -> m a
+modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)
+
 tryFix :: MonadError e m => m a -> (e -> m ()) -> m a
-tryFix action fix = do
+tryFix action f = do
-  action `catchError` \e -> fix e >> action
+  action `catchError` \e -> f e >> action
+
+data GHandler m a = forall e . Exception e => GHandler (e -> m a)
+
+gcatches :: ExceptionMonad m => m a -> [GHandler m a] -> m a
+gcatches io handlers = io `gcatch` gcatchesHandler handlers
+
+gcatchesHandler :: ExceptionMonad m => [GHandler m a] -> SomeException -> m a
+gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers
+    where tryHandler (GHandler handler) res
+              = case fromException e of
+                Just e' -> handler e'
+                Nothing -> res

Language/Haskell/GhcMod/FillSig.hs

@@ -19,8 +19,10 @@ import qualified GHC as G
 import qualified Name as G
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
+import Language.Haskell.GhcMod.Doc
 import Language.Haskell.GhcMod.Types
 import Outputable (PprStyle)
 import qualified Type as Ty
@@ -66,21 +68,29 @@ sig :: IOish m
     -> Int          -- ^ Line number.
     -> Int          -- ^ Column number.
     -> GhcModT m String
-sig file lineNo colNo = ghandle handler body
+sig file lineNo colNo =
-  where
+    runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do
-    body = inModuleContext file $ \dflag style -> do
+      opt <- options
-        opt <- options
+      style <- getStyle
-        modSum <- Gap.fileModSummary file
+      dflag <- G.getSessionDynFlags
-        whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
+      modSum <- Gap.fileModSummary file
+      whenFound opt (getSignature modSum lineNo colNo) $ \s ->
+        case s of
           Signature loc names ty ->
-            ("function", fourInts loc, map (initialBody dflag style ty) names)
+              ("function", fourInts loc, map (initialBody dflag style ty) names)
-          InstanceDecl loc cls ->
+
-             ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
+          InstanceDecl loc cls -> let
-                                            (Ty.classMethods cls))
+                body x = initialBody dflag style (G.idType x) x
+            in
+              ("instance", fourInts loc, body `map` Ty.classMethods cls)
+
           TyFamDecl loc name flavour vars ->
             let (rTy, initial) = initialTyFamString flavour
-             in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars])
+                body = initialFamBody dflag style name vars
+             in (rTy, fourInts loc, [initial ++ body])
 
+
+  where
     handler (SomeException _) = do
       opt <- options
       -- Code cannot be parsed by ghc module
@@ -321,10 +331,11 @@ refine :: IOish m
        -> Int          -- ^ Column number.
        -> Expression   -- ^ A Haskell expression.
        -> GhcModT m String
-refine file lineNo colNo expr = ghandle handler body
+refine file lineNo colNo expr =
-  where
+  runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do
-    body = inModuleContext file $ \dflag style -> do
         opt <- options
+        style <- getStyle
+        dflag <- G.getSessionDynFlags
         modSum <- Gap.fileModSummary file
         p <- G.parseModule modSum
         tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
@@ -339,7 +350,8 @@ refine file lineNo colNo expr = ghandle handler body
                   text = initialHead1 expr iArgs (infinitePrefixSupply name)
                in (fourInts loc, doParen paren text)
 
-    handler (SomeException _) = emptyResult =<< options
+ where
+   handler (SomeException _) = emptyResult =<< options
 
 -- Look for the variable in the specified position
 findVar :: GhcMonad m => DynFlags -> PprStyle
@@ -386,10 +398,11 @@ auto :: IOish m
      -> Int          -- ^ Line number.
      -> Int          -- ^ Column number.
      -> GhcModT m String
-auto file lineNo colNo = ghandle handler body
+auto file lineNo colNo =
-  where
+  runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do
-    body = inModuleContext file $ \dflag style -> do
         opt <- options
+        style <- getStyle
+        dflag <- G.getSessionDynFlags
         modSum <- Gap.fileModSummary file
         p <- G.parseModule modSum
         tcm@TypecheckedModule {
@@ -415,8 +428,8 @@ auto file lineNo colNo = ghandle handler body
           djinns <- djinn True (Just minfo) env rty (Max 10) 100000
           return ( fourInts loc
                  , map (doParen paren) $ nub (djinnsEmpty ++ djinns))
-
+ where
-    handler (SomeException _) = emptyResult =<< options
+   handler (SomeException _) = emptyResult =<< options
 
 -- Functions we do not want in completions
 notWantedFuns :: [String]

Language/Haskell/GhcMod/Find.hs

@@ -28,7 +28,7 @@ import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Gap (listVisibleModules)
 import Name (getOccString)
-import Module (moduleNameString, moduleName)
+import Module (moduleName)
 import System.Directory (doesFileExist, getModificationTime)
 import System.FilePath ((</>), takeDirectory)
 import System.IO
@@ -81,7 +81,7 @@ loadSymbolDb :: IOish m => GhcModT m SymbolDb
 loadSymbolDb = do
     ghcMod <- liftIO ghcModExecutable
     tmpdir <- cradleTempDir <$> cradle
-    file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir]
+    file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
     !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
     return $ SymbolDb {
         table = db
@@ -102,12 +102,12 @@ loadSymbolDb = do
 --   The file name is printed.
 
 dumpSymbol :: IOish m => FilePath -> GhcModT m String
-dumpSymbol dir = do
+dumpSymbol dir = runGmPkgGhc $ do
     let cache = dir </> symbolCacheFile
         pkgdb = dir </> packageCache
 
     create <- liftIO $ cache `isOlderThan` pkgdb
-    when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
+    when create $ (liftIO . writeSymbolCache cache) =<< getGlobalSymbolTable
     return $ unlines [cache]
 
 writeSymbolCache :: FilePath
@@ -127,9 +127,9 @@ isOlderThan cache file = do
         tFile <- getModificationTime file
         return $ tCache <= tFile -- including equal just in case
 
--- | Browsing all functions in all system/user modules.
+-- | Browsing all functions in all system modules.
-getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
+getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])]
-getSymbolTable = do
+getGlobalSymbolTable = do
     df  <- G.getSessionDynFlags
     let mods = listVisibleModules df
     moduleInfos <- mapM G.getModuleInfo mods

Language/Haskell/GhcMod/GHCChoice.hs

@@ -1,23 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Language.Haskell.GhcMod.GHCChoice where
-
-import Control.Exception (IOException)
-import CoreMonad (liftIO)
-import qualified Exception as GE
-import GHC (GhcMonad)
-
-----------------------------------------------------------------
-
--- | Try the left 'Ghc' action. If 'IOException' occurs, try
---   the right 'Ghc' action.
-(||>) :: GhcMonad m => m a -> m a -> m a
-x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y)
-
--- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.
-goNext :: GhcMonad m => m a
-goNext = liftIO . GE.throwIO $ userError "goNext"
-
--- | Run any one 'Ghc' monad.
-runAnyOne :: GhcMonad m => [m a] -> m a
-runAnyOne = foldr (||>) goNext

Language/Haskell/GhcMod/Gap.hs

@@ -13,7 +13,6 @@ module Language.Haskell.GhcMod.Gap (
   , showSeverityCaption
   , setCabalPkg
   , setHideAllPackages
-  , addPackageFlags
   , setDeferTypeErrors
   , setWarnTypedHoles
   , setDumpSplices
@@ -33,16 +32,10 @@ module Language.Haskell.GhcMod.Gap (
   , fileModSummary
   , WarnFlags
   , emptyWarnFlags
-  , benchmarkBuildInfo
-  , benchmarkTargets
-  , toModuleString
   , GLMatch
   , GLMatchI
   , getClass
   , occName
-  , setFlags
-  , ghcVersion
-  , mkGHCCompilerId
   , listVisibleModuleNames
   , listVisibleModules
   , Language.Haskell.GhcMod.Gap.isSynTyCon
@@ -51,19 +44,18 @@ module Language.Haskell.GhcMod.Gap (
 import Control.Applicative hiding (empty)
 import Control.Monad (filterM)
 import CoreSyn (CoreExpr)
-import Data.Version (parseVersion)
 import Data.List (intersperse)
 import Data.Maybe (catMaybes)
 import Data.Time.Clock (UTCTime)
+import Data.Traversable (traverse)
 import DataCon (dataConRepType)
 import Desugar (deSugarExpr)
 import DynFlags
 import ErrUtils
+import Exception
 import FastString
 import GhcMonad
 import HscTypes
-import Language.Haskell.GhcMod.GHCChoice
-import Language.Haskell.GhcMod.Types
 import NameSet
 import OccName
 import Outputable
@@ -71,11 +63,8 @@ import PprTyThing
 import StringBuffer
 import TcType
 import Var (varType)
-import Config (cProjectVersion)
+import System.Directory
 
-import Text.ParserCombinators.ReadP (readP_to_S)
-
-import qualified Distribution.PackageDescription as P
 import qualified InstEnv
 import qualified Pretty
 import qualified StringBuffer as SB
@@ -97,13 +86,6 @@ import Data.Convertible
 import RdrName (rdrNameOcc)
 #endif
 
-import Distribution.Version
-import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
-#if __GLASGOW_HASKELL__ >= 710
-import Distribution.Simple.Compiler (CompilerInfo(..), AbiTag(..))
-import Packages (listVisibleModuleNames, lookupModuleInAllPackages)
-#endif
-
 #if __GLASGOW_HASKELL__ < 710
 import UniqFM (eltsUFM)
 import Packages (exposedModules, exposed, pkgIdMap)
@@ -112,7 +94,6 @@ import PackageConfig (PackageConfig, packageConfigId)
 
 #if __GLASGOW_HASKELL__ >= 704
 import qualified Data.IntSet as I (IntSet, empty)
-import qualified Distribution.ModuleName as M (ModuleName,toFilePath)
 #endif
 
 ----------------------------------------------------------------
@@ -213,9 +194,11 @@ fOptions = [option | (option,_,_,_) <- fFlags]
 ----------------------------------------------------------------
 
 fileModSummary :: GhcMonad m => FilePath -> m ModSummary
-fileModSummary file = do
+fileModSummary file' = do
     mss <- getModuleGraph
-    let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss
+    file <- liftIO $ canonicalizePath file'
+    [ms] <- liftIO $ flip filterM mss $ \m ->
+        (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)
     return ms
 
 withContext :: GhcMonad m => m a -> m a
@@ -228,26 +211,31 @@ withContext action = gbracket setup teardown body
         action
     topImports = do
         mss <- getModuleGraph
-        ms <- map modName <$> filterM isTop mss
+        mns <- map modName <$> filterM isTop mss
+        let ii = map IIModule mns
 #if __GLASGOW_HASKELL__ >= 704
-        return ms
+        return ii
 #else
-        return (ms,[])
+        return (ii,[])
 #endif
     isTop mos = lookupMod mos ||> returnFalse
     lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True
     returnFalse = return False
 #if __GLASGOW_HASKELL__ >= 706
-    modName = IIModule . moduleName . ms_mod
+    modName = moduleName . ms_mod
     setCtx = setContext
 #elif __GLASGOW_HASKELL__ >= 704
-    modName = IIModule . ms_mod
+    modName = ms_mod
     setCtx = setContext
 #else
     modName = ms_mod
     setCtx = uncurry setContext
 #endif
 
+-- | Try the left action, if an IOException occurs try the right action.
+(||>) :: ExceptionMonad m => m a -> m a -> m a
+x ||> y = x `gcatch` (\(_ :: IOException) -> y)
+
 showSeverityCaption :: Severity -> String
 #if __GLASGOW_HASKELL__ >= 706
 showSeverityCaption SevWarning = "Warning: "
@@ -275,17 +263,6 @@ setHideAllPackages df = gopt_set df Opt_HideAllPackages
 setHideAllPackages df = dopt_set df Opt_HideAllPackages
 #endif
 
-addPackageFlags :: [Package] -> DynFlags -> DynFlags
-addPackageFlags pkgs df =
-    df { packageFlags = packageFlags df ++ expose `map` pkgs }
-  where
-#if __GLASGOW_HASKELL__ >= 710
-    expose :: Package -> PackageFlag
-    expose pkg = ExposePackage (PackageIdArg $ showPkgId pkg) (ModRenaming True [])
-#else
-    expose pkg = ExposePackageId $ showPkgId pkg
-#endif
-
 ----------------------------------------------------------------
 
 setDumpSplices :: DynFlags -> DynFlags
@@ -444,29 +421,6 @@ emptyWarnFlags = []
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 
-benchmarkBuildInfo :: P.PackageDescription -> [P.BuildInfo]
-#if __GLASGOW_HASKELL__ >= 704
-benchmarkBuildInfo pd = map P.benchmarkBuildInfo $ P.benchmarks pd
-#else
-benchmarkBuildInfo pd = []
-#endif
-
-benchmarkTargets :: P.PackageDescription -> [String]
-#if __GLASGOW_HASKELL__ >= 704
-benchmarkTargets pd = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd
-#else
-benchmarkTargets = []
-#endif
-
-toModuleString :: M.ModuleName -> String
-toModuleString mn = fromFilePath $ M.toFilePath mn
-  where
-    fromFilePath :: FilePath -> String
-    fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp
-
-----------------------------------------------------------------
-----------------------------------------------------------------
-
 #if __GLASGOW_HASKELL__ >= 708
 type GLMatch = LMatch RdrName (LHsExpr RdrName)
 type GLMatchI = LMatch Id (LHsExpr Id)
@@ -502,35 +456,6 @@ occName = rdrNameOcc
 
 ----------------------------------------------------------------
 
-setFlags :: DynFlags -> DynFlags
-#if __GLASGOW_HASKELL__ >= 708
-setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2
-#else
-setFlags = id
-#endif
-
-----------------------------------------------------------------
-
-ghcVersion :: Version
-ghcVersion =
-    case readP_to_S parseVersion $ cProjectVersion  of
-      [(ver, "")] -> ver
-      _ -> error "parsing ghc version(cProjectVersion) failed."
-
-
-#if __GLASGOW_HASKELL__ >= 710
-mkGHCCompilerId :: Version -> Distribution.Simple.Compiler.CompilerInfo
--- TODO we should probably fill this out properly
-mkGHCCompilerId v =
-    CompilerInfo (CompilerId GHC v) NoAbiTag Nothing Nothing Nothing
-#else
-mkGHCCompilerId :: Version -> CompilerId
-mkGHCCompilerId v = CompilerId GHC v
-#endif
-
-----------------------------------------------------------------
-
-
 #if __GLASGOW_HASKELL__ < 710
 -- Copied from ghc/InteractiveUI.hs
 allExposedPackageConfigs :: DynFlags -> [PackageConfig]

Language/Haskell/GhcMod/GhcPkg.hs

@@ -4,20 +4,14 @@ module Language.Haskell.GhcMod.GhcPkg (
   , ghcPkgDbStackOpts
   , ghcDbStackOpts
   , ghcDbOpt
-  , fromInstalledPackageId
-  , fromInstalledPackageId'
-  , getPackageDbStack
   , getPackageCachePaths
   ) where
 
 import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
 import Control.Applicative ((<$>))
-import Data.List (intercalate)
 import Data.List.Split (splitOn)
 import Data.Maybe
-import Distribution.Package (InstalledPackageId(..))
 import Exception (handleIO)
-import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
 import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
 import System.FilePath ((</>))
@@ -25,29 +19,6 @@ import System.FilePath ((</>))
 ghcVersion :: Int
 ghcVersion = read cProjectVersionInt
 
-getPackageDbStack :: FilePath -- ^ Project Directory (where the
-                                 -- cabal.sandbox.config file would be if it
-                                 -- exists)
-                  -> IO [GhcPkgDb]
-getPackageDbStack cdir =
-    ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
-
-----------------------------------------------------------------
-
-fromInstalledPackageId' :: InstalledPackageId -> Maybe Package
-fromInstalledPackageId' pid = let
-    InstalledPackageId pkg = pid
-    in case reverse $ splitOn "-" pkg of
-      i:v:rest -> Just (intercalate "-" (reverse rest), v, i)
-      _ -> Nothing
-
-fromInstalledPackageId :: InstalledPackageId -> Package
-fromInstalledPackageId pid =
-    case fromInstalledPackageId' pid of
-      Just p -> p
-      Nothing -> error $
-        "fromInstalledPackageId: `"++show pid++"' is not a valid package-id"
-
 ----------------------------------------------------------------
 
 -- | Get options needed to add a list of package dbs to ghc-pkg's db stack
@@ -82,12 +53,10 @@ ghcDbOpt (PackageDb pkgDb)
 
 ----------------------------------------------------------------
 
-
 getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath]
 getPackageCachePaths sysPkgCfg crdl =
     catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl
 
-
 -- TODO: use PkgConfRef
 --- Copied from ghc module `Packages' unfortunately it's not exported :/
 resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath)

Language/Haskell/GhcMod/HomeModuleGraph.hs

@@ -0,0 +1,270 @@
+-- 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 ScopedTypeVariables, RecordWildCards #-}
+module Language.Haskell.GhcMod.HomeModuleGraph (
+   GmModuleGraph(..)
+ , ModulePath(..)
+ , mkFileMap
+ , mkModuleMap
+ , mkMainModulePath
+ , findModulePath
+ , findModulePathSet
+ , fileModuleName
+ , homeModuleGraph
+ , updateHomeModuleGraph
+ , reachable
+ , moduleGraphToDot
+ ) where
+
+import Bag
+import DriverPipeline hiding (unP)
+import ErrUtils
+import Exception
+import FastString
+import Finder
+import GHC
+import HscTypes
+import Lexer
+import MonadUtils hiding (foldrM)
+import Parser
+import SrcLoc
+import StringBuffer
+
+import Control.Arrow ((&&&))
+import Control.Monad
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Control.Monad.State.Strict (execStateT)
+import Control.Monad.State.Class
+import Data.Maybe
+import Data.Monoid
+import Data.Map.Strict  (Map)
+import qualified Data.Map.Strict  as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import System.FilePath
+
+import Language.Haskell.GhcMod.Logging
+import Language.Haskell.GhcMod.Logger
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Types
+
+-- | Turn module graph into a graphviz dot file
+--
+-- @dot -Tpng -o modules.png modules.dot@
+moduleGraphToDot :: GmModuleGraph -> String
+moduleGraphToDot GmModuleGraph { gmgGraph } =
+    "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n"
+ where
+   graph = Map.map (Set.mapMonotonic mpPath)
+         $ Map.mapKeysMonotonic mpPath gmgGraph
+   edges :: (FilePath, (Set FilePath)) -> String
+   edges (f, sf) =
+       concatMap (\f' -> "    \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf)
+
+data S = S {
+      sErrors   :: [(ModulePath, ErrorMessages)],
+      sWarnings :: [(ModulePath, WarningMessages)],
+      sGraph    :: GmModuleGraph
+}
+
+defaultS :: S
+defaultS = S [] [] mempty
+
+putErr :: MonadState S m
+       => (ModulePath, ErrorMessages) -> m ()
+putErr e = do
+  s <- get
+  put s { sErrors = e:sErrors s}
+
+putWarn :: MonadState S m
+       => (ModulePath, ErrorMessages) -> m ()
+putWarn w = do
+  s <- get
+  put s { sWarnings = w:sWarnings s}
+
+gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath))
+gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get
+
+graphUnion :: MonadState S m => GmModuleGraph -> m ()
+graphUnion gmg = do
+  s <- get
+  put s { sGraph = sGraph s `mappend` gmg }
+
+reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath
+reachable smp0 GmModuleGraph {..} = go smp0
+ where
+   go smp = let
+       δsmp = Set.unions $
+                collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp
+       smp' = smp `Set.union` δsmp
+    in if smp == smp' then smp' else go smp'
+
+pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph
+pruneUnreachable smp0 gmg@GmModuleGraph {..} = let
+    r = reachable smp0 gmg
+    rfn = Set.map mpPath r
+    rmn = Set.map mpModule r
+  in
+    GmModuleGraph {
+      gmgFileMap = Map.filterWithKey (\k _ -> k `Set.member` rfn) gmgFileMap,
+      gmgModuleMap = Map.filterWithKey (\k _ -> k `Set.member` rmn) gmgModuleMap,
+      gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph
+    }
+
+collapseMaybeSet :: Maybe (Set a) -> Set a
+collapseMaybeSet = maybe Set.empty id
+
+homeModuleGraph :: (IOish m, GmLog m, GmEnv m)
+    => HscEnv -> Set ModulePath -> m GmModuleGraph
+homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp
+
+mkMainModulePath :: FilePath -> ModulePath
+mkMainModulePath = ModulePath (mkModuleName "Main")
+
+findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath)
+findModulePath env mn = do
+    fmap (ModulePath mn) <$> find env mn
+
+findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath)
+findModulePathSet env mns = do
+    Set.fromList . catMaybes <$> findModulePath env `mapM` mns
+
+find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath)
+find env mn = liftIO $ do
+  res <- findHomeModule env mn
+  case res of
+   -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc
+    Found loc@ModLocation { ml_hs_file = Just _ } _mod -> do
+        return $ normalise <$> ml_hs_file loc
+    _ -> return Nothing
+
+updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m)
+                      => HscEnv
+                      -> GmModuleGraph
+                      -> Set ModulePath -- ^ Initial set of modules
+                      -> Set ModulePath -- ^ Updated set of modules
+                      -> m GmModuleGraph
+updateHomeModuleGraph env GmModuleGraph {..} smp usmp = do
+    -- TODO: It would be good if we could retain information about modules that
+    -- stop to compile after we've already successfully parsed them at some
+    -- point. Figure out a way to delete the modules about to be updated only
+    -- after we're sure they won't fail to parse .. or something. Should probably
+    -- push this whole prune logic deep into updateHomeModuleGraph'
+   (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env usmp)
+ where
+   runS = flip execStateT defaultS { sGraph = graph' }
+   graph' = GmModuleGraph {
+       gmgFileMap = Set.foldr (Map.delete . mpPath) gmgFileMap usmp,
+       gmgModuleMap = Set.foldr (Map.delete . mpModule) gmgModuleMap usmp,
+       gmgGraph = Set.foldr Map.delete gmgGraph usmp
+    }
+
+mkFileMap :: Set ModulePath -> Map FilePath ModulePath
+mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp
+
+mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath
+mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp
+
+updateHomeModuleGraph'
+    :: forall m. (MonadState S m, IOish m, GmLog m, GmEnv m)
+    => HscEnv
+    -> Set ModulePath     -- ^ Initial set of modules
+    -> m ()
+updateHomeModuleGraph' env smp0 = do
+    go `mapM_` Set.toList smp0
+
+ where
+   go :: ModulePath -> m ()
+   go mp = do
+     msmp <- gmgLookupMP mp
+     case msmp of
+       Just _ -> return ()
+       Nothing -> do
+           smp <- collapseMaybeSet `liftM` step mp
+
+           graphUnion GmModuleGraph {
+               gmgFileMap = mkFileMap smp,
+               gmgModuleMap = mkModuleMap smp,
+               gmgGraph = Map.singleton mp smp
+            }
+
+           mapM_ go (Set.toList smp)
+
+   step :: ModulePath -> m (Maybe (Set ModulePath))
+   step mp = runMaybeT $ do
+       (dflags, ppsrc_fn) <- MaybeT preprocess'
+       src <- liftIO $ readFile ppsrc_fn
+       imports mp src dflags
+    where
+      preprocess' :: m (Maybe (DynFlags, FilePath))
+      preprocess' = do
+        let fn = mpPath mp
+        ep <- liftIO $ withLogger' env $ \setDf -> let
+              env' = env { hsc_dflags = setDf (hsc_dflags env) }
+           in preprocess env' (fn, Nothing)
+        case ep of
+          Right (_, x) -> return $ Just x
+          Left errs -> do
+            -- TODO: Remember these and present them as proper errors if this is
+            -- the file the user is looking at.
+            gmLog GmWarning "preprocess'" $ vcat $ map strDoc errs
+            return Nothing
+
+   imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath)
+   imports mp@ModulePath {..} src dflags =
+       case parseModuleHeader src dflags mpPath of
+         Left err -> do
+           putErr (mp, err)
+           mzero
+
+         Right (ws, lmdl) -> do
+           putWarn (mp, ws)
+           let HsModule {..} = unLoc lmdl
+               mns = map (unLoc . ideclName)
+                   $ filter (isNothing . ideclPkgQual)
+                   $ map unLoc hsmodImports
+           liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns
+
+fileModuleName :: HscEnv
+               -> FilePath
+               -> IO (Either ErrorMessages (Maybe ModuleName))
+fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do
+    src <- readFile fn
+    case parseModuleHeader src (hsc_dflags env) fn of
+      Left errs -> return (Left errs)
+      Right (_, lmdl) -> do
+        let HsModule {..} = unLoc lmdl
+        return $ Right $ unLoc <$> hsmodName
+
+parseModuleHeader
+    :: String         -- ^ Haskell module source text (full Unicode is supported)
+    -> DynFlags
+    -> FilePath       -- ^ the filename (for source locations)
+    -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
+parseModuleHeader str dflags filename =
+   let
+       loc  = mkRealSrcLoc (mkFastString filename) 1 1
+       buf  = stringToStringBuffer str
+   in
+   case unP Parser.parseHeader (mkPState dflags buf loc) of
+
+     PFailed sp err   ->
+         Left (unitBag (mkPlainErrMsg dflags sp err))
+
+     POk pst rdr_module ->
+         let (warns,_) = getMessages pst in
+         Right (warns, rdr_module)

Language/Haskell/GhcMod/Info.hs

@@ -7,16 +7,20 @@ import Control.Applicative ((<$>))
 import Data.Function (on)
 import Data.List (sortBy)
 import Data.Maybe (catMaybes)
+import System.FilePath
 import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
 import qualified GHC as G
-import Language.Haskell.GhcMod.Doc (showPage)
-import Language.Haskell.GhcMod.Gap (HasType(..))
 import qualified Language.Haskell.GhcMod.Gap as Gap
+
+import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Doc
+import Language.Haskell.GhcMod.DynFlags
+import Language.Haskell.GhcMod.Gap
+import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Convert
 
 ----------------------------------------------------------------
 
@@ -25,14 +29,21 @@ info :: IOish m
      => FilePath     -- ^ A target file.
      -> Expression   -- ^ A Haskell expression.
      -> GhcModT m String
-info file expr = do
+info file expr = runGmLoadedT' [Left file] deferErrors $ withContext $ do
     opt <- options
     convert opt <$> ghandle handler body
   where
-    body = inModuleContext file $ \dflag style -> do
+    handler (SomeException ex) = do
+        gmLog GmException "info" $
+                text "" $$ nest 4 (showDoc ex)
+        return "Cannot show info"
+
+    body = do
         sdoc <- Gap.infoThing expr
-        return $ showPage dflag style sdoc
+        st <- getStyle
-    handler (SomeException _) = return "Cannot show info"
+        dflag <- G.getSessionDynFlags
+        return $ showPage dflag st sdoc
+
 
 ----------------------------------------------------------------
 
@@ -42,15 +53,18 @@ types :: IOish m
       -> Int          -- ^ Line number.
       -> Int          -- ^ Column number.
       -> GhcModT m String
-types file lineNo colNo = do
+types file lineNo colNo =
-    opt <- options
+    runGmLoadedT' [Left file] deferErrors $ ghandle handler $ withContext $ do
-    convert opt <$> ghandle handler body
+        crdl <- cradle
-  where
+        modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
-    body = inModuleContext file $ \dflag style -> do
-        modSum <- Gap.fileModSummary file
         srcSpanTypes <- getSrcSpanType modSum lineNo colNo
-        return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
+
-    handler (SomeException _) = return []
+        dflag <- G.getSessionDynFlags
+        st <- getStyle
+
+        convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
+ where
+   handler (SomeException _) = return []
 
 getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
 getSrcSpanType modSum lineNo colNo = do

Language/Haskell/GhcMod/Internal.hs

@@ -8,28 +8,16 @@ module Language.Haskell.GhcMod.Internal (
   , PackageVersion
   , PackageId
   , IncludeDir
-  , CompilerOptions(..)
-  -- * Cabal API
-  , parseCabalFile
-  , getCompilerOptions
-  , cabalAllBuildInfo
-  , cabalSourceDirs
   -- * Various Paths
   , ghcLibDir
   , ghcModExecutable
-  -- * IO
-  , getDynamicFlags
-  -- * Targets
-  , setTargetFiles
   -- * Logging
   , withLogger
   , setNoWarningFlags
   , setAllWarningFlags
   -- * Environment, state and logging
   , GhcModEnv(..)
-  , newGhcModEnv
   , GhcModState
-  , defaultState
   , CompilerMode(..)
   , GhcModLog
   -- * Monad utilities
@@ -43,10 +31,6 @@ module Language.Haskell.GhcMod.Internal (
   , withOptions
   -- * 'GhcModError'
   , gmeDoc
-  -- * 'GhcMonad' Choice
-  , (||>)
-  , goNext
-  , runAnyOne
   -- * World
   , World
   , getCurrentWorld
@@ -55,13 +39,10 @@ module Language.Haskell.GhcMod.Internal (
 
 import GHC.Paths (libdir)
 
-import Language.Haskell.GhcMod.CabalApi
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.Error
-import Language.Haskell.GhcMod.GHCChoice
 import Language.Haskell.GhcMod.Logger
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Target
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.World

Language/Haskell/GhcMod/Logger.hs

@@ -1,30 +1,30 @@
-{-# LANGUAGE CPP #-}
-
 module Language.Haskell.GhcMod.Logger (
     withLogger
+  , withLogger'
   , checkErrorPrefix
   ) where
 
-import Bag (Bag, bagToList)
+import Control.Arrow
 import Control.Applicative ((<$>))
-import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
 import Data.List (isPrefixOf)
 import Data.Maybe (fromMaybe)
-import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
-import Exception (ghandle)
-import GHC (DynFlags, SrcSpan, Severity(SevError))
-import qualified GHC as G
-import HscTypes (SourceError, srcErrorMessages)
-import Language.Haskell.GhcMod.Doc (showPage, getStyle)
-import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)
-import qualified Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Convert (convert')
-import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Types
-import Outputable (PprStyle, SDoc)
 import System.FilePath (normalise)
+import Text.PrettyPrint
 
-----------------------------------------------------------------
+import Bag (Bag, bagToList)
+import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
+import GHC (DynFlags, SrcSpan, Severity(SevError))
+import HscTypes
+import Outputable
+import qualified GHC as G
+
+import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Doc (showPage)
+import Language.Haskell.GhcMod.DynFlags (withDynFlags)
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Error
+import qualified Language.Haskell.GhcMod.Gap as Gap
 
 type Builder = [String] -> [String]
 
@@ -38,16 +38,16 @@ emptyLog = Log [] id
 newLogRef :: IO LogRef
 newLogRef = LogRef <$> newIORef emptyLog
 
-readAndClearLogRef :: IOish m => LogRef -> GhcModT m String
+readAndClearLogRef :: LogRef -> IO [String]
 readAndClearLogRef (LogRef ref) = do
-    Log _ b <- liftIO $ readIORef ref
+    Log _ b <- readIORef ref
-    liftIO $ writeIORef ref emptyLog
+    writeIORef ref emptyLog
-    convert' (b [])
+    return $ b []
 
 appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
-appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update
+appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update
   where
-    l = ppMsg src sev df style msg
+    l = ppMsg src sev df st msg
     update lg@(Log ls b)
       | l `elem` ls = lg
       | otherwise   = Log (l:ls) (b . (l:))
@@ -57,56 +57,68 @@ appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update
 -- | Set the session flag (e.g. "-Wall" or "-w:") then
 --   executes a body. Logged messages are returned as 'String'.
 --   Right is success and Left is failure.
-withLogger :: IOish m
+withLogger :: (GmGhc m, GmEnv m)
            => (DynFlags -> DynFlags)
-           -> GhcModT m ()
+           -> m a
-           -> GhcModT m (Either String String)
+           -> m (Either String (String, a))
-withLogger setDF body = ghandle sourceError $ do
+withLogger f action = do
-    logref <- liftIO newLogRef
+  env <- G.getSession
-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
+  opts <- options
-    withDynFlags (setLogger logref . setDF) $
+  let conv = convert opts
-        withCmdFlags wflags $ do
+  eres <- withLogger' env $ \setDf ->
-            body
+      withDynFlags (f . setDf) action
-            Right <$> readAndClearLogRef logref
+  return $ either (Left . conv) (Right . first conv) eres
+
+withLogger' :: IOish m
+    => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
+withLogger' env action = do
+    logref <- liftIO $ newLogRef
+
+    let dflags = hsc_dflags env
+        pu = icPrintUnqual dflags (hsc_IC env)
+        st = mkUserStyle pu AllTheWay
+
+        fn df  = setLogger logref df
+
+    a <- gcatches (Right <$> action fn) (handlers dflags st)
+    ls <- liftIO $ readAndClearLogRef logref
+
+    return $ ((,) ls <$> a)
+
   where
     setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
+    handlers df st = [
+        GHandler $ \ex -> return $ Left $ sourceError df st ex,
+        GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
+     ]
 
 ----------------------------------------------------------------
 
 -- | Converting 'SourceError' to 'String'.
-sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
+sourceError :: DynFlags -> PprStyle -> SourceError -> [String]
-sourceError err = errBagToStr (srcErrorMessages err)
+sourceError df st src_err = errBagToStrList df st $ srcErrorMessages src_err
-
-errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)
-errBagToStr = errBagToStr' Left
-
-errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a
-errBagToStr' f err = do
-    dflags <- G.getSessionDynFlags
-    style <- getStyle
-    ret <- convert' (errBagToStrList dflags style err)
-    return $ f ret
 
 errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
-errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
+errBagToStrList df st = map (ppErrMsg df st) . reverse . bagToList
 
 ----------------------------------------------------------------
 
 ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
-ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext)
+ppErrMsg dflag st err =
+    ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext)
    where
      spn = Gap.errorMsgSpan err
      msg = errMsgShortDoc err
-     ext = showPage dflag style (errMsgExtraInfo err)
+     ext = showPage dflag st (errMsgExtraInfo err)
 
 ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
-ppMsg spn sev dflag style msg = prefix ++ cts
+ppMsg spn sev dflag st msg = prefix ++ cts
   where
-    cts  = showPage dflag style msg
+    cts  = showPage dflag st msg
-    prefix = ppMsgPrefix spn sev dflag style cts
+    prefix = ppMsgPrefix spn sev dflag st cts
 
 ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String
-ppMsgPrefix spn sev dflag _style cts =
+ppMsgPrefix spn sev dflag _st cts =
   let defaultPrefix
         | Gap.isDumpSplices dflag = ""
         | otherwise               = checkErrorPrefix

Language/Haskell/GhcMod/Logging.hs

@@ -1,4 +1,3 @@
-module Language.Haskell.GhcMod.Logging where
 -- ghc-mod: Making Haskell development *more* fun
 -- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
 --
@@ -15,22 +14,45 @@ module Language.Haskell.GhcMod.Logging where
 -- 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/>.
 
-import Language.Haskell.GhcMod.Types
+module Language.Haskell.GhcMod.Logging (
-import Language.Haskell.GhcMod.Monad.Types
+    module Language.Haskell.GhcMod.Logging
+  , module Language.Haskell.GhcMod.Pretty
+  , GmLogLevel(..)
+  , module Text.PrettyPrint
+  , module Data.Monoid
+  ) where
 
-import Control.Monad.Journal.Class
+import Control.Monad
-import Control.Monad.Trans.Class
+import Data.Monoid (mempty, mappend, mconcat, (<>))
 import System.IO
+import Text.PrettyPrint hiding (style, (<>))
 
-import MonadUtils
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Pretty
 
---gmSink :: IOish m => (GhcModLog -> IO ()) -> GhcModT m ()
+gmSetLogLevel :: GmLog m => GmLogLevel -> m ()
---gmSink = GhcModT . (lift . lift . sink)
+gmSetLogLevel level =
+    gmlJournal $ GhcModLog (Just level) []
 
-type GmLog m = MonadJournal GhcModLog m
+increaseLogLevel :: GmLogLevel -> GmLogLevel
+increaseLogLevel l | l == maxBound = l
+increaseLogLevel l = succ l
 
-gmJournal :: IOish m => GhcModLog -> GhcModT m ()
+-- |
-gmJournal = GhcModT . lift . lift . journal
+-- >>> Just GmDebug <= Nothing
+-- False
+-- >>> Just GmException <= Just GmDebug
+-- True
+-- >>> Just GmDebug <= Just GmException
+-- False
+gmLog :: (MonadIO m, GmLog m) => GmLogLevel -> String -> Doc -> m ()
+gmLog level loc' doc = do
+  GhcModLog { gmLogLevel = level' } <- gmlHistory
 
-gmLog :: (MonadIO m, MonadJournal GhcModLog m) => String -> m ()
+  let loc | loc' == "" = empty
-gmLog str = liftIO (hPutStrLn stderr str) >> (journal $ GhcModLog [str])
+          | otherwise = text (head $ lines loc') <> colon
+      msg = gmRenderDoc $ gmLogLevelDoc level <+> loc <+> doc
+
+  when (Just level <= level') $
+       liftIO $ hPutStrLn stderr msg
+  gmlJournal (GhcModLog Nothing [(level, render loc, msg)])

Language/Haskell/GhcMod/Modules.hs

@@ -1,6 +1,5 @@
 module Language.Haskell.GhcMod.Modules (modules) where
 
-import Control.Applicative ((<$>))
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
@@ -10,5 +9,7 @@ import Module (moduleNameString)
 ----------------------------------------------------------------
 
 -- | Listing installed modules.
-modules :: IOish m => GhcModT m String
+modules :: (IOish m, GmEnv m) => m String
-modules = convert' =<< map moduleNameString . listVisibleModuleNames <$> G.getSessionDynFlags
+modules = do
+  dflags <- runGmPkgGhc G.getSessionDynFlags
+  convert' $ map moduleNameString $ listVisibleModuleNames dflags

Language/Haskell/GhcMod/Monad.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP, RecordWildCards #-}
 -- ghc-mod: Making Haskell development *more* fun
 -- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
 --
@@ -14,166 +13,74 @@
 --
 -- 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 #-}
 module Language.Haskell.GhcMod.Monad (
-  -- * Monad Types
+    runGhcModT
-    GhcModT
-  , IOish
-  -- ** Environment, state and logging
-  , GhcModEnv(..)
-  , newGhcModEnv
-  , GhcModState(..)
-  , defaultState
-  , CompilerMode(..)
-  , GhcModLog
-  , GhcModError(..)
-  -- * Monad utilities
-  , runGhcModT
   , runGhcModT'
+  , runGhcModT''
   , hoistGhcModT
-  -- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'
+  , runGmLoadedT
-  , gmsGet
+  , runGmLoadedT'
-  , gmsPut
+  , runGmLoadedTWith
-  , gmLog
+  , runGmPkgGhc
-  , options
+  , withGhcModEnv
-  , cradle
+  , withGhcModEnv'
-  , getCompilerMode
+  , module Language.Haskell.GhcMod.Monad.Types
-  , setCompilerMode
-  , withOptions
-  , withTempSession
-  -- ** Re-exporting convenient stuff
-  , liftIO
-  , module Control.Monad.Reader.Class
   ) where
 
 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.Logging
 import Language.Haskell.GhcMod.Cradle
-import Language.Haskell.GhcMod.DynFlags
+import Language.Haskell.GhcMod.Target
-import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.CabalApi
-import Language.Haskell.GhcMod.CabalConfig
-import qualified Language.Haskell.GhcMod.Gap as Gap
-
-import GHC
-import qualified GHC as G
-import GHC.Paths (libdir)
-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.Arrow (first)
-import Control.Monad (void)
+import Control.Applicative
-#if !MIN_VERSION_monad_control(1,0,0)
-import Control.Monad (liftM)
-#endif
-import Control.Monad.Base (liftBase)
 
-import Control.Monad.Reader.Class
-import Control.Monad.State.Class (MonadState(..))
-
-import Control.Monad.Error (runErrorT)
 import Control.Monad.Reader (runReaderT)
 import Control.Monad.State.Strict (runStateT)
 import Control.Monad.Trans.Journal (runJournalT)
 
-import Data.Maybe (isJust)
+import Exception (ExceptionMonad(..))
-import Data.IORef
-import System.Directory (getCurrentDirectory)
 
-----------------------------------------------------------------
+import System.Directory
 
--- | Initialize the 'DynFlags' relating to the compilation of a single
+withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
--- file or GHC session according to the 'Cradle' and 'Options'
+withCradle cradledir f =
--- provided.
+    gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f
-initializeFlagsWithCradle :: (IOish m, GhcMonad m, GmError m, GmLog m)
-        => Options
-        -> Cradle
-        -> CabalConfig
-        -> m ()
-initializeFlagsWithCradle opt c config
-  | cabal     = withCabal
-  | otherwise = withSandbox
-  where
-    mCabalFile = cradleCabalFile c
 
-    cabal = isJust mCabalFile
+withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
+withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f)
 
-    ghcopts = ghcUserOptions opt
+withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a
-
+withGhcModEnv' opt f crdl = do
-    withCabal = do
+    olddir <- liftIO getCurrentDirectory
-        let Just cabalFile = mCabalFile
+    gbracket_ (liftIO $ setCurrentDirectory $ cradleRootDir crdl)
-        pkgDesc <- parseCabalFile config cabalFile
+              (liftIO $ setCurrentDirectory olddir)
-        compOpts <- getCompilerOptions ghcopts c config pkgDesc
+              (f $ GhcModEnv opt crdl)
-        initSession CabalPkg opt compOpts
+ where
-
+   gbracket_ ma mb mc = gbracket ma (const mb) (const mc)
-    withSandbox = initSession SingleFile opt compOpts
-      where
-        importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
-
-        pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c
-
-        compOpts
-          | null pkgOpts = CompilerOptions ghcopts importDirs []
-          | otherwise    = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []
-
-        (wdir, rdir) = (cradleCurrentDir c, cradleRootDir c)
-
-initSession :: GhcMonad m
-            => Build
-            -> Options
-            -> CompilerOptions
-            -> m ()
-initSession build Options {..} CompilerOptions {..} = do
-    df <- G.getSessionDynFlags
-    void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions
-      ( setModeSimple
-      $ Gap.setFlags
-      $ setIncludeDirs includeDirs
-      $ setBuildEnv build
-      $ setEmptyLogger
-      $ Gap.addPackageFlags depPackages df)
-
-----------------------------------------------------------------
-
-newGhcModEnv :: Options -> FilePath -> IO GhcModEnv
-newGhcModEnv opt dir = do
-      session <- newIORef (error "empty session")
-      c <- findCradle' dir
-      return GhcModEnv {
-          gmGhcSession = session
-        , gmOptions = opt
-        , gmCradle = c
-        }
-
-cleanupGhcModEnv :: GhcModEnv -> IO ()
-cleanupGhcModEnv env = cleanupCradle $ gmCradle env
 
 -- | Run a @GhcModT m@ computation.
 runGhcModT :: IOish m
            => Options
            -> GhcModT m a
            -> m (Either GhcModError a, GhcModLog)
-runGhcModT opt action = gbracket newEnv delEnv $ \env -> do
+runGhcModT opt action = do
-    r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
+    dir <- liftIO getCurrentDirectory
-        dflags <- getSessionDynFlags
+    runGhcModT' dir opt action
-        defaultCleanupHandler dflags $ do
-            config <- cabalGetConfig =<< cradle
-            initializeFlagsWithCradle opt (gmCradle env) config
-            action )
-    return r
 
- where
+runGhcModT' :: IOish m
-   newEnv = liftBase $ newGhcModEnv opt =<< getCurrentDirectory
+            => FilePath
-   delEnv = liftBase . cleanupGhcModEnv
+            -> Options
+            -> GhcModT m a
+            -> m (Either GhcModError a, GhcModLog)
+runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
+    withGhcModEnv dir' opt $ \env ->
+      first (fst <$>) <$> runGhcModT'' env defaultGhcModState
+        (gmSetLogLevel (logLevel opt) >> action)
 
 -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
 -- computation. Note that if the computation that returned @result@ modified the
@@ -182,7 +89,7 @@ hoistGhcModT :: IOish m
              => (Either GhcModError a, GhcModLog)
              -> GhcModT m a
 hoistGhcModT (r,l) = do
-  gmJournal l >> case r of
+  gmlJournal l >> case r of
     Left e -> throwError e
     Right a -> return a
 
@@ -191,57 +98,10 @@ hoistGhcModT (r,l) = do
 -- do with 'GhcModEnv' and 'GhcModState'.
 --
 -- You should probably look at 'runGhcModT' instead.
-runGhcModT' :: IOish m
+runGhcModT'' :: IOish m
-           => GhcModEnv
+             => GhcModEnv
-           -> GhcModState
+             -> GhcModState
-           -> GhcModT m a
+             -> GhcModT m a
-           -> m (Either GhcModError (a, GhcModState), GhcModLog)
+             -> m (Either GhcModError (a, GhcModState), GhcModLog)
-runGhcModT' r s a = do
+runGhcModT'' r s a = do
-  (res, w') <-
+  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s
-      flip runReaderT r $ runJournalT $ runErrorT $
-        runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s
-  return (res, w')
-----------------------------------------------------------------
--- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the
--- original 'HscEnv'.
-withTempSession :: IOish m => GhcModT m a -> GhcModT m a
-withTempSession action = do
-  session <- gmGhcSession <$> ask
-  savedHscEnv <- liftIO $ readIORef session
-  a <- action
-  liftIO $ writeIORef session savedHscEnv
-  return a
-
-----------------------------------------------------------------
-
-gmeAsk :: IOish m => GhcModT m GhcModEnv
-gmeAsk = ask
-
-gmsGet :: IOish m => GhcModT m GhcModState
-gmsGet = GhcModT get
-
-gmsPut :: IOish m => GhcModState -> GhcModT m ()
-gmsPut = GhcModT . put
-
-options :: IOish m => GhcModT m Options
-options = gmOptions <$> gmeAsk
-
-cradle :: IOish m => GhcModT m Cradle
-cradle = gmCradle <$> gmeAsk
-
-getCompilerMode :: IOish m => GhcModT m CompilerMode
-getCompilerMode = gmCompilerMode <$> gmsGet
-
-setCompilerMode :: IOish m => CompilerMode -> GhcModT m ()
-setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
-
-----------------------------------------------------------------
-
-withOptions :: IOish m => (Options -> Options) -> GhcModT m a -> GhcModT m a
-withOptions changeOpt action = local changeEnv action
-  where
-    changeEnv e = e { gmOptions = changeOpt opt }
-      where
-        opt = gmOptions e
-
-----------------------------------------------------------------

Language/Haskell/GhcMod/Monad/Types.hs

@@ -16,13 +16,45 @@
 
 {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
-{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
+{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-}
-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE StandaloneDeriving, InstanceSigs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Language.Haskell.GhcMod.Monad.Types where
+module Language.Haskell.GhcMod.Monad.Types (
-
+  -- * Monad Types
+    GhcModT(..)
+  , GmLoadedT(..)
+  , LightGhc(..)
+  , GmGhc
+  , IOish
+  -- ** Environment, state and logging
+  , GhcModEnv(..)
+  , GhcModState(..)
+  , defaultGhcModState
+  , GmGhcSession(..)
+  , GmComponent(..)
+  , CompilerMode(..)
+  -- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'
+  , GmLogLevel(..)
+  , GhcModLog(..)
+  , GhcModError(..)
+  , GmEnv(..)
+  , GmState(..)
+  , GmLog(..)
+  , cradle
+  , options
+  , withOptions
+  , getCompilerMode
+  , setCompilerMode
+  -- ** Re-exporting convenient stuff
+  , MonadIO
+  , liftIO
+  ) where
 
+-- 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
 #if __GLASGOW_HASKELL__ < 708
 -- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
 -- classes before ghc 7.8
@@ -33,37 +65,28 @@ module Language.Haskell.GhcMod.Monad.Types where
 #endif
 
 import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Error
 
 import GHC
 import DynFlags
-import GhcMonad hiding (withTempSession)
+import Exception
-#if __GLASGOW_HASKELL__ <= 702
 import HscTypes
-#endif
 
--- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
+import Control.Applicative (Applicative, Alternative, (<$>))
--- RWST does not automatically become an instance of MonadIO.
+import Control.Monad
--- 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.Reader (ReaderT(..))
-import Control.Monad (MonadPlus)
+import Control.Monad.Error (ErrorT(..), MonadError(..))
-import Control.Monad.Error (ErrorT)
+import Control.Monad.State.Strict (StateT(..))
-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.Base (MonadBase(..), liftBase)
-import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
+import Control.Monad.Trans.Control
-  control, liftBaseOp, liftBaseOp_)
 
-import Control.Monad.Trans.Class
 import Control.Monad.Reader.Class
-import Control.Monad.Writer.Class (MonadWriter)
+import Control.Monad.Writer.Class
 import Control.Monad.State.Class (MonadState(..))
 import Control.Monad.Journal.Class (MonadJournal(..))
+import Control.Monad.Trans.Class (MonadTrans(..))
 
 #ifdef MONADIO_INSTANCES
 import Control.Monad.Trans.Maybe (MaybeT)
@@ -71,41 +94,49 @@ 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 Data.Set (Set)
-import Control.Monad (liftM)
+import Data.Map (Map, empty)
-#endif
+import Data.Maybe
-
 import Data.Monoid
 import Data.IORef
 
+import MonadUtils (MonadIO(..))
+
 data GhcModEnv = GhcModEnv {
-      gmGhcSession :: !(IORef HscEnv)
+      gmOptions    :: Options
-    , gmOptions    :: Options
     , gmCradle     :: Cradle
     }
 
 data GhcModLog = GhcModLog {
-      gmLogMessages :: [String]
+      gmLogLevel    :: Maybe GmLogLevel,
+      gmLogMessages :: [(GmLogLevel, String, String)]
     } deriving (Eq, Show, Read)
 
 instance Monoid GhcModLog where
-    mempty = GhcModLog mempty
+    mempty = GhcModLog (Just GmPanic) mempty
-    GhcModLog a `mappend` GhcModLog b = GhcModLog (a `mappend` b)
+    GhcModLog ml a `mappend` GhcModLog ml' b =
+        GhcModLog (ml' `mplus` ml) (a `mappend` b)
+
+data GmGhcSession = GmGhcSession {
+      gmgsOptions :: ![GHCOption],
+      gmgsSession :: !(IORef HscEnv)
+    }
 
 data GhcModState = GhcModState {
-      gmCompilerMode :: CompilerMode
+      gmGhcSession   :: !(Maybe GmGhcSession)
-    } deriving (Eq,Show,Read)
+    , gmComponents   :: !(Map GmComponentName (GmComponent (Set ModulePath)))
+    , gmCompilerMode :: !CompilerMode
+    }
+
+defaultGhcModState :: GhcModState
+defaultGhcModState = GhcModState Nothing empty Simple
 
 data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
 
-defaultState :: GhcModState
-defaultState = GhcModState Simple
-
 ----------------------------------------------------------------
 
 -- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'
@@ -130,39 +161,111 @@ newtype GhcModT m a = GhcModT {
 #if DIFFERENT_MONADIO
                , Control.Monad.IO.Class.MonadIO
 #endif
-               , MonadReader GhcModEnv -- TODO: make MonadReader instance
-                                       -- pass-through like MonadState
-               , MonadWriter w
                , MonadError GhcModError
                )
 
+newtype GmLoadedT m a = GmLoadedT { unGmLoadedT :: GhcModT m a }
+    deriving ( Functor
+             , Applicative
+             , Alternative
+             , Monad
+             , MonadPlus
+             , MonadTrans
+             , MonadIO
+#if DIFFERENT_MONADIO
+             , Control.Monad.IO.Class.MonadIO
+#endif
+             , MonadError GhcModError
+             , GmEnv
+             , GmState
+             , GmLog
+             )
+
+newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }
+    deriving ( Functor
+             , Applicative
+             , Monad
+             , MonadIO
+#if DIFFERENT_MONADIO
+             , Control.Monad.IO.Class.MonadIO
+#endif
+             )
+
+
+class Monad m => GmEnv m where
+    gmeAsk :: m GhcModEnv
+    gmeAsk = gmeReader id
+
+    gmeReader :: (GhcModEnv -> a) -> m a
+    gmeReader f = f `liftM` gmeAsk
+
+    gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a
+    {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}
+
+instance Monad m => GmEnv (GhcModT m) where
+    gmeAsk = GhcModT ask
+    gmeReader = GhcModT . reader
+    gmeLocal f a = GhcModT $ local f (unGhcModT a)
+
+instance GmEnv m => GmEnv (StateT s m) where
+    gmeAsk = lift gmeAsk
+    gmeReader = lift . gmeReader
+    gmeLocal f (StateT a) = StateT $ \s -> gmeLocal f (a s)
+
+class Monad m => GmState m where
+    gmsGet :: m GhcModState
+    gmsGet = gmsState (\s -> (s, s))
+
+    gmsPut :: GhcModState -> m ()
+    gmsPut s = gmsState (\_ -> ((), s))
+
+    gmsState :: (GhcModState -> (a, GhcModState)) -> m a
+    gmsState f = do
+      s <- gmsGet
+      let ~(a, s') = f s
+      gmsPut s'
+      return a
+    {-# MINIMAL gmsState | gmsGet, gmsPut #-}
+
+instance Monad m => GmState (StateT GhcModState m) where
+    gmsGet = get
+    gmsPut = put
+    gmsState = state
+
+instance Monad m => GmState (GhcModT m) where
+    gmsGet = GhcModT get
+    gmsPut = GhcModT . put
+    gmsState = GhcModT . state
+
+class Monad m => GmLog m where
+    gmlJournal :: GhcModLog -> m ()
+    gmlHistory :: m GhcModLog
+    gmlClear   :: m ()
+
+instance Monad m => GmLog (JournalT GhcModLog m) where
+    gmlJournal = journal
+    gmlHistory = history
+    gmlClear   = clear
+
+instance Monad m => GmLog (GhcModT m) where
+    gmlJournal = GhcModT . lift . lift . journal
+    gmlHistory = GhcModT $ lift $ lift history
+    gmlClear   = GhcModT $ lift $ lift clear
+
+instance (Monad m, GmLog m) => GmLog (ReaderT r m) where
+    gmlJournal = lift . gmlJournal
+    gmlHistory = lift gmlHistory
+    gmlClear = lift  gmlClear
+
+instance (Monad m, GmLog m) => GmLog (StateT s m) where
+    gmlJournal = lift . gmlJournal
+    gmlHistory = lift gmlHistory
+    gmlClear = lift gmlClear
+
 instance MonadIO m => MonadIO (GhcModT m) where
-    liftIO action = do
+    liftIO action = GhcModT $ liftIO action
-      res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action
-      case res of
-        Right a -> return a
 
-        Left e | isIOError e ->
+instance Monad m => MonadJournal GhcModLog (GhcModT m) where
-                   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
@@ -170,6 +273,18 @@ instance (Monad m) => MonadJournal GhcModLog (GhcModT m) where
 instance MonadTrans GhcModT where
     lift = GhcModT . lift . lift . lift . lift
 
+instance forall r m. MonadReader r m => MonadReader r (GhcModT m) where
+    local f ma = gmLiftWithInner (\run -> local f (run ma))
+    ask = gmLiftInner ask
+
+instance (Monoid w, MonadWriter w m) => MonadWriter w (GhcModT m) where
+    tell = gmLiftInner . tell
+    listen ma =
+      liftWith (\run -> listen (run ma)) >>= \(sta, w) ->
+          flip (,) w `liftM` restoreT (return sta)
+
+    pass maww = maww >>= gmLiftInner . pass . return
+
 instance MonadState s m => MonadState s (GhcModT m) where
     get = GhcModT $ lift $ lift $ lift get
     put = GhcModT . lift . lift . lift . put
@@ -192,12 +307,24 @@ instance MonadIO m => MonadIO (MaybeT m) where
     liftIO = lift . liftIO
 #endif
 
+instance (MonadBaseControl IO m) => MonadBase IO (GmLoadedT m) where
+    liftBase = GmLoadedT . liftBase
+
+instance (MonadBaseControl IO m) => MonadBaseControl IO (GmLoadedT m) where
+    type StM (GmLoadedT m) a = StM (GhcModT m) a
+    liftBaseWith = defaultLiftBaseWith
+    restoreM = defaultRestoreM
+    {-# INLINE liftBaseWith #-}
+    {-# INLINE restoreM #-}
+
+instance MonadTransControl GmLoadedT where
+    type StT GmLoadedT a = StT GhcModT a
+    liftWith = defaultLiftWith GmLoadedT unGmLoadedT
+    restoreT = defaultRestoreT GmLoadedT
 
 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
@@ -211,94 +338,109 @@ instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
     {-# INLINE liftBaseWith #-}
     {-# INLINE restoreM #-}
 
-#else
+instance MonadTransControl GhcModT where
+    type StT GhcModT a = (Either GhcModError (a, GhcModState), GhcModLog)
 
-instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
+    liftWith f = GhcModT $
-    newtype StM (GhcModT m) a = StGhcMod {
+      liftWith $ \runS ->
-          unStGhcMod :: StM (StateT GhcModState
+        liftWith $ \runE ->
-                              (ErrorT GhcModError
+          liftWith $ \runJ ->
-                                (JournalT GhcModLog
+            liftWith $ \runR ->
-                                  (ReaderT GhcModEnv m) ) ) ) a }
+              f $ \ma -> runR $ runJ $ runE $ runS $ unGhcModT ma
-    liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
+    restoreT = GhcModT . restoreT . restoreT . restoreT . restoreT
-        f $ liftM StGhcMod . runInBase . unGhcModT
+    {-# INLINE liftWith #-}
+    {-# INLINE restoreT #-}
 
-    restoreM = GhcModT . restoreM . unStGhcMod
+gmLiftInner :: Monad m => m a -> GhcModT m a
-    {-# INLINE liftBaseWith #-}
+gmLiftInner = GhcModT . lift . lift . lift . lift
-    {-# INLINE restoreM #-}
 
-#endif
+gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))
+                => (Run t -> m (StT t a)) -> t m a
+gmLiftWithInner f = liftWith f >>= restoreT . return
 
 -- 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.
+-- @MonadBaseControl IO m@ constraint in 'IOish' 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)
+type GmGhc m = (IOish m, GhcMonad m)
-      => GhcMonad (GhcModT m) where
+
-    getSession = (liftIO . readIORef) . gmGhcSession =<< ask
+instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmLoadedT m) where
-    setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask
+    getSession = do
+        ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
+        liftIO $ readIORef ref
+    setSession a = do
+        ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
+        liftIO $ flip writeIORef a ref
+
+instance GhcMonad LightGhc where
+    getSession = (liftIO . readIORef) =<< LightGhc ask
+    setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask
 
 #if __GLASGOW_HASKELL__ >= 706
-instance (Functor m, MonadIO m, MonadBaseControl IO m)
+instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmLoadedT m) where
-      => HasDynFlags (GhcModT m) where
+    getDynFlags = hsc_dflags <$> getSession
-    getDynFlags = getSessionDynFlags
+
+instance HasDynFlags LightGhc where
+    getDynFlags = hsc_dflags <$> getSession
 #endif
 
-instance (MonadIO m, MonadBaseControl IO m)
+instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GhcModT m) where
-      => 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
+
+instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmLoadedT m) where
+    gcatch act handler = control $ \run ->
+        run act `gcatch` (run . handler)
+
+    gmask = liftBaseOp gmask . liftRestore
+     where liftRestore f r = f $ liftBaseOp_ r
+
+instance ExceptionMonad LightGhc where
+  gcatch act handl =
+      LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e)
+  gmask f =
+      LightGhc $ gmask $ \io_restore ->let
+          g_restore (LightGhc m) = LightGhc $ io_restore m
+      in
+        unLightGhc (f g_restore)
+
+
+instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where
+    gcatch act handler = control $ \run ->
+        run act `gcatch` (run . handler)
+
+    gmask = liftBaseOp gmask . liftRestore
+     where liftRestore f r = f $ liftBaseOp_ r
+
+instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where
+    gcatch act handler = control $ \run ->
+        run act `gcatch` (run . handler)
+
+    gmask = liftBaseOp gmask . liftRestore
+     where liftRestore f r = f $ liftBaseOp_ r
+
+----------------------------------------------------------------
+
+options :: GmEnv m => m Options
+options = gmOptions `liftM` gmeAsk
+
+cradle :: GmEnv m => m Cradle
+cradle = gmCradle `liftM` gmeAsk
+
+getCompilerMode :: GmState m => m CompilerMode
+getCompilerMode = gmCompilerMode `liftM` gmsGet
+
+setCompilerMode :: GmState m => CompilerMode -> m ()
+setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
+
+withOptions :: GmEnv m => (Options -> Options) -> m a -> m a
+withOptions changeOpt action = gmeLocal changeEnv action
+  where
+    changeEnv e = e { gmOptions = changeOpt opt }
+      where
+        opt = gmOptions e

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns, TupleSections #-}
 -- ghc-mod: Making Haskell development *more* fun
 -- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
 --
@@ -20,28 +19,79 @@ module Language.Haskell.GhcMod.PathsAndFiles where
 import Config (cProjectVersion)
 import Control.Applicative
 import Control.Monad
+import Control.Monad.Trans.Maybe
 import Data.List
 import Data.Char
 import Data.Maybe
 import Data.Traversable (traverse)
-import Distribution.System (buildPlatform)
+import Types
-import Distribution.Text (display)
-import Language.Haskell.GhcMod.Types
 import System.Directory
 import System.FilePath
+import System.IO.Unsafe
 
+import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Error
+import Language.Haskell.GhcMod.Read
+import Language.Haskell.GhcMod.Utils hiding (dropWhileEnd)
 import qualified Language.Haskell.GhcMod.Utils as U
 
-import Distribution.Simple.BuildPaths (defaultDistPref)
-import Distribution.Simple.Configure (localBuildInfoFile)
-
 -- | Guaranteed to be a path to a directory with no trailing slash.
 type DirPath = FilePath
 
 -- | Guaranteed to be the name of a file only (no slashes).
 type FileName = String
 
+data Cached d a = Cached {
+      inputFiles :: [FilePath],
+      inputData  :: d,
+      cacheFile  :: FilePath
+    }
+
+newtype UnString = UnString { unString :: String }
+
+instance Show UnString where
+    show = unString
+
+instance Read UnString where
+    readsPrec _ = \str -> [(UnString str, "")]
+
+-- |
+--
+-- >>> any (Just 3 <) [Just 1, Nothing, Just 2]
+-- False
+--
+-- >>> any (Just 0 <) [Just 1, Nothing, Just 2]
+-- True
+--
+-- >>> any (Just 0 <) [Nothing]
+-- False
+--
+-- >>> any (Just 0 <) []
+-- False
+cached :: forall a d. (Read a, Show a, Eq d, Read d, Show d)
+       => DirPath -> Cached d a -> IO a -> IO a
+cached dir Cached {..} ma = do
+    ins <- (maybeTimeFile . (dir </>)) `mapM` inputFiles
+    c <- maybeTimeFile (dir </> cacheFile)
+    if any (c<) ins || isNothing c
+       then writeCache
+       else maybe ma return =<< readCache
+ where
+   maybeTimeFile :: FilePath -> IO (Maybe TimedFile)
+   maybeTimeFile f = traverse timeFile =<< mightExist f
+
+   writeCache = do
+     a <- ma
+     writeFile (dir </> cacheFile) $ unlines [show inputData, show a]
+     return a
+
+   readCache :: IO (Maybe a)
+   readCache = runMaybeT $ do
+     hdr:c:_ <- lines <$> liftIO (readFile $ dir </> cacheFile)
+     if inputData /= read hdr
+       then liftIO $ writeCache
+       else MaybeT $ return $ readMaybe c
+
 -- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent
 -- directories. The first parent directory containing more than one cabal file
 -- is assumed to be the project directory. If only one cabal file exists in this
@@ -49,13 +99,17 @@ type FileName = String
 -- or 'GMETooManyCabalFiles'
 findCabalFile :: FilePath -> IO (Maybe FilePath)
 findCabalFile dir = do
-    dcs <- findFileInParentsP  isCabalFile dir
+    -- List of directories and all cabal file candidates
-    -- Extract first non-empty list, which represents a directory with cabal
+    dcs <- findFileInParentsP  isCabalFile dir :: IO ([(DirPath, [FileName])])
-    -- files.
+    let css = uncurry appendDir `map` dcs :: [[FilePath]]
-    case find (not . null) $ uncurry appendDir `map` dcs of
+    case find (not . null) css of
-      Just []          -> throw $ GMENoCabalFile
+      Nothing -> return Nothing
       Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
-      a  -> return $ head <$> a
+      Just (a:_)       -> return (Just a)
+      Just []          -> error "findCabalFile"
+ where
+   appendDir :: DirPath -> [FileName] -> [FilePath]
+   appendDir d fs = (d </>) `map` fs
 
 -- |
 -- >>> isCabalFile "/home/user/.cabal"
@@ -105,11 +159,8 @@ findCabalSandboxDir dir = do
  where
    isSandboxConfig = (=="cabal.sandbox.config")
 
-appendDir :: DirPath -> [FileName] -> [FilePath]
-appendDir d fs = (d </>) `map` fs
-
 zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
-zipMapM f as = mapM (\a -> liftM (a,) $ f a) as
+zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
 
 -- | @parents dir@. Returns all parent directories of @dir@ including @dir@.
 --
@@ -169,24 +220,29 @@ setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
 
 -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
 setupConfigPath :: FilePath
-setupConfigPath = localBuildInfoFile defaultDistPref
+setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref
 
 ghcSandboxPkgDbDir :: String
 ghcSandboxPkgDbDir =
-   targetPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"
+   cabalBuildPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"
-  where
+
-    targetPlatform = display buildPlatform
+cabalBuildPlatform :: String
+cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $
+    readLibExecProcess' "cabal-helper-wrapper" ["print-build-platform"]
 
 packageCache :: String
 packageCache = "package.cache"
 
--- | Filename of the show'ed Cabal setup-config cache
+cabalHelperCache :: [String] -> Cached [String] [Maybe GmCabalHelperResponse]
-prettyConfigCache :: FilePath
+cabalHelperCache cmds = Cached {
-prettyConfigCache = setupConfigPath <.> "ghc-mod-0.pretty-cabal-cache"
+    inputFiles = [setupConfigPath],
+    inputData  = cmds,
+    cacheFile  = setupConfigPath <.> "ghc-mod.cabal-helper"
+  }
 
 -- | Filename of the symbol table cache file.
 symbolCache :: Cradle -> FilePath
 symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
 
 symbolCacheFile :: String
-symbolCacheFile = "ghc-mod-0.symbol-cache"
+symbolCacheFile = "ghc-mod.symbol-cache"

Language/Haskell/GhcMod/PkgDoc.hs

@@ -11,11 +11,11 @@ import Control.Applicative ((<$>))
 pkgDoc :: IOish m => String -> GhcModT m String
 pkgDoc mdl = do
     c <- cradle
-    pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c)
+    pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts c) ""
     if pkg == "" then
         return "\n"
       else do
-        htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c)
+        htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg c) ""
         let ret = pkg ++ " " ++ drop 14 htmlpath
         return ret
   where

Language/Haskell/GhcMod/Pretty.hs

@@ -0,0 +1,64 @@
+-- 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 Language.Haskell.GhcMod.Pretty where
+
+import Control.Arrow hiding ((<+>))
+import Text.PrettyPrint
+
+import Language.Haskell.GhcMod.Types
+
+docStyle :: Style
+docStyle = style { ribbonsPerLine = 1.2 }
+
+gmRenderDoc :: Doc -> String
+gmRenderDoc = renderStyle docStyle
+
+gmComponentNameDoc :: GmComponentName -> Doc
+gmComponentNameDoc GmSetupHsName   = text $ "Setup.hs"
+gmComponentNameDoc GmLibName       = text $ "library"
+gmComponentNameDoc (GmExeName n)   = text $ "exe:" ++ n
+gmComponentNameDoc (GmTestName n)  = text $ "test:" ++ n
+gmComponentNameDoc (GmBenchName n) = text $ "bench:" ++ n
+
+gmLogLevelDoc :: GmLogLevel -> Doc
+gmLogLevelDoc GmPanic     = text "PANIC"
+gmLogLevelDoc GmException = text "EXCEPTION"
+gmLogLevelDoc GmError     = text "ERROR"
+gmLogLevelDoc GmWarning   = text "Warning"
+gmLogLevelDoc GmInfo      = text "info"
+gmLogLevelDoc GmDebug     = text "DEBUG"
+
+infixl 6 <+>:
+(<+>:) :: Doc -> Doc -> Doc
+a <+>: b = (a <> colon) <+> b
+
+fnDoc :: FilePath -> Doc
+fnDoc = doubleQuotes . text
+
+showDoc :: Show a => a -> Doc
+showDoc = text . show
+
+warnDoc :: Doc -> Doc
+warnDoc d = text "Warning" <+>: d
+
+strDoc :: String -> Doc
+strDoc str = doc str
+ where
+   doc :: String -> Doc
+   doc = lines
+         >>> map (words >>> map text >>> fsep)
+         >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty

Language/Haskell/GhcMod/SrcUtils.hs

@@ -13,12 +13,9 @@ import qualified GHC as G
 import GHC.SYB.Utils (Stage(..), everythingStaged)
 import GhcMonad
 import qualified Language.Haskell.Exts.Annotated as HE
-import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)
+import Language.Haskell.GhcMod.Doc
-import Language.Haskell.GhcMod.DynFlags
+import Language.Haskell.GhcMod.Gap
-import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
 import qualified Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
-import Language.Haskell.GhcMod.Target (setTargetFiles)
 import OccName (OccName)
 import Outputable (PprStyle)
 import TcHsSyn (hsPatType)
@@ -83,22 +80,6 @@ typeSigInRangeHE _  _ _= False
 pretty :: DynFlags -> PprStyle -> Type -> String
 pretty dflag style = showOneLine dflag style . Gap.typeForUser
 
-----------------------------------------------------------------
-
-inModuleContext :: IOish m
-                => FilePath
-                -> (DynFlags -> PprStyle -> GhcModT m a)
-                -> GhcModT m a
-inModuleContext file action =
-    withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do
-    setTargetFiles [file]
-    Gap.withContext $ do
-        dflag <- G.getSessionDynFlags
-        style <- getStyle
-        action dflag style
-
-----------------------------------------------------------------
-
 showName :: DynFlags -> PprStyle -> G.Name -> String
 showName dflag style name = showOneLine dflag style $ Gap.nameForUser name
 

Language/Haskell/GhcMod/Target.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE CPP #-}
-module Language.Haskell.GhcMod.Target (
-    setTargetFiles
-  ) where
 -- ghc-mod: Making Haskell development *more* fun
 -- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
 --
@@ -18,56 +14,319 @@ module Language.Haskell.GhcMod.Target (
 -- 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, ViewPatterns, NamedFieldPuns, RankNTypes #-}
+module Language.Haskell.GhcMod.Target where
+
+import Control.Arrow
 import Control.Applicative ((<$>))
-import Control.Monad (forM, void, (>=>))
+import Control.Monad.Reader (runReaderT)
-import DynFlags (ExtensionFlag(..), xopt)
+import GHC
-import GHC (LoadHowMuch(..))
+import GHC.Paths (libdir)
-import qualified GHC as G
+import StaticFlags
+import SysTools
+import DynFlags
+import HscMain
+import HscTypes
+
 import Language.Haskell.GhcMod.DynFlags
-import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.CabalHelper
+import Language.Haskell.GhcMod.HomeModuleGraph
+import Language.Haskell.GhcMod.GhcPkg
+import Language.Haskell.GhcMod.Error
+import Language.Haskell.GhcMod.Logging
+import Language.Haskell.GhcMod.Types
+
+import Data.Maybe
+import Data.Either
+import Data.Foldable (foldrM)
+import Data.IORef
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict  as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import System.Directory
+import System.FilePath
+
+withLightHscEnv :: forall m a. IOish m
+    => [GHCOption] -> (HscEnv -> m a) -> m a
+withLightHscEnv opts action = gbracket initEnv teardownEnv (action)
+
+ where
+   teardownEnv :: HscEnv -> m ()
+   teardownEnv env = liftIO $ do
+       let dflags = hsc_dflags env
+       cleanTempFiles dflags
+       cleanTempDirs dflags
+
+   initEnv :: m HscEnv
+   initEnv = liftIO $ do
+     initStaticOpts
+     settings <- initSysTools (Just libdir)
+     dflags  <- initDynFlags (defaultDynFlags settings)
+     env <- newHscEnv dflags
+     dflags' <- runLightGhc env $ do
+         -- HomeModuleGraph and probably all other clients get into all sorts of
+         -- trouble if the package state isn't initialized here
+         _ <- setSessionDynFlags =<< getSessionDynFlags
+         addCmdOpts opts =<< getSessionDynFlags
+     newHscEnv dflags'
+
+runLightGhc :: HscEnv -> LightGhc a -> IO a
+runLightGhc env action = do
+  renv <- newIORef env
+  flip runReaderT renv $ unLightGhc action
+
+runGmPkgGhc :: (IOish m, GmEnv m) => LightGhc a -> m a
+runGmPkgGhc action = do
+    pkgOpts <- packageGhcOptions
+    withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
+
+initSession :: IOish m
+            => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()
+initSession opts mdf = do
+   s <- gmsGet
+   case gmGhcSession s of
+     Just GmGhcSession {..} -> do
+         if gmgsOptions == opts
+            then return ()
+            else error "TODO: reload stuff"
+     Nothing -> do
+       Cradle { cradleTempDir } <- cradle
+       ghc <- liftIO $ runGhc (Just libdir) $ do
+           let setDf df =
+                setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
+           _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
+           getSession
+
+       rghc <- liftIO $ newIORef ghc
+       gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
+
+
+-- $ do
+--         dflags <- getSessionDynFlags
+--         defaultCleanupHandler dflags $ do
+--             initializeFlagsWithCradle opt (gmCradle env)
+--
+
+-- initSession :: GhcMonad m => Options -> [GHCOption] -> m ()
+-- initSession Options {..} ghcOpts = do
+--     df <- G.getSessionDynFlags
+--     void $
+--       ( setModeSimple -- $ setEmptyLogger
+--                       df)
+
+runGmLoadedT :: IOish m
+             => [Either FilePath ModuleName] -> GmLoadedT m a -> GhcModT m a
+runGmLoadedT fns action = runGmLoadedT' fns return action
+
+runGmLoadedT' :: IOish m
+              => [Either FilePath ModuleName]
+              -> (DynFlags -> Ghc DynFlags)
+              -> GmLoadedT m a
+              -> GhcModT m a
+runGmLoadedT' fns mdf action = runGmLoadedTWith fns mdf id action
+
+runGmLoadedTWith :: IOish m
+                 => [Either FilePath ModuleName]
+                 -> (DynFlags -> Ghc DynFlags)
+                 -> (GmLoadedT m a -> GmLoadedT m b)
+                 -> GmLoadedT m a
+                 -> GhcModT m b
+runGmLoadedTWith efnmns' mdf wrapper action = do
+    crdl <- cradle
+    Options { ghcUserOptions } <- options
+
+    let (fns, mns) = partitionEithers efnmns'
+        ccfns = map (cradleCurrentDir crdl </>) fns
+    cfns <- liftIO $ mapM canonicalizePath ccfns
+    let rfns = map (makeRelative $ cradleRootDir crdl) cfns
+        serfnmn = Set.fromList $ map Right mns ++ map Left rfns
+
+    opts <- targetGhcOptions crdl serfnmn
+    let opts' = opts ++ ghcUserOptions
+
+    initSession opts' $
+        setModeSimple >>> setEmptyLogger >>> mdf
+
+    unGmLoadedT $ wrapper $ do
+      loadTargets (map moduleNameString mns ++ rfns)
+      action
+
+targetGhcOptions :: IOish m
+                  => Cradle
+                  -> Set (Either FilePath ModuleName)
+                  -> GhcModT m [GHCOption]
+targetGhcOptions crdl sefnmn = do
+    when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
+
+    case cradleCabalFile crdl of
+      Just _ -> cabalOpts
+      Nothing -> sandboxOpts crdl
+ where
+   zipMap f l = l `zip` (f `map` l)
+   cabalOpts = do
+       mcs <- resolveGmComponents Nothing =<< getComponents
+
+       let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
+           candidates = Set.unions $ map snd mdlcs
+
+       when (Set.null candidates) $
+          throwError $ GMECabalCompAssignment mdlcs
+
+       let cn = pickComponent candidates
+       return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
+
+moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath))
+                 -> Either FilePath ModuleName
+                 -> Set GmComponentName
+moduleComponents m efnmn =
+    foldr' Set.empty m $ \c s ->
+        let
+            memb =
+              case efnmn of
+                Left fn  -> fn `Set.member` Set.map mpPath (smp c)
+                Right mn -> mn `Set.member` Set.map mpModule (smp c)
+        in if memb
+           then Set.insert (gmcName c) s
+           else s
+ where
+   smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c
+
+   foldr' b as f = Map.foldr f b as
+
+pickComponent :: Set GmComponentName -> GmComponentName
+pickComponent scn = Set.findMin scn
+
+
+packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption]
+packageGhcOptions = do
+    crdl <- cradle
+    case cradleCabalFile crdl of
+      Just _ -> do
+        (Set.toList . Set.fromList . concat . map snd) `liftM` getGhcPkgOptions
+      Nothing -> sandboxOpts crdl
+
+sandboxOpts :: Monad m => Cradle -> m [String]
+sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts
+  where
+    pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl
+    (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
+
+resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
+    => Maybe [Either FilePath ModuleName] -- ^ Updated modules
+    -> GmComponent (Either FilePath [ModuleName])
+    -> m (GmComponent (Set ModulePath))
+resolveGmComponent mums c@GmComponent {..} =
+  withLightHscEnv gmcGhcSrcOpts $ \env -> do
+    let srcDirs = gmcSourceDirs
+        mg = gmcHomeModuleGraph
+
+    let eps = either (return . Left) (map Right) gmcEntrypoints
+    simp <- liftIO $ resolveEntrypoints env srcDirs eps
+    sump <- liftIO $ case mums of
+        Nothing -> return simp
+        Just ums -> resolveEntrypoints env srcDirs ums
+
+    mg' <- updateHomeModuleGraph env mg simp sump
+
+    return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }
+
+resolveEntrypoints :: MonadIO m
+    => HscEnv -> [FilePath] -> [Either FilePath ModuleName] -> m (Set ModulePath)
+resolveEntrypoints env srcDirs ms =
+    liftIO $ Set.fromList . catMaybes <$> resolve `mapM` ms
+ where
+   resolve :: Either FilePath ModuleName -> IO (Maybe ModulePath)
+   resolve (Right mn) = findModulePath env mn
+   resolve (Left fn') = do
+       mfn <- findFile srcDirs fn'
+       case mfn of
+         Nothing -> return Nothing
+         Just fn'' -> do
+             let fn = normalise fn''
+             emn <- fileModuleName env fn
+             return $ case emn of
+                 Left _ -> Nothing
+                 Right mmn -> Just $
+                     case mmn of
+                       Nothing -> mkMainModulePath fn
+                       Just mn -> ModulePath mn fn
+
+resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
+                    => Maybe [Either FilePath ModuleName]
+                        -- ^ Updated modules
+                    -> [GmComponent (Either FilePath [ModuleName])]
+                    -> m (Map GmComponentName (GmComponent (Set ModulePath)))
+resolveGmComponents mumns cs = do
+    s <- gmsGet
+    m' <- foldrM' (gmComponents s) cs $ \c m -> do
+        case Map.lookup (gmcName c) m of
+          Nothing -> insertUpdated m c
+          Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c'
+                       then return m
+                       else insertUpdated m c
+    gmsPut s { gmComponents = m' }
+    return m'
+
+ where
+   foldrM' b fa f = foldrM f b fa
+   insertUpdated m c = do
+     rc <- resolveGmComponent mumns c
+     return $ Map.insert (gmcName rc) rc m
+
+   same :: Eq b
+        => (forall a. GmComponent a -> b)
+        -> GmComponent c -> GmComponent d -> Bool
+   same f a b = (f a) == (f b)
+
 
 -- | Set the files as targets and load them.
-setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()
+loadTargets :: IOish m => [String] -> GmLoadedT m ()
-setTargetFiles files = do
+loadTargets filesOrModules = do
-    targets <- forM files $ \file -> G.guessTarget file Nothing
+    gmLog GmDebug "loadTargets" $
-    G.setTargets targets
+          text "Loading" <+>: fsep (map text filesOrModules)
+
+    targets <- forM filesOrModules (flip guessTarget Nothing)
+    setTargets targets
+
     mode <- getCompilerMode
-    if mode == Intelligent then
+    if mode == Intelligent
-        loadTargets Intelligent
+      then loadTargets' Intelligent
       else do
-        mdls <- G.depanal [] False
+        mdls <- depanal [] False
         let fallback = needsFallback mdls
         if fallback then do
             resetTargets targets
             setIntelligent
-            loadTargets Intelligent
+            gmLog GmInfo "loadTargets" $
+                text "Switching to LinkInMemory/HscInterpreted (memory hungry)"
+            loadTargets' Intelligent
           else
-            loadTargets Simple
+            loadTargets' Simple
   where
-    loadTargets Simple = do
+    loadTargets' Simple = do
-        -- Reporting error A and error B
+        void $ load LoadAllTargets
-        void $ G.load LoadAllTargets
+
-        mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph
+    loadTargets' Intelligent = do
-        -- Reporting error B and error C
+        df <- getSessionDynFlags
-        mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss
+        void $ setSessionDynFlags (setModeIntelligent df)
-        -- Error B duplicates. But we cannot ignore both error reportings,
+        void $ load LoadAllTargets
-        -- sigh. So, the logger makes log messages unique by itself.
+
-    loadTargets Intelligent = do
-        df <- G.getSessionDynFlags
-        void $ G.setSessionDynFlags (setModeIntelligent df)
-        void $ G.load LoadAllTargets
     resetTargets targets = do
-        G.setTargets []
+        setTargets []
-        void $ G.load LoadAllTargets
+        void $ load LoadAllTargets
-        G.setTargets targets
+        setTargets targets
+
     setIntelligent = do
-        newdf <- setModeIntelligent <$> G.getSessionDynFlags
+        newdf <- setModeIntelligent <$> getSessionDynFlags
-        void $ G.setSessionDynFlags newdf
+        void $ setSessionDynFlags newdf
         setCompilerMode Intelligent
 
-needsFallback :: G.ModuleGraph -> Bool
+needsFallback :: ModuleGraph -> Bool
 needsFallback = any $ \ms ->
-                let df = G.ms_hspp_opts ms in
+                let df = ms_hspp_opts ms in
                    Opt_TemplateHaskell `xopt` df
                 || Opt_QuasiQuotes     `xopt` df
 #if __GLASGOW_HASKELL__ >= 708

Language/Haskell/GhcMod/Types.hs

@@ -1,13 +1,29 @@
-module Language.Haskell.GhcMod.Types where
+{-# LANGUAGE DeriveDataTypeable, GADTs, StandaloneDeriving, DataKinds #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Language.Haskell.GhcMod.Types (
+    module Language.Haskell.GhcMod.Types
+  , module Types
+  , ModuleName
+  , mkModuleName
+  , moduleNameString
+  ) where
 
 import Control.Monad.Trans.Control (MonadBaseControl)
-import Data.List (intercalate)
+import Control.Monad.Error (Error(..))
-import qualified Data.Map as M
+import Control.Exception (Exception)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Monoid
+import Data.Typeable (Typeable)
 import Exception (ExceptionMonad)
 import MonadUtils (MonadIO)
-
+import GHC (ModuleName, moduleNameString, mkModuleName)
 import PackageConfig (PackageConfig)
 
+import Types
+
 -- | A constraint alias (-XConstraintKinds) to make functions dealing with
 -- 'GhcModT' somewhat cleaner.
 --
@@ -28,8 +44,10 @@ data Options = Options {
     outputStyle   :: OutputStyle
   -- | Line separator string.
   , lineSeparator :: LineSeparator
-  -- | @ghc@ program name.
+  -- | Verbosity
-  , ghcProgram    :: FilePath
+  , logLevel      :: GmLogLevel
+--  -- | @ghc@ program name.
+--  , ghcProgram    :: FilePath
   -- | @cabal@ program name.
   , cabalProgram  :: FilePath
     -- | GHC command line options set on the @ghc-mod@ command line
@@ -48,14 +66,15 @@ data Options = Options {
 defaultOptions :: Options
 defaultOptions = Options {
     outputStyle   = PlainStyle
-  , hlintOpts     = []
+  , lineSeparator = LineSeparator "\0"
-  , ghcProgram    = "ghc"
+  , logLevel      = GmPanic
+--  , ghcProgram    = "ghc"
   , cabalProgram  = "cabal"
   , ghcUserOptions= []
   , operators     = False
   , detailed      = False
   , qualified     = False
-  , lineSeparator = LineSeparator "\0"
+  , hlintOpts     = []
   }
 
 ----------------------------------------------------------------
@@ -76,57 +95,110 @@ data Cradle = Cradle {
 
 ----------------------------------------------------------------
 
--- | GHC package database flags.
+data GmLogLevel = GmPanic
-data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
+                | GmException
-
+                | GmError
--- | A single GHC command line option.
+                | GmWarning
-type GHCOption  = String
+                | GmInfo
-
+                | GmDebug
--- | An include directory for modules.
+                  deriving (Eq, Ord, Enum, Bounded, Show, Read)
-type IncludeDir = FilePath
-
--- | A package name.
-type PackageBaseName = String
-
--- | A package version.
-type PackageVersion  = String
-
--- | A package id.
-type PackageId  = String
-
--- | A package's name, verson and id.
-type Package    = (PackageBaseName, PackageVersion, PackageId)
-
-pkgName :: Package -> PackageBaseName
-pkgName (n,_,_) = n
-
-pkgVer :: Package -> PackageVersion
-pkgVer (_,v,_) = v
-
-pkgId :: Package -> PackageId
-pkgId (_,_,i) = i
-
-showPkg :: Package -> String
-showPkg (n,v,_) = intercalate "-" [n,v]
-
-showPkgId :: Package -> String
-showPkgId (n,v,i) = intercalate "-" [n,v,i]
 
 -- | Collection of packages
-type PkgDb = (M.Map Package PackageConfig)
+type PkgDb = (Map Package PackageConfig)
 
--- | Haskell expression.
+data GmModuleGraph = GmModuleGraph {
-type Expression = String
+      gmgFileMap    :: Map FilePath ModulePath,
+      gmgModuleMap  :: Map ModuleName ModulePath,
+      gmgGraph      :: Map ModulePath (Set ModulePath)
+    } deriving (Eq, Ord, Show, Read, Typeable)
 
--- | Module name.
+instance Monoid GmModuleGraph where
-type ModuleString = String
+    mempty  = GmModuleGraph mempty mempty mempty
+    mappend (GmModuleGraph a b c) (GmModuleGraph a' b' c') =
+        GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
 
--- | A Module
+data GmComponent eps = GmComponent {
-type Module = [String]
+      gmcName            :: GmComponentName,
+      gmcGhcOpts         :: [GHCOption],
+      gmcGhcSrcOpts      :: [GHCOption],
+      gmcRawEntrypoints  :: Either FilePath [ModuleName],
+      gmcEntrypoints     :: eps,
+      gmcSourceDirs      :: [FilePath],
+      gmcHomeModuleGraph :: GmModuleGraph
+    } deriving (Eq, Ord, Show, Read, Typeable)
 
--- | Option information for GHC
+data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
-data CompilerOptions = CompilerOptions {
+    deriving (Eq, Ord, Show, Read, Typeable)
-    ghcOptions  :: [GHCOption]  -- ^ Command line options
+
-  , includeDirs :: [IncludeDir] -- ^ Include directories for modules
+instance Show ModuleName where
-  , depPackages :: [Package]    -- ^ Dependent package names
+    show mn = "ModuleName " ++ show (moduleNameString mn)
-  } deriving (Eq, Show)
+
+instance Read ModuleName where
+    readsPrec d r = readParen (d > app_prec)
+                         (\r' -> [(mkModuleName m,t) |
+                                 ("ModuleName",s) <- lex r',
+                                 (m,t) <- readsPrec (app_prec+1) s]) r
+        where app_prec = 10
+
+
+--- \ / These types MUST be in sync with the copies in cabal-helper/Main.hs
+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 cabal-helper/Main.hs
+
+data GhcModError
+    = GMENoMsg
+    -- ^ Unknown error
+
+    | GMEString String
+    -- ^ Some Error with a message. These are produced mostly by
+    -- 'fail' calls on GhcModT.
+
+    | GMECabalConfigure GhcModError
+    -- ^ Configuring a cabal project failed.
+
+    | GMECabalFlags GhcModError
+    -- ^ Retrieval of the cabal configuration flags failed.
+
+    | GMECabalComponent GmComponentName
+    -- ^ Cabal component could not be found
+
+    | GMECabalCompAssignment [(Either FilePath ModuleName, Set GmComponentName)]
+    -- ^ Could not find a consistent component assignment for modules
+
+    | GMEProcess String [String] (Either (String, String, Int) GhcModError)
+    -- ^ Launching an operating system process failed. Fields in
+    -- order: command, arguments, (stdout, stderr, exitcode)
+
+    | 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)
+
+instance Error GhcModError where
+    noMsg = GMENoMsg
+    strMsg = GMEString
+
+instance Exception GhcModError
+
+data GMConfigStateFileError
+    = GMConfigStateFileNoHeader
+    | GMConfigStateFileBadHeader
+    | GMConfigStateFileNoParse
+    | GMConfigStateFileMissing
+--    | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
+  deriving (Eq, Show, Read, Typeable)

Language/Haskell/GhcMod/Utils.hs

@@ -15,28 +15,28 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 {-# LANGUAGE CPP #-}
-module Language.Haskell.GhcMod.Utils where
+module Language.Haskell.GhcMod.Utils (
+    module Language.Haskell.GhcMod.Utils
+  , module Utils
+  , readProcess
+  ) where
 
 import Control.Arrow
-import Control.Applicative ((<$>))
+import Control.Applicative
 import Data.Char
 import Language.Haskell.GhcMod.Error
-import MonadUtils (MonadIO, liftIO)
+import Exception
 import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist)
-import System.Exit (ExitCode(..))
+import System.Process (readProcess)
-import System.Process (readProcessWithExitCode)
 import System.Directory (getTemporaryDirectory)
-import System.FilePath (splitDrive, pathSeparators, (</>))
+import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
+                        (</>))
 import System.IO.Temp (createTempDirectory)
-#ifndef SPEC
-import Paths_ghc_mod (getLibexecDir)
 import System.Environment
-import System.FilePath (takeDirectory)
+import Text.Printf
-#else
+
--- When compiling test suite
+import Paths_ghc_mod (getLibexecDir)
-import Data.IORef
+import Utils
-import System.IO.Unsafe
-#endif
 
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
 dropWhileEnd :: (a -> Bool) -> [a] -> [a]
@@ -54,21 +54,6 @@ extractParens str = extractParens' str 0
        | s `elem` "}])" = s : extractParens' ss (level-1)
        | otherwise = s : extractParens' ss level
 
-readProcess' :: (MonadIO m, GmError m)
-             => String
-             -> [String]
-             -> m String
-readProcess' cmd opts = do
-  (rv,output,err) <- liftIO (readProcessWithExitCode cmd opts "")
-      `modifyError'` GMEProcess ([cmd] ++ opts)
-  case rv of
-    ExitFailure val -> do
-        throwError $ GMEProcess ([cmd] ++ opts) $ strMsg $
-          cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"
-              ++ "\n" ++ err
-    ExitSuccess ->
-        return output
-
 withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
 withDirectory_ dir action =
     gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
@@ -91,42 +76,85 @@ newTempDir :: FilePath -> IO FilePath
 newTempDir dir =
     flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
 
-mightExist :: FilePath -> IO (Maybe FilePath)
+whenM :: IO Bool -> IO () -> IO ()
-mightExist f = do
+whenM mb ma = mb >>= flip when ma
-  exists <- doesFileExist f
-  return $ if exists then (Just f) else (Nothing)
 
 -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
 -- this is a guess but >=7.6 uses 'getExecutablePath'.
 ghcModExecutable :: IO FilePath
 #ifndef SPEC
 ghcModExecutable = do
-    dir <- getExecutablePath'
+    dir <- takeDirectory <$> getExecutablePath'
-    return $ dir </> "ghc-mod"
+    return $ (if dir == "." then "" else dir) </> "ghc-mod"
- where
-    getExecutablePath' :: IO FilePath
-# if __GLASGOW_HASKELL__ >= 706
-    getExecutablePath' = takeDirectory <$> getExecutablePath
-# else
-    getExecutablePath' = return ""
-# endif
 #else
 ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
 #endif
 
-#ifdef SPEC
--- Ugly workaround :'( but I can't think of any other way of doing this
--- the test suite changes the cwd often so I can't use relative paths :/
-specRootDir :: IORef FilePath
-specRootDir = unsafePerformIO $ newIORef undefined
-{-# NOINLINE specRootDir #-}
-#endif
-
 findLibexecExe :: String -> IO FilePath
-#ifndef SPEC
+findLibexecExe "cabal-helper-wrapper" = do
-findLibexecExe "cabal-helper" = (fmap (</> "cabal-helper")) getLibexecDir
+    libexecdir <- getLibexecDir
-#else
+    let exeName = "cabal-helper-wrapper"
-findLibexecExe "cabal-helper" =
+        exe = libexecdir </> exeName
-    (</> "dist/build/cabal-helper/cabal-helper") <$> (readIORef specRootDir)
+
-#endif
+    exists <- doesFileExist exe
+
+    if exists
+       then return exe
+       else do
+         mdir <- tryFindGhcModTreeDataDir
+         case mdir of
+           Nothing ->
+               error $ libexecNotExitsError exeName libexecdir
+           Just dir ->
+               return $ dir </> "dist" </> "build" </> exeName </> exeName
 findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
+
+libexecNotExitsError :: String -> FilePath -> String
+libexecNotExitsError exe dir = printf
+ ( "Could not find $libexecdir/%s\n"
+ ++"\n"
+ ++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n"
+ ++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n"
+ ++"\n"
+ ++"    $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n"
+ ++"\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"
+ ++"\n"
+ ++"    https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir
+
+tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
+tryFindGhcModTreeLibexecDir  = do
+  exe <- getExecutablePath
+  dir <- case takeFileName exe of
+    "ghc" -> do -- we're probably in ghci; try CWD
+        getCurrentDirectory
+    _ ->
+        return $ (!!4) $ iterate takeDirectory exe
+  exists <- doesFileExist $ dir </> "ghc-mod.cabal"
+  return $ if exists
+             then Just dir
+             else Nothing
+
+tryFindGhcModTreeDataDir :: IO (Maybe FilePath)
+tryFindGhcModTreeDataDir  = do
+  dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'
+  exists <- doesFileExist $ dir </> "ghc-mod.cabal"
+  return $ if exists
+             then Just dir
+             else Nothing
+
+readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
+                    => String -> [String] -> m String
+readLibExecProcess' cmd args = do
+  exe <- liftIO $ findLibexecExe cmd
+  liftIO $ readProcess exe args ""
+
+getExecutablePath' :: IO FilePath
+#if __GLASGOW_HASKELL__ >= 706
+getExecutablePath' = getExecutablePath
+#else
+getExecutablePath' = getProgName
+#endif

Language/Haskell/GhcMod/World.hs

@@ -1,82 +1,44 @@
-{-# LANGUAGE RecordWildCards, CPP #-}
 module Language.Haskell.GhcMod.World where
-{-(
-  , World
-  , getCurrentWorld
-  , isWorldChanged
-  ) where
--}
 
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 
-import Control.Applicative (pure, (<$>), (<*>))
+import Control.Applicative ((<$>))
-import Control.Monad
 import Data.Maybe
 import Data.Traversable (traverse)
-import System.Directory (getModificationTime)
 import System.FilePath ((</>))
 
 import GHC.Paths (libdir)
 
-#if __GLASGOW_HASKELL__ <= 704
-import System.Time (ClockTime)
-#else
-import Data.Time (UTCTime)
-#endif
-
-
-#if __GLASGOW_HASKELL__ <= 704
-type ModTime = ClockTime
-#else
-type ModTime = UTCTime
-#endif
-
-data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show)
-
-instance Ord TimedFile where
-    compare (TimedFile _ a) (TimedFile _ b) = compare a b
-
-timeFile :: FilePath -> IO TimedFile
-timeFile f = TimedFile <$> pure f <*> getModificationTime f
-
 data World = World {
     worldPackageCaches :: [TimedFile]
   , worldCabalFile     :: Maybe TimedFile
   , worldCabalConfig   :: Maybe TimedFile
   , worldSymbolCache   :: Maybe TimedFile
-  , worldPrettyCabalConfigCache :: Maybe TimedFile
   } deriving (Eq, Show)
 
-timedPackageCache :: Cradle -> IO [TimedFile]
+timedPackageCaches :: Cradle -> IO [TimedFile]
-timedPackageCache crdl = do
+timedPackageCaches crdl = do
     fs <- mapM mightExist . map (</> packageCache)
             =<< getPackageCachePaths libdir crdl
     timeFile `mapM` catMaybes fs
 
 getCurrentWorld :: Cradle -> IO World
 getCurrentWorld crdl = do
-    pkgCaches    <- timedPackageCache crdl
+    pkgCaches    <- timedPackageCaches crdl
     mCabalFile   <- timeFile `traverse` cradleCabalFile crdl
     mCabalConfig <- timeMaybe (setupConfigFile crdl)
     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

Utils.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE CPP #-}
+module Utils where
+
+import Control.Monad
+import Control.Applicative
+import Data.Traversable
+import System.Directory
+
+#if MIN_VERSION_directory(1,2,0)
+import Data.Time (UTCTime)
+#else
+import System.Time (ClockTime)
+#endif
+
+#if MIN_VERSION_directory(1,2,0)
+type ModTime = UTCTime
+#else
+type ModTime = ClockTime
+#endif
+
+data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show)
+
+instance Ord TimedFile where
+    compare (TimedFile _ a) (TimedFile _ b) = compare a b
+
+timeFile :: FilePath -> IO TimedFile
+timeFile f = TimedFile <$> pure f <*> getModificationTime f
+
+mightExist :: FilePath -> IO (Maybe FilePath)
+mightExist f = do
+  exists <- doesFileExist f
+  return $ if exists then (Just f) else (Nothing)
+
+timeMaybe :: FilePath -> IO (Maybe TimedFile)
+timeMaybe f = do
+  join $ (timeFile `traverse`) <$> mightExist f

ghc-mod.cabal

@@ -19,14 +19,15 @@ Description:            The ghc-mod command is a backend command to enrich
                         For more information, please see its home page.
 
 Category:               Development
-Cabal-Version:          >= 1.10
+Cabal-Version:          >= 1.16
 Build-Type:             Custom
-Data-Dir:               elisp
+Data-Files:             elisp/Makefile
-Data-Files:             Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
+                        elisp/*.el
-                        ghc-check.el ghc-process.el ghc-command.el ghc-info.el
+                        cabal-helper/*.hs
-                        ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el
+
 Extra-Source-Files:     ChangeLog
                         SetupCompat.hs
+                        NotCPP/*.hs
 			test/data/*.cabal
                         test/data/*.hs
                         test/data/cabal.sandbox.config.in
@@ -56,29 +57,23 @@ Extra-Source-Files:     ChangeLog
                         test/data/subdir1/subdir2/dummy
                         test/data/.cabal-sandbox/packages/00-index.tar
 
-Flag cabal-122
-  Default:              True
-  Manual:               False
-
 Library
   Default-Language:     Haskell2010
-  GHC-Options:          -Wall
+  GHC-Options:          -Wall -fno-warn-deprecations
-  Default-Extensions:   ConstraintKinds, FlexibleContexts
+  Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
+                        ConstraintKinds, FlexibleContexts
   Exposed-Modules:      Language.Haskell.GhcMod
                         Language.Haskell.GhcMod.Internal
   Other-Modules:        Paths_ghc_mod
+                        Types
+                        Utils
                         Language.Haskell.GhcMod.Boot
                         Language.Haskell.GhcMod.Browse
-                        Language.Haskell.GhcMod.CabalConfig.Cabal16
-                        Language.Haskell.GhcMod.CabalConfig.Cabal18
-                        Language.Haskell.GhcMod.CabalConfig.Cabal22
-                        Language.Haskell.GhcMod.CabalConfig.Extract
-                        Language.Haskell.GhcMod.CabalConfig
-                        Language.Haskell.GhcMod.CabalApi
                         Language.Haskell.GhcMod.CaseSplit
                         Language.Haskell.GhcMod.Check
                         Language.Haskell.GhcMod.Convert
                         Language.Haskell.GhcMod.Cradle
+                        Language.Haskell.GhcMod.CabalHelper
                         Language.Haskell.GhcMod.Debug
                         Language.Haskell.GhcMod.Doc
                         Language.Haskell.GhcMod.DynFlags
@@ -86,9 +81,9 @@ Library
                         Language.Haskell.GhcMod.FillSig
                         Language.Haskell.GhcMod.Find
                         Language.Haskell.GhcMod.Flag
-                        Language.Haskell.GhcMod.GHCChoice
                         Language.Haskell.GhcMod.Gap
                         Language.Haskell.GhcMod.GhcPkg
+                        Language.Haskell.GhcMod.HomeModuleGraph
                         Language.Haskell.GhcMod.Info
                         Language.Haskell.GhcMod.Lang
                         Language.Haskell.GhcMod.Lint
@@ -99,14 +94,13 @@ Library
                         Language.Haskell.GhcMod.Monad.Types
                         Language.Haskell.GhcMod.PathsAndFiles
                         Language.Haskell.GhcMod.PkgDoc
+                        Language.Haskell.GhcMod.Pretty
                         Language.Haskell.GhcMod.Read
                         Language.Haskell.GhcMod.SrcUtils
                         Language.Haskell.GhcMod.Target
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.World
-
-
   Build-Depends:        base >= 4.0 && < 5
                       , bytestring
                       , containers
@@ -117,7 +111,6 @@ Library
                       , ghc-paths
                       , ghc-syb-utils
                       , hlint >= 1.8.61
-                      , io-choice
                       , monad-journal >= 0.4
                       , old-time
                       , pretty
@@ -128,18 +121,13 @@ Library
                       , transformers
                       , transformers-base
                       , mtl >= 2.0
-                      , monad-control
+                      , monad-control >= 1
                       , split
                       , haskell-src-exts
                       , text
                       , djinn-ghc >= 0.0.2.2
   if impl(ghc < 7.8)
     Build-Depends:      convertible
-                      , Cabal >= 1.10 && < 1.17
-  else
-    Build-Depends:      Cabal >= 1.18
-  if flag(cabal-122)
-    Build-Depends:      Cabal >= 1.22
   if impl(ghc <= 7.4.2)
     -- Only used to constrain random to a version that still works with GHC 7.4
     Build-Depends:      random <= 1.0.1.1
@@ -148,7 +136,7 @@ Executable ghc-mod
   Default-Language:     Haskell2010
   Main-Is:              GHCMod.hs
   Other-Modules:        Paths_ghc_mod
-  GHC-Options:          -Wall
+  GHC-Options:          -Wall -fno-warn-deprecations
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
@@ -169,7 +157,7 @@ Executable ghc-modi
   Other-Modules:        Paths_ghc_mod
                         Misc
                         Utils
-  GHC-Options:          -Wall -threaded
+  GHC-Options:          -Wall -threaded -fno-warn-deprecations
   if os(windows)
       Cpp-Options:      -DWINDOWS
   Default-Extensions:   ConstraintKinds, FlexibleContexts
@@ -218,16 +206,20 @@ Test-Suite doctest
 
 Test-Suite spec
   Default-Language:     Haskell2010
-  Default-Extensions:   ConstraintKinds, FlexibleContexts
+  Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
+                        ConstraintKinds, FlexibleContexts, OverloadedStrings
   Main-Is:              Main.hs
   Hs-Source-Dirs:       test, .
-  Ghc-Options:          -Wall
+  Ghc-Options:          -Wall -fno-warn-deprecations
   CPP-Options:          -DSPEC=1
   Type:                 exitcode-stdio-1.0
-  Other-Modules:        BrowseSpec
+  Other-Modules:        Paths_ghc_mod
-                        CabalApiSpec
+                        Types
-                        CheckSpec
                         Dir
+                        Spec
+                        TestUtils
+                        BrowseSpec
+                        CheckSpec
                         FlagSpec
                         InfoSpec
                         LangSpec
@@ -235,8 +227,7 @@ Test-Suite spec
                         ListSpec
                         MonadSpec
                         PathsAndFilesSpec
-                        Spec
+                        HomeModuleGraphSpec
-                        TestUtils
 
   Build-Depends:        hspec
   if impl(ghc == 7.4.*)

src/GHCMod.hs

@@ -259,8 +259,9 @@ reqArg udsc dsc = ReqArg dsc udsc
 
 globalArgSpec :: [OptDescr (Options -> Options)]
 globalArgSpec =
-      [ option "v" ["verbose"] "Be more verbose." $
+      [ option "v" ["verbose"] "Can be given multiple times to be increasingly\
-               NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }
+                               \more verbose." $
+               NoArg $ \o -> o { logLevel = increaseLogLevel (logLevel o) }
 
       , option "l" ["tolisp"] "Format output as an S-Expression" $
                NoArg $ \o -> o { outputStyle = LispStyle }
@@ -272,8 +273,8 @@ globalArgSpec =
                reqArg "OPT" $ \g o ->
                    o { ghcUserOptions = g : ghcUserOptions o }
 
-      , option "" ["with-ghc"] "GHC executable to use" $
+--      , option "" ["with-ghc"] "GHC executable to use" $
-               reqArg "PROG" $ \p o -> o { ghcProgram = p }
+--               reqArg "PROG" $ \p o -> o { ghcProgram = p }
 
       , option "" ["with-cabal"] "cabal-install executable to use" $
                reqArg "PROG" $ \p o -> o { cabalProgram = p }