Merge branch 'master' into release

.gitignore

@@ -2,6 +2,7 @@ dist/
 elisp/*.elc
 *~
 /.cabal-sandbox/
+/.stack-work/
 add-source-timestamps
 package.cache
 cabal.sandbox.config

.travis.yml

@@ -16,23 +16,29 @@ cache:
   directories:
   - ~/.cabal
   - ~/.ghc
+  - ~/.stack
 
 before_cache:
   - rm -f $HOME/.cabal/logs $HOME/.cabal/packages/*/build-reports.log
 
+before_install:
+  - wget https://github.com/commercialhaskell/stack/releases/download/v0.1.3.1/stack-0.1.3.1-x86_64-linux.gz
+  - mkdir stack-bin
+  - gunzip stack-0.1.3.1-x86_64-linux.gz
+  - mv stack-0.1.3.1-x86_64-linux stack-bin/stack
+  - chmod +x stack-bin/stack
+  - export PATH=$(pwd)/stack-bin:$PATH
+  - stack --version
+
 install:
+  - export CABAL_VER="$(ghc-pkg describe ghc | sed -n '/^depends:/,/^[a-z]/p' | head -n-1 | sed '1{s/^depends://}' | grep " *Cabal" | tr -d "[:space:]" | sed 's/^Cabal-\([0-9.]*\)-.*/\1/g')"
+  - echo $CABAL_VER
   - cabal update
-#  - ( $CABAL122 && cabal install cabal-install --constraint "Cabal >= 1.22" && ghc-pkg unregister Cabal ) || true
-  - echo $PATH
-  - which cabal
-  - if [ -n "$(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1 | sed -n '/^1.18/p')" ]; then cabal install cabal-install --constraint "Cabal == 1.18.* && > 1.18.0"; fi
   - cabal install happy
   - happy --version
-#  - ls -lR ~/.ghc
-#  - ls -lR ~/.cabal
-  - cabal install -j --only-dependencies --enable-tests
   - git clone --depth=1 https://github.com/DanielG/cabal-helper.git
-  - cabal install cabal-helper/
+  - cabal install cabal-helper/ --constraint "Cabal == ${CABAL_VER}"
+  - cabal install -j --only-dependencies --enable-tests
 
 
 script:

Language/Haskell/GhcMod.hs

@@ -3,12 +3,13 @@
 module Language.Haskell.GhcMod (
   -- * Cradle
     Cradle(..)
-  , ProjectType(..)
+  , Project(..)
   , findCradle
   -- * Options
   , Options(..)
   , LineSeparator(..)
   , OutputStyle(..)
+  , FileMapping(..)
   , defaultOptions
   -- * Logging
   , GmLogLevel
@@ -61,8 +62,10 @@ module Language.Haskell.GhcMod (
   , gmErrStr
   , gmPutStrLn
   , gmErrStrLn
-  , gmUnsafePutStrLn
+  -- * FileMapping
-  , gmUnsafeErrStrLn
+  , loadMappedFile
+  , loadMappedFileSource
+  , unloadMappedFile
   ) where
 
 import Language.Haskell.GhcMod.Boot
@@ -84,3 +87,4 @@ import Language.Haskell.GhcMod.PkgDoc
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Target
 import Language.Haskell.GhcMod.Output
+import Language.Haskell.GhcMod.FileMapping

Language/Haskell/GhcMod/Browse.hs

@@ -80,7 +80,7 @@ processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
 processExports opt minfo = do
   let
     removeOps
-      | operators opt = id
+      | optOperators opt = id
       | otherwise = filter (isNotOp . getOccString)
   mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
 
@@ -90,17 +90,17 @@ 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
+    mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optQualified opt
     mtype :: m (Maybe String)
     mtype
-      | detailed opt = do
+      | optDetailed opt = do
         tyInfo <- G.modInfoLookupName minfo e
         -- If nothing found, load dependent module and lookup global
         tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
         dflag <- G.getSessionDynFlags
         return $ do
           typeName <- tyResult >>= showThing dflag
-          (" :: " ++ typeName) `justIf` detailed opt
+          (" :: " ++ typeName) `justIf` optDetailed opt
       | otherwise = return Nothing
     formatOp nm
       | null nm    = error "formatOp"

Language/Haskell/GhcMod/CabalHelper.hs

@@ -20,7 +20,6 @@ module Language.Haskell.GhcMod.CabalHelper
   ( getComponents
   , getGhcMergedPkgOptions
   , getCabalPackageDbStack
-  , getCustomPkgDbStack
   , prepareCabalHelper
   )
 #endif
@@ -33,42 +32,45 @@ import Data.Maybe
 import Data.Monoid
 import Data.Serialize (Serialize)
 import Data.Traversable
-import Distribution.Helper
+import Distribution.Helper hiding (Programs(..))
+import qualified Distribution.Helper as CH
 import qualified Language.Haskell.GhcMod.Types as T
-import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
+import Language.Haskell.GhcMod.Types
-                                             cabalProgram)
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Output
+import Language.Haskell.GhcMod.CustomPackageDb
+import Language.Haskell.GhcMod.Stack
 import System.FilePath
+import System.Process
+import System.Exit
 import Prelude hiding ((.))
 
 import Paths_ghc_mod as GhcMod
 
 -- | Only package related GHC options, sufficient for things that don't need to
 -- access home modules
-getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
+getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)
   => m [GHCOption]
-getGhcMergedPkgOptions = chCached Cached {
+getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
   cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
-  cacheFile = mergedPkgOptsCacheFile,
+  cacheFile = mergedPkgOptsCacheFile distdir,
-  cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do
+  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do
-    readProc <- gmReadProcess
+    opts <- withCabal $ runCHQuery ghcMergedPkgOptions
-    opts <- withCabal $ runQuery'' readProc progs rootdir distdir $
+    return ([setupConfigPath distdir], opts)
-                ghcMergedPkgOptions
-    return ([setupConfigPath], opts)
  }
 
-getCabalPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb]
+getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]
-getCabalPackageDbStack = chCached Cached {
+getCabalPackageDbStack = chCached $ \distdir -> Cached {
   cacheLens = Just (lGmcPackageDbStack . lGmCaches),
-  cacheFile = pkgDbStackCacheFile,
+  cacheFile = pkgDbStackCacheFile distdir,
-  cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do
+  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do
-    readProc <- gmReadProcess
+    crdl <- cradle
-    dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery'' readProc progs rootdir distdir packageDbStack
+    dbs <- withCabal $ map chPkgToGhcPkg <$>
-    return ([setupConfigPath, sandboxConfigFile], dbs)
+             runCHQuery packageDbStack
+    return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)
  }
 
 chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb
@@ -81,14 +83,13 @@ chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
 --
 -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
 -- 'resolveGmComponents'.
-getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
+getComponents :: (Applicative m, IOish m, Gm m)
               => m [GmComponent 'GMCRaw ChEntrypoint]
-getComponents = chCached Cached {
+getComponents = chCached$ \distdir -> Cached {
     cacheLens = Just (lGmcComponents . lGmCaches),
-    cacheFile = cabalHelperCacheFile,
+    cacheFile = cabalHelperCacheFile distdir,
-    cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> do
+    cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do
-      readProc <- gmReadProcess
+      runCHQuery $ do
-      runQuery'' readProc progs rootdir distdir $ do
         q <- join7
                <$> ghcOptions
                <*> ghcPkgOptions
@@ -98,7 +99,7 @@ getComponents = chCached Cached {
                <*> entrypoints
                <*> sourceDirs
         let cs = flip map q $ curry8 (GmComponent mempty)
-        return ([setupConfigPath], cs)
+        return ([setupConfigPath distdir], cs)
   }
  where
    curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h
@@ -110,75 +111,134 @@ getComponents = chCached Cached {
                  , (a', c) <- lc
                  , a == a'
                  ]
+runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b
+runCHQuery a = do
+  crdl <- cradle
+  let projdir = cradleRootDir crdl
+      distdir = projdir </> cradleDistDir crdl
 
-prepareCabalHelper :: (IOish m, GmEnv m, GmLog m) => m ()
+  opts <- options
+  progs <- patchStackPrograms crdl (optPrograms opts)
+
+  readProc <- gmReadProcess
+
+  let qe = (defaultQueryEnv projdir distdir) {
+               qeReadProcess = readProc
+             , qePrograms = helperProgs progs
+             }
+  runQuery qe a
+
+
+prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
 prepareCabalHelper = do
   crdl <- cradle
   let projdir = cradleRootDir crdl
-      distdir = projdir </> "dist"
+      distdir = projdir </> cradleDistDir crdl
   readProc <- gmReadProcess
-  when (cradleProjectType crdl == CabalProject) $
+  when (isCabalHelperProject $ cradleProject crdl) $
        withCabal $ liftIO $ prepare readProc projdir distdir
 
-parseCustomPackageDb :: String -> [GhcPkgDb]
+withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
-parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src
- where
-   parsePkgDb "global" = GlobalDb
-   parsePkgDb "user" = UserDb
-   parsePkgDb s = PackageDb s
-
-getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb])
-getCustomPkgDbStack = do
-    mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle
-    return $ parseCustomPackageDb <$> mCusPkgDbFile
-
-withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a
 withCabal action = do
     crdl <- cradle
     opts <- options
     readProc <- gmReadProcess
 
     let projdir = cradleRootDir crdl
-        distdir = projdir </> "dist"
+        distdir = projdir </> cradleDistDir crdl
 
-    mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
+    mCabalFile          <- liftIO $ timeFile `traverse` cradleCabalFile crdl
-    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
+    mCabalConfig        <- liftIO $ timeMaybe (setupConfigFile crdl)
+    mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
 
     mCusPkgDbStack <- getCustomPkgDbStack
 
     pkgDbStackOutOfSync <-
          case mCusPkgDbStack of
            Just cusPkgDbStack -> do
-             pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $
+             let qe = (defaultQueryEnv projdir distdir) {
-                 map chPkgToGhcPkg <$> packageDbStack
+                          qeReadProcess = readProc
+                        , qePrograms = helperProgs $ optPrograms opts
+                        }
+             pkgDb <- runQuery qe $ map chPkgToGhcPkg <$> packageDbStack
              return $ pkgDb /= cusPkgDbStack
 
            Nothing -> return False
 
-    cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
+    proj <- cradleProject <$> cradle
-
-    --TODO: also invalidate when sandboxConfig file changed
 
     when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $
       gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
+
+    when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
+      gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date, reconfiguring Cabal project."
+
     when pkgDbStackOutOfSync $
       gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project."
 
-    when (isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync) $
+    when ( isSetupConfigOutOfDate mCabalFile mCabalConfig
-        withDirectory_ (cradleRootDir crdl) $ do
+        || pkgDbStackOutOfSync
-            let progOpts =
+        || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
-                    [ "--with-ghc=" ++ T.ghcProgram opts ]
+          case proj of
-                    -- Only pass ghc-pkg if it was actually set otherwise we
+            CabalProject ->
-                    -- might break cabal's guessing logic
+                cabalReconfigure readProc (optPrograms opts) crdl projdir distdir
-                    ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
+            StackProject {} ->
-                         then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
+
-                         else []
+                stackReconfigure crdl (optPrograms opts)
-                    ++ map pkgDbArg cusPkgStack
+            _ ->
-            liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) ""
+                error $ "withCabal: unsupported project type: " ++ show proj
-            gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
+
-            liftIO $ writeAutogenFiles readProc projdir distdir
     action
 
+ where
+   writeAutogen projdir distdir = do
+     readProc <- gmReadProcess
+     gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
+     liftIO $ writeAutogenFiles readProc projdir distdir
+
+
+   cabalReconfigure readProc progs crdl projdir distdir = do
+     withDirectory_ (cradleRootDir crdl) $ do
+        cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
+        let progOpts =
+                [ "--with-ghc=" ++ T.ghcProgram progs ]
+                -- Only pass ghc-pkg if it was actually set otherwise we
+                -- might break cabal's guessing logic
+                ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)
+                     then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]
+                     else []
+                ++ map pkgDbArg cusPkgStack
+        liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""
+        writeAutogen projdir distdir
+
+   stackReconfigure crdl progs = do
+     let projdir = cradleRootDir crdl
+         distdir = projdir </> cradleDistDir crdl
+
+     withDirectory_ (cradleRootDir crdl) $ do
+       supported <- haveStackSupport
+       if supported
+          then do
+            spawn [T.stackProgram progs, "build", "--only-dependencies", "."]
+            spawn [T.stackProgram progs, "build", "--only-configure", "."]
+            writeAutogen projdir distdir
+          else
+            gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 0.1.4.0)"
+
+   spawn [] = return ()
+   spawn (exe:args) = do
+     readProc <- gmReadProcess
+     liftIO $ void $ readProc exe args ""
+
+   haveStackSupport = do
+     (rv, _, _) <-
+         liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] ""
+     case rv of
+       ExitSuccess -> return True
+       ExitFailure _ -> return False
+
+
+
 pkgDbArg :: GhcPkgDb -> String
 pkgDbArg GlobalDb      = "--package-db=global"
 pkgDbArg UserDb        = "--package-db=user"
@@ -188,9 +248,9 @@ pkgDbArg (PackageDb p) = "--package-db=" ++ p
 --   @Nothing < Nothing = False@
 --   (since we don't need to @cabal configure@ when no cabal file exists.)
 --
--- * Cabal file doesn't exist (unlikely case) -> should return False
+-- * Cabal file doesn't exist (impossible since cabal-helper is only used with
+-- cabal projects) -> should return False
 --   @Just cc < Nothing = False@
---   TODO: should we delete dist/setup-config?
 --
 -- * dist/setup-config doesn't exist yet -> should return True:
 --   @Nothing < Just cf = True@
@@ -201,26 +261,29 @@ isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool
 isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do
   worldCabalConfig < worldCabalFile
 
+helperProgs :: Programs -> CH.Programs
+helperProgs progs = CH.Programs {
+    cabalProgram  = T.cabalProgram progs,
+    ghcProgram    = T.ghcProgram progs,
+    ghcPkgProgram = T.ghcPkgProgram progs
+  }
 
-helperProgs :: Options -> Programs
+chCached :: (Applicative m, IOish m, Gm m, Serialize a)
-helperProgs opts = Programs {
+  => (FilePath -> Cached m GhcModState ChCacheData a) -> m a
-                            cabalProgram  = T.cabalProgram opts,
-                            ghcProgram    = T.ghcProgram opts,
-                            ghcPkgProgram = T.ghcPkgProgram opts
-                          }
-
-chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a)
-  => Cached m GhcModState ChCacheData a -> m a
 chCached c = do
-  root <- cradleRootDir <$> cradle
+  projdir <- cradleRootDir <$> cradle
-  d <- cacheInputData root
+  distdir <- (projdir </>) . cradleDistDir <$> cradle
-  withCabal $ cached root c d
+  d <- cacheInputData projdir
+  withCabal $ cached projdir (c distdir) d
  where
-   cacheInputData root = do
+   -- we don't need to include the disdir in the cache input because when it
-               opt <- options
+   -- changes the cache files will be gone anyways ;)
-               return $ ( helperProgs opt
+   cacheInputData projdir = do
-                        , root
+               opts <- options
-                        , root </> "dist"
+               crdl <- cradle
+               progs' <- patchStackPrograms crdl (optPrograms opts)
+               return $ ( helperProgs progs'
+                        , projdir
                         , (gmVer, chVer)
                         )
 

Language/Haskell/GhcMod/Caching/Types.hs

@@ -47,6 +47,6 @@ data TimedCacheFiles = TimedCacheFiles {
   -- ^ 'cacheFile' timestamp
   tcFiles     :: [TimedFile]
   -- ^ Timestamped files returned by the cached action
- }
+ } deriving (Eq, Ord, Show)
 
-type ChCacheData = (Programs, FilePath, FilePath, (Version, [Char]))
+type ChCacheData = (Programs, FilePath, (Version, [Char]))

Language/Haskell/GhcMod/CaseSplit.hs

@@ -9,6 +9,7 @@ import Data.Maybe (isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T (readFile)
 import System.FilePath
+import Prelude
 
 import qualified DataCon as Ty
 import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
@@ -26,6 +27,7 @@ import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Doc
 import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
 
 ----------------------------------------------------------------
 -- CASE SPLITTING
@@ -47,12 +49,12 @@ splits :: IOish m
        -> GhcModT m String
 splits file lineNo colNo =
   ghandle handler $ runGmlT' [Left file] deferErrors $ do
-      opt <- options
+      oopts <- outputOpts
       crdl <- cradle
       style <- getStyle
       dflag <- G.getSessionDynFlags
-      modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
+      modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
-      whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
+      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
         (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
           let varName' = showName dflag style varName  -- Convert name to string
           t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
@@ -65,9 +67,9 @@ splits file lineNo colNo =
           return (fourInts bndLoc, t)
  where
    handler (SomeException ex) = do
-     gmLog GmDebug "splits" $
+     gmLog GmException "splits" $
            text "" $$ nest 4 (showDoc ex)
-     emptyResult =<< options
+     emptyResult =<< outputOpts
 
 ----------------------------------------------------------------
 -- a. Code for getting the information of the variable

Language/Haskell/GhcMod/Convert.hs

@@ -25,99 +25,99 @@ inter _ [] = id
 inter c bs = foldr1 (\x y -> x . (c:) . y) bs
 
 convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
-convert' x = flip convert x <$> options
+convert' x = flip convert x . optOutput <$> options
 
-convert :: ToString a => Options -> a -> String
+convert :: ToString a => OutputOpts -> a -> String
-convert opt@Options { outputStyle = LispStyle  } x = toLisp opt x "\n"
+convert opt@OutputOpts { ooptStyle = LispStyle  } x = toLisp opt x "\n"
-convert opt@Options { outputStyle = PlainStyle } x
+convert opt@OutputOpts { ooptStyle = PlainStyle } x
   | str == "\n" = ""
   | otherwise   = str
   where
     str = toPlain opt x "\n"
 
 class ToString a where
-  toLisp  :: Options -> a -> Builder
+  toLisp  :: OutputOpts -> a -> Builder
-  toPlain :: Options -> a -> Builder
+  toPlain :: OutputOpts -> a -> Builder
 
-lineSep :: Options -> String
+lineSep :: OutputOpts -> String
-lineSep opt = interpret lsep
+lineSep oopts = interpret lsep
   where
     interpret s = read $ "\"" ++ s ++ "\""
-    LineSeparator lsep = lineSeparator opt
+    LineSeparator lsep = ooptLineSeparator oopts
 
 -- |
 --
--- >>> toLisp defaultOptions "fo\"o" ""
+-- >>> toLisp (optOutput defaultOptions) "fo\"o" ""
 -- "\"fo\\\"o\""
--- >>> toPlain defaultOptions "foo" ""
+-- >>> toPlain (optOutput defaultOptions) "foo" ""
 -- "foo"
 instance ToString String where
-  toLisp  opt = quote opt
+  toLisp  oopts = quote oopts
-  toPlain opt = replace '\n' (lineSep opt)
+  toPlain oopts = replace '\n' (lineSep oopts)
 
 -- |
 --
--- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] ""
+-- >>> toLisp (optOutput defaultOptions) ["foo", "bar", "ba\"z"] ""
 -- "(\"foo\" \"bar\" \"ba\\\"z\")"
--- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
+-- >>> toPlain (optOutput defaultOptions) ["foo", "bar", "baz"] ""
 -- "foo\nbar\nbaz"
 instance ToString [String] where
-  toLisp  opt = toSexp1 opt
+  toLisp  oopts = toSexp1 oopts
-  toPlain opt = inter '\n' . map (toPlain opt)
+  toPlain oopts = inter '\n' . map (toPlain oopts)
 
 instance ToString [ModuleString] where
-  toLisp  opt = toLisp opt . map getModuleString
+  toLisp  oopts = toLisp oopts . map getModuleString
-  toPlain opt = toPlain opt . map getModuleString
+  toPlain oopts = toPlain oopts . map getModuleString
 
 -- |
 --
 -- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]
--- >>> toLisp defaultOptions inp ""
+-- >>> toLisp (optOutput defaultOptions) inp ""
 -- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"
--- >>> toPlain defaultOptions inp ""
+-- >>> toPlain (optOutput defaultOptions) inp ""
 -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
 instance ToString [((Int,Int,Int,Int),String)] where
-  toLisp  opt = toSexp2 . map toS
+  toLisp  oopts = toSexp2 . map toS
     where
-      toS x = ('(' :) . tupToString opt x . (')' :)
+      toS x = ('(' :) . tupToString oopts x . (')' :)
-  toPlain opt = inter '\n' . map (tupToString opt)
+  toPlain oopts = inter '\n' . map (tupToString oopts)
 
 instance ToString ((Int,Int,Int,Int),String) where
-  toLisp  opt x = ('(' :) . tupToString opt x . (')' :)
+  toLisp  oopts x = ('(' :) . tupToString oopts x . (')' :)
-  toPlain opt x = tupToString opt x
+  toPlain oopts x = tupToString oopts x
 
 instance ToString ((Int,Int,Int,Int),[String]) where
-  toLisp  opt (x,s) = ('(' :) . fourIntsToString opt x .
+  toLisp  oopts (x,s) = ('(' :) .  fourIntsToString x .
-                      (' ' :) . toLisp opt s . (')' :)
+                        (' ' :) . toLisp oopts s . (')' :)
-  toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
+  toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s
 
 instance ToString (String, (Int,Int,Int,Int),[String]) where
-  toLisp  opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
+  toLisp  oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y]
-  toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
+  toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y]
 
-toSexp1 :: Options -> [String] -> Builder
+toSexp1 :: OutputOpts -> [String] -> Builder
-toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
+toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)
 
 toSexp2 :: [Builder] -> Builder
 toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)
 
-fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder
+fourIntsToString :: (Int,Int,Int,Int) -> Builder
-fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)
+fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)
-                             . (show b ++) . (' ' :)
+                           . (show b ++) . (' ' :)
-                             . (show c ++) . (' ' :)
+                           . (show c ++) . (' ' :)
-                             . (show d ++)
+                           . (show d ++)
 
-tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder
+tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder
-tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)
+tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)
-                              . (show b ++) . (' ' :)
+                                . (show b ++) . (' ' :)
-                              . (show c ++) . (' ' :)
+                                . (show c ++) . (' ' :)
-                              . (show d ++) . (' ' :)
+                                . (show d ++) . (' ' :)
-                              . quote opt s -- fixme: quote is not necessary
+                                . quote oopts s -- fixme: quote is not necessary
 
-quote :: Options -> String -> Builder
+quote :: OutputOpts -> String -> Builder
-quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)
+quote oopts str = ("\"" ++) .  (quote' str ++) . ("\"" ++)
   where
-    lsep = lineSep opt
+    lsep = lineSep oopts
     quote' [] = []
     quote' (x:xs)
       | x == '\n' = lsep   ++ quote' xs
@@ -128,13 +128,13 @@ quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)
 ----------------------------------------------------------------
 
 -- Empty result to be returned when no info can be gathered
-emptyResult :: Monad m => Options -> m String
+emptyResult :: Monad m => OutputOpts -> m String
-emptyResult opt = return $ convert opt ([] :: [String])
+emptyResult oopts = return $ convert oopts ([] :: [String])
 
 -- Return an emptyResult when Nothing
-whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String
+whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String
-whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from
+whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from
 
 -- Return an emptyResult when Nothing, inside a monad
-whenFound' :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> m b) -> m String
+whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String
-whenFound' opt from f = maybe (emptyResult opt) (\x -> do y <- f x ; return (convert opt y)) =<< from
+whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from

Language/Haskell/GhcMod/Cradle.hs

@@ -1,14 +1,20 @@
-module Language.Haskell.GhcMod.Cradle (
+{-# LANGUAGE CPP #-}
+module Language.Haskell.GhcMod.Cradle
+#ifndef SPEC
+  (
     findCradle
   , findCradle'
   , findSpecCradle
   , cleanupCradle
-  ) where
+  )
+#endif
+  where
 
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
+import Language.Haskell.GhcMod.Stack
 
 import Control.Applicative
 import Control.Monad
@@ -24,66 +30,108 @@ import Prelude
 --   Find a cabal file by tracing ancestor directories.
 --   Find a sandbox according to a cabal sandbox config
 --   in a cabal directory.
-findCradle :: IO Cradle
+findCradle :: (IOish m, GmOut m) => m Cradle
-findCradle = findCradle' =<< getCurrentDirectory
+findCradle = findCradle' =<< liftIO getCurrentDirectory
 
-findCradle' :: FilePath -> IO Cradle
+findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle
-findCradle' dir = run $ do
+findCradle' dir = run $
-    (cabalCradle dir `mplus`  sandboxCradle dir `mplus` plainCradle dir)
+    msum [ stackCradle dir
+         , cabalCradle dir
+         , sandboxCradle dir
+         , plainCradle dir
+         ]
  where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
 
-findSpecCradle :: FilePath -> IO Cradle
+findSpecCradle :: (IOish m, GmOut m) => FilePath -> m Cradle
 findSpecCradle dir = do
-    let cfs = [cabalCradle, sandboxCradle]
+    let cfs = [stackCradleSpec, 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 =
-   isNotGmCradle crdl = do
+     liftIO $ not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")
-     not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")
 
 cleanupCradle :: Cradle -> IO ()
 cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
 
-fillTempDir :: MonadIO m => Cradle -> m Cradle
+fillTempDir :: IOish m => Cradle -> m Cradle
 fillTempDir crdl = do
   tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
   return crdl { cradleTempDir = tmpDir }
 
-cabalCradle :: FilePath -> MaybeT IO Cradle
+cabalCradle :: IOish m => FilePath -> MaybeT m Cradle
 cabalCradle wdir = do
-    cabalFile <- MaybeT $ findCabalFile wdir
+    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
 
     let cabalDir = takeDirectory cabalFile
 
     return Cradle {
-        cradleProjectType = CabalProject
+        cradleProject    = CabalProject
       , cradleCurrentDir = wdir
       , cradleRootDir    = cabalDir
       , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Just cabalFile
+      , cradleDistDir    = "dist"
       }
 
-sandboxCradle :: FilePath -> MaybeT IO Cradle
+stackCradle :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle
-sandboxCradle wdir = do
+stackCradle wdir = do
-    sbDir <- MaybeT $ findCabalSandboxDir wdir
+    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
+
+    let cabalDir = takeDirectory cabalFile
+
+    _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir
+
+    -- If dist/setup-config already exists the user probably wants to use cabal
+    -- rather than stack, or maybe that's just me ;)
+    whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero
+
+    senv <- MaybeT $ getStackEnv cabalDir
+
     return Cradle {
-        cradleProjectType = SandboxProject
+        cradleProject    = StackProject senv
+      , cradleCurrentDir = wdir
+      , cradleRootDir    = cabalDir
+      , cradleTempDir    = error "tmpDir"
+      , cradleCabalFile  = Just cabalFile
+      , cradleDistDir    = seDistDir senv
+      }
+
+stackCradleSpec :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle
+stackCradleSpec wdir = do
+  crdl <- stackCradle wdir
+  case crdl of
+    Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
+      b <- isGmDistDir seDistDir
+      when b mzero
+      return crdl
+    _ -> error "stackCradleSpec"
+ where
+   isGmDistDir dir =
+       liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")
+
+sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
+sandboxCradle wdir = do
+    sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
+    return Cradle {
+        cradleProject    = SandboxProject
       , cradleCurrentDir = wdir
       , cradleRootDir    = sbDir
       , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Nothing
+      , cradleDistDir    = "dist"
       }
 
-plainCradle :: FilePath -> MaybeT IO Cradle
+plainCradle :: IOish m => FilePath -> MaybeT m Cradle
 plainCradle wdir = do
     return $ Cradle {
-        cradleProjectType = PlainProject
+        cradleProject    = PlainProject
       , cradleCurrentDir = wdir
       , cradleRootDir    = wdir
       , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Nothing
+      , cradleDistDir    = "dist"
       }

Language/Haskell/GhcMod/CustomPackageDb.hs

@@ -0,0 +1,25 @@
+module Language.Haskell.GhcMod.CustomPackageDb where
+
+
+import Control.Applicative
+import Control.Monad
+import Control.Category ((.))
+import Data.Maybe
+import Data.Traversable
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.PathsAndFiles
+import Prelude hiding ((.))
+
+
+parseCustomPackageDb :: String -> [GhcPkgDb]
+parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src
+ where
+   parsePkgDb "global" = GlobalDb
+   parsePkgDb "user" = UserDb
+   parsePkgDb s = PackageDb s
+
+getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb])
+getCustomPkgDbStack = do
+    mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle
+    return $ parseCustomPackageDb <$> mCusPkgDbFile

Language/Haskell/GhcMod/Debug.hs

@@ -8,13 +8,14 @@ import qualified Data.Set as Set
 import Data.Char
 import Data.List.Split
 import Text.PrettyPrint
-import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Internal
 import Language.Haskell.GhcMod.Target
 import Language.Haskell.GhcMod.Pretty
 import Language.Haskell.GhcMod.Utils
+import Language.Haskell.GhcMod.Cradle
+import Language.Haskell.GhcMod.Stack
 
 ----------------------------------------------------------------
 
@@ -25,8 +26,9 @@ debugInfo = do
     Cradle {..} <- cradle
 
     cabal <-
-        case cradleProjectType of
+        case cradleProject of
           CabalProject -> cabalDebug
+          StackProject {} -> (++) <$> stackPaths <*> cabalDebug
           _ -> return []
 
     pkgOpts <- packageGhcOptions
@@ -38,9 +40,19 @@ debugInfo = do
               fsep $ map text pkgOpts)
       , "GHC System libraries: " ++ ghcLibDir
       , "GHC user options:\n"    ++ render (nest 4 $
-              fsep $ map text ghcUserOptions)
+              fsep $ map text optGhcUserOptions)
       ] ++ cabal
 
+stackPaths :: IOish m => GhcModT m [String]
+stackPaths = do
+    Cradle { cradleProject = StackProject senv } <- cradle
+    ghc <- getStackGhcPath senv
+    ghcPkg <- getStackGhcPkgPath senv
+    return $
+         [ "Stack ghc executable:    " ++ show ghc
+         , "Stack ghc-pkg executable:" ++ show ghcPkg
+         ]
+
 cabalDebug :: IOish m => GhcModT m [String]
 cabalDebug = do
     Cradle {..} <- cradle
@@ -52,6 +64,7 @@ cabalDebug = do
 
     return $
          [ "Cabal file:           " ++ show cradleCabalFile
+         , "Project:   " ++ show cradleProject
          , "Cabal entrypoints:\n"       ++ render (nest 4 $
               mapDoc gmComponentNameDoc smpDoc entrypoints)
          , "Cabal components:\n"        ++ render (nest 4 $
@@ -125,5 +138,5 @@ mapDoc kd ad m = vcat $
 ----------------------------------------------------------------
 
 -- | Obtaining root information.
-rootInfo :: IOish m => GhcModT m String
+rootInfo :: (IOish m, GmOut m) => m String
-rootInfo = convert' =<< cradleRootDir <$> cradle
+rootInfo = (++"\n") . cradleRootDir <$> findCradle

Language/Haskell/GhcMod/DebugLogger.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE CPP #-}
+module Language.Haskell.GhcMod.DebugLogger where
+
+
+import GHC
+import FastString
+import Pretty
+import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine)
+import qualified Outputable
+import ErrUtils
+
+import Language.Haskell.GhcMod.Error
+import Language.Haskell.GhcMod.Gap
+import Prelude
+
+debugLogAction :: (String -> IO ()) -> GmLogAction
+debugLogAction putErr dflags severity srcSpan style msg
+    = case severity of
+      SevOutput      -> printSDoc putErr msg style
+
+#if __GLASGOW_HASKELL__ >= 706
+      SevDump        -> printSDoc putErr (msg Outputable.$$ blankLine) style
+#endif
+
+#if __GLASGOW_HASKELL__ >= 708
+      SevInteractive -> let
+          putStrSDoc = debugLogActionHPutStrDoc dflags putErr
+       in
+          putStrSDoc msg style
+#endif
+      SevInfo        -> printErrs putErr msg style
+      SevFatal       -> printErrs putErr msg style
+      _              -> do putErr "\n"
+#if __GLASGOW_HASKELL__ >= 706
+                           printErrs putErr (mkLocMessage severity srcSpan msg) style
+#else
+                           printErrs putErr (mkLocMessage srcSpan msg) style
+#endif
+                           -- careful (#2302): printErrs prints in UTF-8,
+                           -- whereas converting to string first and using
+                           -- hPutStr would just emit the low 8 bits of
+                           -- each unicode char.
+    where
+#if __GLASGOW_HASKELL__ >= 706
+      printSDoc put = debugLogActionHPrintDoc  dflags put
+      printErrs put = debugLogActionHPrintDoc  dflags put
+#endif
+
+
+#if __GLASGOW_HASKELL__ >= 706
+
+debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
+debugLogActionHPrintDoc dflags put d sty
+ = debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty
+      -- Adds a newline
+
+debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
+debugLogActionHPutStrDoc dflags put d sty
+  = gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc
+  where   -- Don't add a newline at the end, so that successive
+          -- calls to this log-action can output all on the same line
+    doc = runSDoc d (initSDocContext dflags sty)
+
+#else
+
+printSDoc = printErrs
+
+printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO ()
+printErrs put doc sty = do
+  gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty))
+
+#endif
+
+gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()
+-- printDoc adds a newline to the end
+gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "")
+
+gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()
+gmPrintDoc_ mode pprCols putS doc
+  = fullRender mode pprCols 1.5 put done doc
+  where
+    put (Chr c)  next = putS [c] >> next
+    put (Str s)  next = putS s >> next
+    put (PStr s) next = putS (unpackFS s) >> next
+#if __GLASGOW_HASKELL__ >= 708
+    put (ZStr s) next = putS (zString s) >> next
+#endif
+    put (LStr s _l) next = putS (unpackLitString s) >> next
+
+    done = return () -- hPutChar hdl '\n'

Language/Haskell/GhcMod/DynFlags.hs

@@ -3,18 +3,23 @@
 module Language.Haskell.GhcMod.DynFlags where
 
 import Control.Applicative
-import Control.Monad (void)
+import Control.Monad
-import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..))
+import GHC
 import qualified GHC as G
 import GHC.Paths (libdir)
-import GhcMonad
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.DebugLogger
 import System.IO.Unsafe (unsafePerformIO)
 import Prelude
 
 setEmptyLogger :: DynFlags -> DynFlags
-setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
+setEmptyLogger df =
+    Gap.setLogAction df $ \_ _ _ _ _ -> return ()
+
+setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags
+setDebugLogger put df = do
+  Gap.setLogAction df (debugLogAction put)
 
 -- * Fast
 -- * Friendly to foreign export
@@ -99,4 +104,5 @@ setNoMaxRelevantBindings = id
 
 deferErrors :: DynFlags -> Ghc DynFlags
 deferErrors df = return $
-  Gap.setWarnTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df
+  Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $
+  Gap.setDeferTypeErrors $ setNoWarningFlags df

Language/Haskell/GhcMod/Error.hs

@@ -17,7 +17,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
 module Language.Haskell.GhcMod.Error (
     GhcModError(..)
-  , GMConfigStateFileError(..)
   , GmError
   , gmeDoc
   , ghcExceptionDoc
@@ -33,7 +32,7 @@ module Language.Haskell.GhcMod.Error (
   , module Control.Exception
   ) where
 
-import Control.Arrow
+import Control.Arrow hiding ((<+>))
 import Control.Exception
 import Control.Monad.Error hiding (MonadIO, liftIO)
 import qualified Data.Set as Set
@@ -53,37 +52,6 @@ import Language.Haskell.GhcMod.Pretty
 
 type GmError m = MonadError GhcModError m
 
-gmCsfeDoc :: GMConfigStateFileError -> Doc
-gmCsfeDoc GMConfigStateFileNoHeader = text $
-        "Saved package config file header is missing. "
-        ++ "Try re-running the 'configure' command."
-
-gmCsfeDoc GMConfigStateFileBadHeader = text $
-        "Saved package config file header is corrupt. "
-        ++ "Try re-running the 'configure' command."
-
-gmCsfeDoc GMConfigStateFileNoParse = text $
-        "Saved package config file body is corrupt. "
-        ++ "Try re-running the 'configure' command."
-
-gmCsfeDoc GMConfigStateFileMissing = text $
-    "Run the 'configure' command first."
-
--- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $
---         "You need to re-run the 'configure' command. "
---         ++ "The version of Cabal being used has changed (was "
---         ++ display oldCabal ++ ", now "
---         ++ display currentCabalId ++ ")."
---         ++ badCompiler
---       where
---         badCompiler
---           | oldCompiler == currentCompilerId = ""
---           | otherwise =
---               " Additionally the compiler is different (was "
---               ++ display oldCompiler ++ ", now "
---               ++ display currentCompilerId
---               ++ ") which is probably the cause of the problem."
-
 gmeDoc :: GhcModError -> Doc
 gmeDoc e = case e of
     GMENoMsg ->
@@ -91,12 +59,11 @@ gmeDoc e = case e of
     GMEString msg ->
         text msg
     GMECabalConfigure msg ->
-        text "Configuring cabal project failed: " <> gmeDoc msg
+        text "Configuring cabal project failed" <+>: gmeDoc msg
-    GMECabalFlags msg ->
+    GMEStackConfigure msg ->
-        text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg
+        text "Configuring stack project failed" <+>: gmeDoc msg
-    GMECabalComponent cn ->
+    GMEStackBootstrap msg ->
-        text "Cabal component " <> quotes (gmComponentNameDoc cn)
+        text "Bootstrapping stack project environment failed" <+>: 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) $$
@@ -125,21 +92,23 @@ gmeDoc e = case e of
         compsDoc sc | Set.null sc = text "has no known components"
         compsDoc sc = fsep $ punctuate comma $
                         map gmComponentNameDoc $ Set.toList sc
-
+    GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in
-    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 $
+          Left rv -> text $
              printf "Launching system command `%s` failed (exited with %d)" c rv
     GMENoCabalFile ->
         text "No cabal file found."
     GMETooManyCabalFiles cfs ->
         text $ "Multiple cabal files found. Possible cabal files: \""
                ++ intercalate "\", \"" cfs ++"\"."
-    GMECabalStateFile csfe ->
+    GMEWrongWorkingDirectory projdir cdir ->
-        gmCsfeDoc csfe
+        (text $ "You must run ghc-mod in the project directory as returned by `ghc-mod root`.")
+          <+> text "Currently in:" <+> showDoc cdir
+          <> text "but should be in" <+> showDoc projdir
+          <> text "."
 
 ghcExceptionDoc :: GhcException -> Doc
 ghcExceptionDoc e@(CmdLineError _) =
@@ -161,7 +130,6 @@ ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\
 
 ghcExceptionDoc e = text $ showGhcException e ""
 
-
 liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a
 liftMaybe e action = maybe (throwError e) return =<< action
 
@@ -175,7 +143,6 @@ 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)

Language/Haskell/GhcMod/FileMapping.hs

@@ -0,0 +1,72 @@
+module Language.Haskell.GhcMod.FileMapping
+    ( loadMappedFile
+    , loadMappedFileSource
+    , unloadMappedFile
+    , mapFile
+    , fileModSummaryWithMapping
+    ) where
+
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Gap
+import Language.Haskell.GhcMod.HomeModuleGraph
+import Language.Haskell.GhcMod.Utils
+
+import System.IO
+import System.FilePath
+import System.Directory
+
+import Control.Monad.Trans.Maybe
+import GHC
+import Control.Monad
+
+loadMappedFile :: IOish m => FilePath -> FilePath -> GhcModT m ()
+loadMappedFile from to = loadMappedFile' from to False
+
+loadMappedFileSource :: IOish m => FilePath -> String -> GhcModT m ()
+loadMappedFileSource from src = do
+  tmpdir <- cradleTempDir `fmap` cradle
+  to <- liftIO $ do
+    (fn, h) <- openTempFile tmpdir (takeFileName from)
+    hPutStr h src
+    hClose h
+    return fn
+  loadMappedFile' from to True
+
+loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m ()
+loadMappedFile' from to isTemp = do
+  cfn <- getCanonicalFileNameSafe from
+  unloadMappedFile' cfn
+  addMMappedFile cfn (FileMapping to isTemp)
+
+mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>
+            HscEnv -> Target -> m Target
+mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do
+  mapping <- lookupMMappedFile filePath
+  mkMappedTarget (Just filePath) tid taoc mapping
+mapFile env (Target tid@(TargetModule moduleName) taoc _) = do
+  (fp, mapping) <- do
+    filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName)
+    mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile
+    return (filePath, mmf)
+  mkMappedTarget fp tid taoc mapping
+
+mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) =>
+                  Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target
+mkMappedTarget _ _ taoc (Just to) =
+  return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing
+mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing
+
+unloadMappedFile :: IOish m => FilePath -> GhcModT m ()
+unloadMappedFile = getCanonicalFileNameSafe >=> unloadMappedFile'
+
+unloadMappedFile' :: IOish m => FilePath -> GhcModT m ()
+unloadMappedFile' cfn = void $ runMaybeT $ do
+  fm <- MaybeT $ lookupMMappedFile cfn
+  liftIO $ when (fmTemp fm) $ removeFile (fmPath fm)
+  delMMappedFile cfn
+
+fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>
+                            FilePath -> m ModSummary
+fileModSummaryWithMapping fn =
+  withMappedFile fn $ \fn' -> fileModSummary fn'

Language/Haskell/GhcMod/FillSig.hs

@@ -9,15 +9,27 @@ module Language.Haskell.GhcMod.FillSig (
 
 import Data.Char (isSymbol)
 import Data.Function (on)
+import Data.Functor
 import Data.List (find, nub, sortBy)
 import qualified Data.Map as M
 import Data.Maybe (catMaybes)
 import Text.PrettyPrint (($$), text, nest)
+import Prelude
+
 import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
             SrcSpan, Type, GenLocated(L))
 import qualified GHC as G
 import qualified Name as G
+import Outputable (PprStyle)
+import qualified Type as Ty
+import qualified HsBinds as Ty
+import qualified Class as Ty
+import qualified Var as Ty
+import qualified HsPat as Ty
+import qualified Language.Haskell.Exts.Annotated as HE
+import Djinn.GHC
+
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.DynFlags
@@ -27,14 +39,7 @@ import Language.Haskell.GhcMod.Logging (gmLog)
 import Language.Haskell.GhcMod.Pretty (showDoc)
 import Language.Haskell.GhcMod.Doc
 import Language.Haskell.GhcMod.Types
-import Outputable (PprStyle)
+import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
-import qualified Type as Ty
-import qualified HsBinds as Ty
-import qualified Class as Ty
-import qualified Var as Ty
-import qualified HsPat as Ty
-import qualified Language.Haskell.Exts.Annotated as HE
-import Djinn.GHC
 
 #if __GLASGOW_HASKELL__ >= 710
 import GHC (unLoc)
@@ -73,11 +78,11 @@ sig :: IOish m
     -> GhcModT m String
 sig file lineNo colNo =
     runGmlT' [Left file] deferErrors $ ghandle fallback $ do
-      opt <- options
+      oopts <- outputOpts
       style <- getStyle
       dflag <- G.getSessionDynFlags
-      modSum <- Gap.fileModSummary file
+      modSum <- fileModSummaryWithMapping file
-      whenFound opt (getSignature modSum lineNo colNo) $ \s ->
+      whenFound oopts (getSignature modSum lineNo colNo) $ \s ->
         case s of
           Signature loc names ty ->
               ("function", fourInts loc, map (initialBody dflag style ty) names)
@@ -92,10 +97,10 @@ sig file lineNo colNo =
             in (rTy, fourInts loc, [initial ++ body])
   where
     fallback (SomeException _) = do
-      opt <- options
+      oopts <- outputOpts
       -- Code cannot be parsed by ghc module
       -- Fallback: try to get information via haskell-src-exts
-      whenFound opt (getSignatureFromHE file lineNo colNo) $ \x -> case x of
+      whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of
         HESignature loc names ty ->
           ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
         HEFamSignature loc flavour name vars ->
@@ -342,14 +347,14 @@ refine :: IOish m
 refine file lineNo colNo (Expression expr) =
   ghandle handler $
     runGmlT' [Left file] deferErrors $ do
-      opt <- options
+      oopts <- outputOpts
       style <- getStyle
       dflag <- G.getSessionDynFlags
-      modSum <- Gap.fileModSummary file
+      modSum <- fileModSummaryWithMapping file
       p <- G.parseModule modSum
       tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
       ety <- G.exprType expr
-      whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
+      whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $
         \(loc, name, rty, paren) ->
             let eArgs = getFnArgs ety
                 rArgs = getFnArgs rty
@@ -360,9 +365,9 @@ refine file lineNo colNo (Expression expr) =
              in (fourInts loc, doParen paren txt)
   where
    handler (SomeException ex) = do
-     gmLog GmDebug "refining" $
+     gmLog GmException "refining" $
            text "" $$ nest 4 (showDoc ex)
-     emptyResult =<< options
+     emptyResult =<< outputOpts
 
 -- Look for the variable in the specified position
 findVar
@@ -419,16 +424,16 @@ auto :: IOish m
      -> GhcModT m String
 auto file lineNo colNo =
   ghandle handler $ runGmlT' [Left file] deferErrors $ do
-        opt <- options
+        oopts <- outputOpts
         style <- getStyle
         dflag <- G.getSessionDynFlags
-        modSum <- Gap.fileModSummary file
+        modSum <- fileModSummaryWithMapping file
         p <- G.parseModule modSum
         tcm@TypecheckedModule {
                  tm_typechecked_source = tcs
                , tm_checked_module_info = minfo
                } <- G.typecheckModule p
-        whenFound' opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do
+        whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do
           topLevel <- getEverythingInTopLevel minfo
           let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
               -- Remove self function to prevent recursion, and id to trim
@@ -449,9 +454,9 @@ auto file lineNo colNo =
                  , map (doParen paren) $ nub (djinnsEmpty ++ djinns))
  where
    handler (SomeException ex) = do
-     gmLog GmDebug "auto-refining" $
+     gmLog GmException "auto-refining" $
            text "" $$ nest 4 (showDoc ex)
-     emptyResult =<< options
+     emptyResult =<< outputOpts
 
 -- Functions we do not want in completions
 notWantedFuns :: [String]

Language/Haskell/GhcMod/Gap.hs

@@ -4,16 +4,18 @@ module Language.Haskell.GhcMod.Gap (
     Language.Haskell.GhcMod.Gap.ClsInst
   , mkTarget
   , withStyle
+  , GmLogAction
   , setLogAction
   , getSrcSpan
   , getSrcFile
-  , withContext
+  , withInteractiveContext
   , fOptions
   , toStringBuffer
   , showSeverityCaption
   , setCabalPkg
   , setHideAllPackages
   , setDeferTypeErrors
+  , setDeferTypedHoles
   , setWarnTypedHoles
   , setDumpSplices
   , isDumpSplices
@@ -41,6 +43,7 @@ module Language.Haskell.GhcMod.Gap (
   , lookupModulePackageInAllPackages
   , Language.Haskell.GhcMod.Gap.isSynTyCon
   , parseModuleHeader
+  , mkErrStyle'
   ) where
 
 import Control.Applicative hiding (empty)
@@ -67,6 +70,7 @@ import TcType
 import Var (varType)
 import System.Directory
 
+import qualified Name
 import qualified InstEnv
 import qualified Pretty
 import qualified StringBuffer as SB
@@ -132,9 +136,13 @@ withStyle = withPprStyleDoc
 withStyle _ = withPprStyleDoc
 #endif
 
-setLogAction :: DynFlags
+#if __GLASGOW_HASKELL__ >= 706
-             -> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ())
+type GmLogAction = LogAction
-             -> DynFlags
+#else
+type GmLogAction = DynFlags -> LogAction
+#endif
+
+setLogAction :: DynFlags -> GmLogAction -> DynFlags
 setLogAction df f =
 #if __GLASGOW_HASKELL__ >= 706
     df { log_action = f }
@@ -211,8 +219,8 @@ fileModSummary file' = do
         (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)
     return ms
 
-withContext :: GhcMonad m => m a -> m a
+withInteractiveContext :: GhcMonad m => m a -> m a
-withContext action = gbracket setup teardown body
+withInteractiveContext action = gbracket setup teardown body
   where
     setup = getContext
     teardown = setCtx
@@ -220,32 +228,24 @@ withContext action = gbracket setup teardown body
         topImports >>= setCtx
         action
     topImports = do
-        mss <- getModuleGraph
+        ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph
-        mns <- map modName <$> filterM isTop mss
+        let iis = map (IIModule . modName) ms
-        let ii = map IIModule mns
 #if __GLASGOW_HASKELL__ >= 704
-        return ii
+        return iis
 #else
-        return (ii,[])
+        return (iis,[])
 #endif
-    isTop mos = lookupMod mos ||> returnFalse
-    lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True
-    returnFalse = return False
 #if __GLASGOW_HASKELL__ >= 706
-    modName = moduleName . ms_mod
+    modName = moduleName
     setCtx = setContext
 #elif __GLASGOW_HASKELL__ >= 704
-    modName = ms_mod
+    modName = id
     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: "
@@ -293,6 +293,13 @@ setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors
 setDeferTypeErrors = id
 #endif
 
+setDeferTypedHoles :: DynFlags -> DynFlags
+#if __GLASGOW_HASKELL__ >= 710
+setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles
+#else
+setDeferTypedHoles = id
+#endif
+
 setWarnTypedHoles :: DynFlags -> DynFlags
 #if __GLASGOW_HASKELL__ >= 708
 setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles
@@ -328,8 +335,8 @@ filterOutChildren get_thing xs
   where
     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 
-infoThing :: GhcMonad m => Expression -> m SDoc
+infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc
-infoThing (Expression str) = do
+infoThing m (Expression str) = do
     names <- parseName str
 #if __GLASGOW_HASKELL__ >= 708
     mb_stuffs <- mapM (getInfo False) names
@@ -338,30 +345,45 @@ infoThing (Expression str) = do
     mb_stuffs <- mapM getInfo names
     let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
 #endif
-    return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
+    return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)
 
 #if __GLASGOW_HASKELL__ >= 708
-pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
+pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
-pprInfo _ (thing, fixity, insts, famInsts)
+pprInfo m _ (thing, fixity, insts, famInsts)
-    = pprTyThingInContextLoc thing
+    = pprTyThingInContextLoc' thing
    $$ show_fixity fixity
    $$ InstEnv.pprInstances insts
    $$ pprFamInsts famInsts
-  where
-    show_fixity fx
-      | fx == defaultFixity = Outputable.empty
-      | otherwise           = ppr fx <+> ppr (getName thing)
 #else
-pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
+pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
-pprInfo pefas (thing, fixity, insts)
+pprInfo m pefas (thing, fixity, insts)
-    = pprTyThingInContextLoc pefas thing
+    = pprTyThingInContextLoc' pefas thing
    $$ show_fixity fixity
    $$ vcat (map pprInstance insts)
+#endif
   where
     show_fixity fx
       | fx == defaultFixity = Outputable.empty
       | otherwise           = ppr fx <+> ppr (getName thing)
+#if __GLASGOW_HASKELL__ >= 708
+    pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2
+                                        (char '\t' <> ptext (sLit "--") <+> loc)
+                         where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
+#else
+    pprTyThingInContextLoc' pefas thing' = hang (pprTyThingInContext pefas thing') 2
+                                    (char '\t' <> ptext (sLit "--") <+> loc)
+                               where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
 #endif
+    pprNameDefnLoc' name
+      = case Name.nameSrcLoc name of
+           RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)
+           UnhelpfulLoc s
+             | Name.isInternalName name || Name.isSystemName name
+             -> ptext (sLit "at") <+> ftext s
+             | otherwise
+             -> ptext (sLit "in") <+> quotes (ppr (nameModule name))
+      where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s)
+            realFP = mkFastString . m . unpackFS . srcLocFile
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------
@@ -535,3 +557,10 @@ parseModuleHeader str dflags filename =
      POk pst rdr_module ->
          let (warns,_) = getMessages pst in
          Right (warns, rdr_module)
+
+mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle
+#if __GLASGOW_HASKELL__ >= 706
+mkErrStyle' = Outputable.mkErrStyle
+#else
+mkErrStyle' _ = Outputable.mkErrStyle
+#endif

Language/Haskell/GhcMod/GhcPkg.hs

@@ -6,6 +6,7 @@ module Language.Haskell.GhcMod.GhcPkg (
   , ghcDbOpt
   , getPackageDbStack
   , getPackageCachePaths
+  , getGhcPkgProgram
   ) where
 
 import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
@@ -21,6 +22,8 @@ import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.CabalHelper
 import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.CustomPackageDb
+import Language.Haskell.GhcMod.Stack
 
 ghcVersion :: Int
 ghcVersion = read cProjectVersionInt
@@ -59,18 +62,31 @@ ghcDbOpt (PackageDb pkgDb)
 
 ----------------------------------------------------------------
 
+getGhcPkgProgram :: IOish m => GhcModT m FilePath
+getGhcPkgProgram = do
+  crdl <- cradle
+  progs <- optPrograms <$> options
+  case cradleProject crdl of
+    (StackProject senv) -> do
+        Just ghcPkg <- getStackGhcPkgPath senv
+        return ghcPkg
+    _ ->
+        return $ ghcPkgProgram progs
+
 getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]
 getPackageDbStack = do
   crdl <- cradle
   mCusPkgStack <- getCustomPkgDbStack
-  stack <- case cradleProjectType crdl of
+  stack <- case cradleProject crdl of
     PlainProject ->
         return [GlobalDb, UserDb]
     SandboxProject -> do
-        Just db <- liftIO $ getSandboxDb $ cradleRootDir crdl
+        Just db <- liftIO $ getSandboxDb crdl
         return $ [GlobalDb, db]
     CabalProject ->
         getCabalPackageDbStack
+    (StackProject StackEnv {..}) ->
+        return $ map PackageDb [seSnapshotPkgDb, seLocalPkgDb]
   return $ fromMaybe stack mCusPkgStack
 
 getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]

Language/Haskell/GhcMod/HomeModuleGraph.hs

@@ -54,12 +54,14 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import System.FilePath
 import System.Directory
+import System.IO
 import Prelude
 
 import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Logger
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils (withMappedFile)
 import Language.Haskell.GhcMod.Gap (parseModuleHeader)
 
 -- | Turn module graph into a graphviz dot file
@@ -124,7 +126,7 @@ pruneUnreachable smp0 gmg@GmModuleGraph {..} = let
 collapseMaybeSet :: Maybe (Set a) -> Set a
 collapseMaybeSet = maybe Set.empty id
 
-homeModuleGraph :: (IOish m, GmLog m, GmEnv m)
+homeModuleGraph :: (IOish m, Gm m)
     => HscEnv -> Set ModulePath -> m GmModuleGraph
 homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp
 
@@ -159,7 +161,7 @@ canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do
    fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp))
 
 
-updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m)
+updateHomeModuleGraph :: (IOish m, Gm m)
                       => HscEnv
                       -> GmModuleGraph
                       -> Set ModulePath -- ^ Initial set of modules
@@ -185,7 +187,7 @@ 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)
+    :: forall m. (MonadState S m, IOish m, Gm m)
     => HscEnv
     -> Set ModulePath     -- ^ Initial set of modules
     -> m ()
@@ -224,6 +226,7 @@ updateHomeModuleGraph' env smp0 = do
             gmLog GmWarning ("preprocess " ++ show fn) $ Monoid.mempty $+$ (vcat $ map text errs)
             return Nothing
 
+
    imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath)
    imports mp@ModulePath {..} src dflags =
        case parseModuleHeader src dflags mpPath of
@@ -239,25 +242,28 @@ updateHomeModuleGraph' env smp0 = do
                    $ map unLoc hsmodImports
            liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns
 
-preprocessFile :: MonadIO m =>
+preprocessFile :: (IOish m, GmEnv m, GmState m) =>
   HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))
 preprocessFile env file =
-  liftIO $ withLogger' env $ \setDf -> do
+  withLogger' env $ \setDf -> do
-    let env' = env { hsc_dflags = setDf (hsc_dflags env) }
+    withMappedFile file $ \fn -> do
-    preprocess env' (file, Nothing)
+      let env' = env { hsc_dflags = setDf (hsc_dflags env) }
+      liftIO $ preprocess env' (fn, Nothing)
 
-fileModuleName ::
+fileModuleName :: (IOish m, GmEnv m, GmState m) =>
-  HscEnv -> FilePath -> IO (Either [String] (Maybe ModuleName))
+  HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))
-fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do
+fileModuleName env fn = do
+    let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing)
     ep <- preprocessFile env fn
     case ep of
       Left errs -> do
         return $ Left errs
-      Right (_warns, (dflags, procdFile)) -> do
+      Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do
         src <- readFile procdFile
         case parseModuleHeader src dflags procdFile of
-          Left errs -> do
+          Left errs -> return $ Left errs
-            return $ Left $ errBagToStrList env errs
           Right (_, lmdl) -> do
             let HsModule {..} = unLoc lmdl
-            return $ Right $ unLoc <$> hsmodName
+            return $ Right $ unLoc <$> hsmodName)
+  where
+    leftM f = either (return . Left <=< f) (return . Right)

Language/Haskell/GhcMod/Info.hs

@@ -3,7 +3,6 @@ module Language.Haskell.GhcMod.Info (
   , types
   ) where
 
-import Control.Applicative
 import Data.Function (on)
 import Data.List (sortBy)
 import Data.Maybe (catMaybes)
@@ -22,6 +21,8 @@ import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
+import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
 
 ----------------------------------------------------------------
 
@@ -33,16 +34,17 @@ info :: IOish m
 info file expr =
   ghandle handler $
     runGmlT' [Left file] deferErrors $
-      withContext $
+      withInteractiveContext $ do
-        convert <$> options <*> body
+        convert' =<< body
   where
     handler (SomeException ex) = do
       gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
       convert' "Cannot show info"
 
-    body :: GhcMonad m => m String
+    body :: (GhcMonad m, GmState m, GmEnv m) => m String
     body = do
-      sdoc  <- Gap.infoThing expr
+      m <- mkRevRedirMapFunc
+      sdoc  <- Gap.infoThing m expr
       st    <- getStyle
       dflag <- G.getSessionDynFlags
       return $ showPage dflag st sdoc
@@ -58,9 +60,9 @@ types :: IOish m
 types file lineNo colNo =
   ghandle handler $
     runGmlT' [Left file] deferErrors $
-      withContext $ do
+      withInteractiveContext $ do
         crdl         <- cradle
-        modSum       <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
+        modSum       <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
         srcSpanTypes <- getSrcSpanType modSum lineNo colNo
         dflag        <- G.getSessionDynFlags
         st           <- getStyle

Language/Haskell/GhcMod/Internal.hs

@@ -40,6 +40,7 @@ module Language.Haskell.GhcMod.Internal (
   , cradle
   , getCompilerMode
   , setCompilerMode
+  , targetGhcOptions
   , withOptions
   -- * 'GhcModError'
   , gmeDoc
@@ -56,6 +57,8 @@ module Language.Haskell.GhcMod.Internal (
   -- * Misc stuff
   , GHandler(..)
   , gcatches
+  -- * FileMapping
+  , module Language.Haskell.GhcMod.FileMapping
   ) where
 
 import GHC.Paths (libdir)
@@ -70,6 +73,7 @@ import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.World
 import Language.Haskell.GhcMod.CabalHelper
+import Language.Haskell.GhcMod.FileMapping
 
 -- | Obtaining the directory for ghc system libraries.
 ghcLibDir :: FilePath

Language/Haskell/GhcMod/LightGhc.hs

@@ -0,0 +1,44 @@
+module Language.Haskell.GhcMod.LightGhc where
+
+import Control.Monad.Reader (runReaderT)
+import Data.IORef
+
+import GHC
+import GHC.Paths (libdir)
+import StaticFlags
+import SysTools
+import DynFlags
+import HscMain
+import HscTypes
+
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.DynFlags
+
+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 =<< addCmdOpts opts =<< getSessionDynFlags
+         getSessionDynFlags
+     newHscEnv dflags'
+
+runLightGhc :: HscEnv -> LightGhc a -> IO a
+runLightGhc env action = do
+  renv <- newIORef env
+  flip runReaderT renv $ unLightGhc action

Language/Haskell/GhcMod/Lint.hs

@@ -8,6 +8,10 @@ import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.HLint (hlint)
 
+import Language.Haskell.GhcMod.Utils (withMappedFile)
+
+import Data.List (stripPrefix)
+
 -- | Checking syntax of a target file using hlint.
 --   Warnings and errors are returned.
 lint :: IOish m
@@ -15,7 +19,11 @@ lint :: IOish m
      -> GhcModT m String
 lint file = do
   opt <- options
-  ghandle handler . pack =<< liftIO (hlint $ file : "--quiet" : hlintOpts opt)
+  withMappedFile file $ \tempfile ->
+        liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt)
+    >>= mapM (replaceFileName tempfile)
+    >>= ghandle handler . pack
  where
-    pack = convert' . map (init . show) -- init drops the last \n.
+    pack = convert' . map init -- init drops the last \n.
     handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
+    replaceFileName fp s = return $ maybe (show s) (file++) $ stripPrefix fp (show s)

Language/Haskell/GhcMod/Logger.hs

@@ -8,14 +8,17 @@ module Language.Haskell.GhcMod.Logger (
 
 import Control.Arrow
 import Control.Applicative
-import Data.List (isPrefixOf)
+import Data.Ord
-import Data.Maybe (fromMaybe)
+import Data.List
+import Data.Maybe
+import Data.Function
+import Control.Monad.Reader (Reader, asks, runReader)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
 import System.FilePath (normalise)
 import Text.PrettyPrint
 
-import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
+import ErrUtils
-import GHC (DynFlags, SrcSpan, Severity(SevError))
+import GHC
 import HscTypes
 import Outputable
 import qualified GHC as G
@@ -26,6 +29,7 @@ import Language.Haskell.GhcMod.Doc (showPage)
 import Language.Haskell.GhcMod.DynFlags (withDynFlags)
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Error
+import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Prelude
 
@@ -35,6 +39,12 @@ data Log = Log [String] Builder
 
 newtype LogRef = LogRef (IORef Log)
 
+data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags
+                         , gpeMapFile :: FilePath -> FilePath
+                         }
+
+type GmPprEnvM a = Reader GmPprEnv a
+
 emptyLog :: Log
 emptyLog = Log [] id
 
@@ -47,99 +57,113 @@ readAndClearLogRef (LogRef ref) = do
     writeIORef ref emptyLog
     return $ b []
 
-appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
+appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
-appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update
+appendLogRef rfm df (LogRef ref) _ sev src st msg = do
+    modifyIORef ref update
   where
-    l = ppMsg src sev df st msg
+    gpe = GmPprEnv {
+            gpeDynFlags = df
+          , gpeMapFile = rfm
+          }
+    l = runReader (ppMsg st src sev msg) gpe
+
     update lg@(Log ls b)
       | l `elem` ls = lg
       | otherwise   = Log (l:ls) (b . (l:))
 
 ----------------------------------------------------------------
 
--- | Set the session flag (e.g. "-Wall" or "-w:") then
+-- | Logged messages are returned as 'String'.
---   executes a body. Logged messages are returned as 'String'.
 --   Right is success and Left is failure.
-withLogger :: (GmGhc m, GmEnv m)
+withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m)
            => (DynFlags -> DynFlags)
            -> m a
            -> m (Either String (String, a))
 withLogger f action = do
   env <- G.getSession
-  opts <- options
+  oopts <- outputOpts
-  let conv = convert opts
+  let conv = convert oopts
   eres <- withLogger' env $ \setDf ->
       withDynFlags (f . setDf) action
   return $ either (Left . conv) (Right . first conv) eres
 
-withLogger' :: IOish m
+withLogger' :: (IOish m, GmState m, GmEnv m)
     => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
 withLogger' env action = do
     logref <- liftIO $ newLogRef
 
-    let dflags = hsc_dflags env
+    rfm <- mkRevRedirMapFunc
-        pu = icPrintUnqual dflags (hsc_IC env)
-        st = mkUserStyle pu AllTheWay
 
-        fn df  = setLogger logref df
+    let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref
+        handlers = [
+            GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe,
+            GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
+          ]
+        gpe = GmPprEnv {
+                gpeDynFlags = hsc_dflags env
+              , gpeMapFile = rfm
+        }
 
-    a <- gcatches (Right <$> action fn) (handlers dflags st)
+    a <- gcatches (Right <$> action setLogger) handlers
     ls <- liftIO $ readAndClearLogRef logref
 
-    return $ ((,) ls <$> a)
+    return ((,) ls <$> a)
 
-  where
+errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]
-    setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
+errBagToStrList env errs = do
-    handlers df st = [
+   rfm <- mkRevRedirMapFunc
-        GHandler $ \ex -> return $ Left $ sourceError df st ex,
+   return $ runReader
-        GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
+    (errsToStr (sortMsgBag errs))
-     ]
+    GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }
-
-errBagToStrList :: HscEnv -> Bag ErrMsg -> [String]
-errBagToStrList env errs = let
-    dflags = hsc_dflags env
-    pu = icPrintUnqual dflags (hsc_IC env)
-    st = mkUserStyle pu AllTheWay
- in errsToStr dflags st $ bagToList errs
 
 ----------------------------------------------------------------
 
 -- | Converting 'SourceError' to 'String'.
-sourceError :: DynFlags -> PprStyle -> SourceError -> [String]
+sourceError :: SourceError -> GmPprEnvM [String]
-sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err
+sourceError = errsToStr . sortMsgBag . srcErrorMessages
 
-errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String]
+errsToStr :: [ErrMsg] -> GmPprEnvM [String]
-errsToStr df st = map (ppErrMsg df st)
+errsToStr = mapM ppErrMsg
+
+sortMsgBag :: Bag ErrMsg -> [ErrMsg]
+sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag
 
 ----------------------------------------------------------------
 
-ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
+ppErrMsg :: ErrMsg -> GmPprEnvM String
-ppErrMsg dflag st err =
+ppErrMsg err = do
-    ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext)
+    dflags <- asks gpeDynFlags
+    let unqual = errMsgContext err
+        st = Gap.mkErrStyle' dflags unqual
+    let ext = showPage dflags st (errMsgExtraInfo err)
+    m <- ppMsg st spn SevError msg
+    return $ m ++ (if null ext then "" else "\n" ++ ext)
    where
      spn = Gap.errorMsgSpan err
      msg = errMsgShortDoc err
-     ext = showPage dflag st (errMsgExtraInfo err)
 
-ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
+ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String
-ppMsg spn sev dflag st msg = prefix ++ cts
+ppMsg st spn sev msg = do
-  where
+  dflags <- asks gpeDynFlags
-    cts  = showPage dflag st msg
+  let cts  = showPage dflags st msg
-    prefix = ppMsgPrefix spn sev dflag st cts
+  prefix <- ppMsgPrefix spn sev cts
+  return $ prefix ++ cts
 
-ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String
+ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String
-ppMsgPrefix spn sev dflag _st cts =
+ppMsgPrefix spn sev cts = do
+  dflags <- asks gpeDynFlags
+  mr <- asks gpeMapFile
   let defaultPrefix
-        | Gap.isDumpSplices dflag = ""
+        | Gap.isDumpSplices dflags = ""
         | otherwise               = checkErrorPrefix
-   in fromMaybe defaultPrefix $ do
+  return $ fromMaybe defaultPrefix $ do
-        (line,col,_,_) <- Gap.getSrcSpan spn
+    (line,col,_,_) <- Gap.getSrcSpan spn
-        file <- normalise <$> Gap.getSrcFile spn
+    file <- mr <$> normalise <$> Gap.getSrcFile spn
-        let severityCaption = Gap.showSeverityCaption sev
+    let severityCaption = Gap.showSeverityCaption sev
-            pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
+        pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
-                              = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
+                          = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
-                  | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
+              | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
-        return pref0
+    return pref0
 
 checkErrorPrefix :: String
 checkErrorPrefix = "Dummy:0:0:Error:"

Language/Haskell/GhcMod/Logging.hs

@@ -65,7 +65,7 @@ decreaseLogLevel l = pred l
 -- True
 -- >>> Just GmDebug <= Just GmException
 -- False
-gmLog :: (MonadIO m, GmLog m, GmEnv m) => GmLogLevel -> String -> Doc -> m ()
+gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()
 gmLog level loc' doc = do
   GhcModLog { gmLogLevel = Just level' } <- gmlHistory
 
@@ -78,7 +78,7 @@ gmLog level loc' doc = do
 
   gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)])
 
-gmVomit :: (MonadIO m, GmLog m, GmEnv m) => String -> Doc -> String -> m ()
+gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m ()
 gmVomit filename doc content = do
   gmLog GmVomit "" $ doc <+>: text content
 

Language/Haskell/GhcMod/Modules.hs

@@ -14,13 +14,13 @@ import qualified GHC as G
 ----------------------------------------------------------------
 
 -- | Listing installed modules.
-modules :: (IOish m, GmEnv m, GmState m, GmLog m) => m String
+modules :: (IOish m, Gm m) => m String
 modules = do
-  Options { detailed } <- options
+  Options { optDetailed } <- options
   df <- runGmPkgGhc G.getSessionDynFlags
   let mns = listVisibleModuleNames df
       pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)
-  convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn
+  convert' $ nub [ if optDetailed then pkg ++ " " ++ mn else mn
                  | (mn, pkgs) <- pmnss, pkg <- pkgs ]
  where
    modulePkg df = lookupModulePackageInAllPackages df

Language/Haskell/GhcMod/Monad.hs

@@ -16,9 +16,10 @@
 
 {-# LANGUAGE CPP #-}
 module Language.Haskell.GhcMod.Monad (
-    runGhcModT
+    runGmOutT
+  , runGmOutT'
+  , runGhcModT
   , runGhcModT'
-  , runGhcModT''
   , hoistGhcModT
   , runGmlT
   , runGmlT'
@@ -46,55 +47,59 @@ import Control.Monad.Reader (runReaderT)
 import Control.Monad.State.Strict (runStateT)
 import Control.Monad.Trans.Journal (runJournalT)
 
-import Exception (ExceptionMonad(..))
+import Exception
 
 import System.Directory
 import Prelude
 
-withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
+withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a
-withCradle cradledir f =
+withGhcModEnv = withGhcModEnv' withCradle
-    gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f
-
-withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
-withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f)
-
-withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a
-withGhcModEnv' opt f crdl = do
-    olddir <- liftIO getCurrentDirectory
-    c <- liftIO newChan
-    let outp = case linePrefix opt of
-                 Just _ -> GmOutputChan c
-                 Nothing -> GmOutputStdio
-    gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp)
  where
-   setup c = liftIO $ do
+   withCradle dir =
-     setCurrentDirectory $ cradleRootDir crdl
+       gbracket (findCradle' dir) (liftIO . cleanupCradle)
-     forkIO $ stdoutGateway c
 
-   teardown olddir tid = liftIO $ do
+withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> (Cradle -> m a) -> m a) -> FilePath -> Options -> (GhcModEnv -> m a) -> m a
-     setCurrentDirectory olddir
+withGhcModEnv' withCradle dir opts f =
-     killThread tid
+    withCradle dir $ \crdl ->
+      withCradleRootDir crdl $
+        f $ GhcModEnv opts crdl
+ where
+   withCradleRootDir (cradleRootDir -> projdir) a = do
+       cdir <- liftIO $ getCurrentDirectory
+       eq <- liftIO $ pathsEqual projdir cdir
+       if not eq
+          then throw $ GMEWrongWorkingDirectory projdir cdir
+          else a
 
-   gbracket_ ma mb mc = gbracket ma mb (const mc)
+   pathsEqual a b = do
+     ca <- canonicalizePath a
+     cb <- canonicalizePath b
+     return $ ca == cb
+
+runGmOutT :: IOish m => Options -> GmOutT m a -> m a
+runGmOutT opts ma = do
+    gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan
+    let action = runGmOutT' gmo ma
+    case ooptLinePrefix $ optOutput opts of
+      Nothing -> action
+      Just pfxs ->
+        gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan)
+                  (const $ liftIO $ flushStdoutGateway gmoChan)
+                  action
+
+runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a
+runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma
 
 -- | Run a @GhcModT m@ computation.
-runGhcModT :: IOish m
+runGhcModT :: (IOish m, GmOut m)
            => Options
            -> GhcModT m a
            -> m (Either GhcModError a, GhcModLog)
-runGhcModT opt action = do
+runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do
-    dir <- liftIO getCurrentDirectory
+    runGmOutT opt $
-    runGhcModT' dir opt action
+      withGhcModEnv dir' opt $ \env ->
-
+        first (fst <$>) <$> runGhcModT' env defaultGhcModState
-runGhcModT' :: IOish m
+          (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
-            => FilePath
-            -> 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
@@ -107,15 +112,19 @@ hoistGhcModT (r,l) = do
     Left e -> throwError e
     Right a -> return a
 
+
 -- | Run a computation inside @GhcModT@ providing the RWST environment and
 -- initial state. This is a low level function, use it only if you know what to
 -- do with 'GhcModEnv' and 'GhcModState'.
 --
 -- You should probably look at 'runGhcModT' instead.
-runGhcModT'' :: IOish m
+runGhcModT' :: IOish m
              => GhcModEnv
              -> GhcModState
              -> GhcModT m a
-             -> m (Either GhcModError (a, GhcModState), GhcModLog)
+             -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)
-runGhcModT'' r s a = do
+runGhcModT' r s a = do
-  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s
+  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s
+
+gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c
+gbracket_ ma mb mc = gbracket ma mb (const mc)

Language/Haskell/GhcMod/Monad/Types.hs

@@ -22,7 +22,9 @@
 
 module Language.Haskell.GhcMod.Monad.Types (
   -- * Monad Types
-    GhcModT(..)
+    GhcModT
+  , GmOutT(..)
+  , GmT(..)
   , GmlT(..)
   , LightGhc(..)
   , GmGhc
@@ -43,11 +45,19 @@ module Language.Haskell.GhcMod.Monad.Types (
   , GmEnv(..)
   , GmState(..)
   , GmLog(..)
+  , GmOut(..)
   , cradle
   , options
+  , outputOpts
   , withOptions
   , getCompilerMode
   , setCompilerMode
+  , getMMappedFiles
+  , setMMappedFiles
+  , addMMappedFile
+  , delMMappedFile
+  , lookupMMappedFile
+  , getMMappedFilePaths
   -- * Re-exporting convenient stuff
   , MonadIO
   , liftIO
@@ -99,6 +109,7 @@ import qualified Control.Monad.IO.Class as MTL
 import Data.Monoid (Monoid)
 #endif
 
+import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid
 import Data.IORef
@@ -106,20 +117,28 @@ import Prelude
 
 import qualified MonadUtils as GHC (MonadIO(..))
 
--- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'
+type GhcModT m = GmT (GmOutT m)
--- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that
+
--- means you can run (almost) all functions from the GHC API on top of 'GhcModT'
+newtype GmOutT m a = GmOutT {
--- transparently.
+      unGmOutT :: ReaderT GhcModOut m a
---
+    } deriving ( Functor
--- The inner monad @m@ should have instances for 'MonadIO' and
+             , Applicative
--- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@
+             , Alternative
--- monads already have 'MonadBaseControl' 'IO' instances, see the
+             , Monad
--- @monad-control@ package.
+             , MonadPlus
-newtype GhcModT m a = GhcModT {
+             , MonadTrans
-      unGhcModT :: StateT GhcModState
+             , MTL.MonadIO
-                     (ErrorT GhcModError
+#if DIFFERENT_MONADIO
-                       (JournalT GhcModLog
+             , GHC.MonadIO
-                         (ReaderT GhcModEnv m) ) ) a
+#endif
+             , GmLog
+             )
+
+newtype GmT m a = GmT {
+      unGmT :: StateT GhcModState
+                 (ErrorT GhcModError
+                   (JournalT GhcModLog
+                     (ReaderT GhcModEnv m) ) ) a
     } deriving ( Functor
                , Applicative
                , Alternative
@@ -138,7 +157,6 @@ newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }
              , Alternative
              , Monad
              , MonadPlus
-             , MonadTrans
              , MTL.MonadIO
 #if DIFFERENT_MONADIO
              , GHC.MonadIO
@@ -159,6 +177,9 @@ newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }
 #endif
              )
 
+--------------------------------------------------
+-- Miscellaneous instances
+
 #if DIFFERENT_MONADIO
 instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where
     liftIO = MTL.liftIO
@@ -184,13 +205,26 @@ instance MonadIO m => MonadIO (JournalT x m) where
     liftIO = MTL.liftIO
 instance MonadIO m => MonadIO (MaybeT m) where
     liftIO = MTL.liftIO
-instance MonadIOC m => MonadIO (GhcModT m) where
+instance MonadIOC m => MonadIO (GmOutT m) where
+    liftIO = MTL.liftIO
+instance MonadIOC m => MonadIO (GmT m) where
     liftIO = MTL.liftIO
 instance MonadIOC m => MonadIO (GmlT m) where
     liftIO = MTL.liftIO
 instance MonadIO LightGhc where
     liftIO = MTL.liftIO
 
+instance MonadTrans GmT where
+    lift = GmT . lift . lift . lift . lift
+instance MonadTrans GmlT where
+    lift = GmlT . lift . lift
+
+--------------------------------------------------
+-- Gm Classes
+
+type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m)
+
+-- GmEnv -----------------------------------------
 class Monad m => GmEnv m where
     gmeAsk :: m GhcModEnv
     gmeAsk = gmeReader id
@@ -201,18 +235,32 @@ class Monad m => GmEnv m where
     gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a
     {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}
 
-type Gm m = (GmEnv m, GmState m, GmLog m)
+instance Monad m => GmEnv (GmT m) where
+    gmeAsk = GmT ask
+    gmeReader = GmT . reader
+    gmeLocal f a = GmT $ local f (unGmT a)
 
-instance Monad m => GmEnv (GhcModT m) where
+instance GmEnv m => GmEnv (GmOutT m) where
-    gmeAsk = GhcModT ask
+    gmeAsk = lift gmeAsk
-    gmeReader = GhcModT . reader
+    gmeReader = lift . gmeReader
-    gmeLocal f a = GhcModT $ local f (unGhcModT a)
+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
 
 instance GmEnv m => GmEnv (StateT s m) where
     gmeAsk = lift gmeAsk
     gmeReader = lift . gmeReader
-    gmeLocal f (StateT a) = StateT $ \s -> gmeLocal f (a s)
+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
 
+instance GmEnv m => GmEnv (JournalT GhcModLog m) where
+    gmeAsk = lift gmeAsk
+    gmeReader = lift . gmeReader
+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
+
+instance GmEnv m => GmEnv (ErrorT GhcModError m) where
+    gmeAsk = lift gmeAsk
+    gmeReader = lift . gmeReader
+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
+
+-- GmState ---------------------------------------
 class Monad m => GmState m where
     gmsGet :: m GhcModState
     gmsGet = gmsState (\s -> (s, s))
@@ -228,21 +276,27 @@ class Monad m => GmState m where
       return a
     {-# MINIMAL gmsState | gmsGet, gmsPut #-}
 
+instance GmState m => GmState (StateT s m) where
+    gmsGet = lift gmsGet
+    gmsPut = lift . gmsPut
+    gmsState = lift . gmsState
+
 instance Monad m => GmState (StateT GhcModState m) where
     gmsGet = get
     gmsPut = put
     gmsState = state
 
-instance Monad m => GmState (GhcModT m) where
+instance Monad m => GmState (GmT m) where
-    gmsGet = GhcModT get
+    gmsGet = GmT get
-    gmsPut = GhcModT . put
+    gmsPut = GmT . put
-    gmsState = GhcModT . state
+    gmsState = GmT . state
 
 instance GmState m => GmState (MaybeT m) where
     gmsGet = MaybeT $ Just `liftM` gmsGet
     gmsPut = MaybeT . (Just `liftM`) . gmsPut
     gmsState = MaybeT . (Just `liftM`) . gmsState
 
+-- GmLog -----------------------------------------
 class Monad m => GmLog m where
     gmlJournal :: GhcModLog -> m ()
     gmlHistory :: m GhcModLog
@@ -253,10 +307,10 @@ instance Monad m => GmLog (JournalT GhcModLog m) where
     gmlHistory = history
     gmlClear   = clear
 
-instance Monad m => GmLog (GhcModT m) where
+instance Monad m => GmLog (GmT m) where
-    gmlJournal = GhcModT . lift . lift . journal
+    gmlJournal = GmT . lift . lift . journal
-    gmlHistory = GhcModT $ lift $ lift history
+    gmlHistory = GmT $ lift $ lift history
-    gmlClear   = GhcModT $ lift $ lift clear
+    gmlClear   = GmT $ lift $ lift clear
 
 instance (Monad m, GmLog m) => GmLog (ReaderT r m) where
     gmlJournal = lift . gmlJournal
@@ -268,19 +322,32 @@ instance (Monad m, GmLog m) => GmLog (StateT s m) where
     gmlHistory = lift gmlHistory
     gmlClear = lift gmlClear
 
-instance Monad m => MonadJournal GhcModLog (GhcModT m) where
+-- GmOut -----------------------------------------
-  journal !w = GhcModT $ lift $ lift $ (journal w)
+class Monad m => GmOut m where
-  history    = GhcModT $ lift $ lift $ history
+    gmoAsk :: m GhcModOut
-  clear      = GhcModT $ lift $ lift $ clear
 
-instance MonadTrans GhcModT where
+instance Monad m => GmOut (GmOutT m) where
-    lift = GhcModT . lift . lift . lift . lift
+    gmoAsk = GmOutT ask
 
-instance forall r m. MonadReader r m => MonadReader r (GhcModT m) where
+instance Monad m => GmOut (GmlT m) where
+    gmoAsk = GmlT $ lift $ GmOutT ask
+
+instance GmOut m => GmOut (GmT m) where
+    gmoAsk = lift gmoAsk
+
+instance GmOut m => GmOut (StateT s m) where
+    gmoAsk = lift gmoAsk
+
+instance Monad m => MonadJournal GhcModLog (GmT m) where
+  journal !w = GmT $ lift $ lift $ (journal w)
+  history    = GmT $ lift $ lift $ history
+  clear      = GmT $ lift $ lift $ clear
+
+instance forall r m. MonadReader r m => MonadReader r (GmT 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
+instance (Monoid w, MonadWriter w m) => MonadWriter w (GmT m) where
     tell = gmLiftInner . tell
     listen ma =
       liftWith (\run -> listen (run ma)) >>= \(sta, w) ->
@@ -288,63 +355,91 @@ instance (Monoid w, MonadWriter w m) => MonadWriter w (GhcModT m) where
 
     pass maww = maww >>= gmLiftInner . pass . return
 
-instance MonadState s m => MonadState s (GhcModT m) where
+instance MonadState s m => MonadState s (GmT m) where
-    get = GhcModT $ lift $ lift $ lift get
+    get = GmT $ lift $ lift $ lift get
-    put = GhcModT . lift . lift . lift . put
+    put = GmT . lift . lift . lift . put
-    state = GhcModT . lift . lift . lift . state
+    state = GmT . lift . lift . lift . state
 
+
+--------------------------------------------------
+-- monad-control instances
+
+-- GmOutT ----------------------------------------
+instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where
+    liftBase = GmOutT . liftBase
+
+instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where
+    type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a
+    liftBaseWith = defaultLiftBaseWith
+    restoreM = defaultRestoreM
+    {-# INLINE liftBaseWith #-}
+    {-# INLINE restoreM #-}
+
+instance MonadTransControl GmOutT where
+    type StT GmOutT a = StT (ReaderT GhcModEnv) a
+    liftWith = defaultLiftWith GmOutT unGmOutT
+    restoreT = defaultRestoreT GmOutT
+
+
+-- GmlT ------------------------------------------
 instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where
     liftBase = GmlT . liftBase
 
 instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where
-    type StM (GmlT m) a = StM (GhcModT m) a
+    type StM (GmlT m) a = StM (GmT m) a
     liftBaseWith = defaultLiftBaseWith
     restoreM = defaultRestoreM
     {-# INLINE liftBaseWith #-}
     {-# INLINE restoreM #-}
 
 instance MonadTransControl GmlT where
-    type StT GmlT a = StT GhcModT a
+    type StT GmlT a = StT GmT a
-    liftWith = defaultLiftWith GmlT unGmlT
+    liftWith f = GmlT $
-    restoreT = defaultRestoreT GmlT
+      liftWith $ \runGm ->
+        liftWith $ \runEnv ->
+          f $ \ma -> runEnv $ runGm $ unGmlT ma
+    restoreT = GmlT . restoreT . restoreT
 
-instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
-    liftBase = GhcModT . liftBase
 
-instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
+-- GmT ------------------------------------------
-    type StM (GhcModT m) a =
+
+instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where
+    liftBase = GmT . liftBase
+
+instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where
+    type StM (GmT m) a =
           StM (StateT GhcModState
                 (ErrorT GhcModError
                   (JournalT GhcModLog
                     (ReaderT GhcModEnv m) ) ) ) a
-
+    liftBaseWith f = GmT (liftBaseWith $ \runInBase ->
-    liftBaseWith f = GhcModT (liftBaseWith $ \runInBase ->
+        f $ runInBase . unGmT)
-        f $ runInBase . unGhcModT)
+    restoreM = GmT . restoreM
-
-    restoreM = GhcModT . restoreM
     {-# INLINE liftBaseWith #-}
     {-# INLINE restoreM #-}
 
-instance MonadTransControl GhcModT where
+instance MonadTransControl GmT where
-    type StT GhcModT a = (Either GhcModError (a, GhcModState), GhcModLog)
+    type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog)
-
+    liftWith f = GmT $
-    liftWith f = GhcModT $
       liftWith $ \runS ->
         liftWith $ \runE ->
           liftWith $ \runJ ->
             liftWith $ \runR ->
-              f $ \ma -> runR $ runJ $ runE $ runS $ unGhcModT ma
+              f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma
-    restoreT = GhcModT . restoreT . restoreT . restoreT . restoreT
+    restoreT = GmT . restoreT . restoreT . restoreT . restoreT
     {-# INLINE liftWith #-}
     {-# INLINE restoreT #-}
 
-gmLiftInner :: Monad m => m a -> GhcModT m a
+gmLiftInner :: Monad m => m a -> GmT m a
-gmLiftInner = GhcModT . lift . lift . lift . lift
+gmLiftInner = GmT . lift . lift . lift . lift
 
 gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))
                 => (Run t -> m (StT t a)) -> t m a
 gmLiftWithInner f = liftWith f >>= restoreT . return
 
+--------------------------------------------------
+-- GHC API instances -----------------------------
+
 -- 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
@@ -357,8 +452,6 @@ instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where
     getSession = gmlGetSession
     setSession = gmlSetSession
 
--- ---------------------------------------------------------------------
-
 gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv
 gmlGetSession = do
         ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
@@ -369,7 +462,6 @@ gmlSetSession a = do
         ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
         GHC.liftIO $ flip writeIORef a ref
 
--- ---------------------------------------------------------------------
 instance GhcMonad LightGhc where
     getSession = (GHC.liftIO . readIORef) =<< LightGhc ask
     setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask
@@ -382,7 +474,14 @@ instance HasDynFlags LightGhc where
     getDynFlags = hsc_dflags <$> getSession
 #endif
 
-instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GhcModT m) where
+instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT 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 (GmT m) where
     gcatch act handler = control $ \run ->
         run act `gcatch` (run . handler)
 
@@ -425,6 +524,9 @@ instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) wher
 options :: GmEnv m => m Options
 options = gmOptions `liftM` gmeAsk
 
+outputOpts :: GmOut m => m OutputOpts
+outputOpts = gmoOptions `liftM` gmoAsk
+
 cradle :: GmEnv m => m Cradle
 cradle = gmCradle `liftM` gmeAsk
 
@@ -434,6 +536,27 @@ getCompilerMode = gmCompilerMode `liftM` gmsGet
 setCompilerMode :: GmState m => CompilerMode -> m ()
 setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
 
+getMMappedFiles :: GmState m => m FileMappingMap
+getMMappedFiles = gmMMappedFiles `liftM` gmsGet
+
+setMMappedFiles :: GmState m => FileMappingMap -> m ()
+setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet
+
+addMMappedFile  :: GmState m => FilePath -> FileMapping -> m ()
+addMMappedFile t fm =
+  getMMappedFiles >>= setMMappedFiles . M.insert t fm
+
+delMMappedFile  :: GmState m => FilePath -> m ()
+delMMappedFile t =
+  getMMappedFiles >>= setMMappedFiles . M.delete t
+
+lookupMMappedFile  :: GmState m => FilePath -> m (Maybe FileMapping)
+lookupMMappedFile t =
+  M.lookup t `liftM` getMMappedFiles
+
+getMMappedFilePaths :: GmState m => m [FilePath]
+getMMappedFilePaths = M.keys `liftM` getMMappedFiles
+
 withOptions :: GmEnv m => (Options -> Options) -> m a -> m a
 withOptions changeOpt action = gmeLocal changeEnv action
   where

Language/Haskell/GhcMod/Output.hs

@@ -22,133 +22,169 @@ module Language.Haskell.GhcMod.Output (
   , gmErrStr
   , gmPutStrLn
   , gmErrStrLn
-  , gmUnsafePutStrLn
+
-  , gmUnsafeErrStrLn
+  , gmPutStrIO
+  , gmErrStrIO
+
   , gmReadProcess
+
   , stdoutGateway
+  , flushStdoutGateway
   ) where
 
 import Data.List
+import qualified Data.Label as L
+import qualified Data.Label.Base as LB
 import System.IO
 import System.Exit
 import System.Process
 import Control.Monad
+import Control.Monad.State.Strict
 import Control.DeepSeq
 import Control.Exception
-import Control.Concurrent
+import Control.Concurrent (forkIO, killThread)
+import Control.Concurrent.MVar
+import Control.Concurrent.Chan
+import Pipes
+import Pipes.Lift
+import Prelude
 
-import Language.Haskell.GhcMod.Types hiding (LineSeparator)
+import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..))
-import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..))
 
-withLines :: (String -> String) -> String -> String
+outputFns :: (GmOut m, MonadIO m')
-withLines f s = let
+          => m (String -> m' (), String -> m' ())
-    res = unlines $ map f $ lines s
+outputFns =
-  in
+  outputFns' `liftM` gmoAsk
-    case s of
-      [] -> res
-      _ | not $ isTerminated s ->
-            reverse $ drop 1 $ reverse res
-      _ -> res
 
-isTerminated :: String -> Bool
+outputFns' ::
-isTerminated "" = False
+  MonadIO m => GhcModOut -> (String -> m (), String -> m ())
-isTerminated s = isNewline (last s)
+outputFns' (GhcModOut oopts c)  = let
-
+  OutputOpts {..} = oopts
-isNewline :: Char -> Bool
-isNewline c = c == '\n'
-
-toGmLines :: String -> (GmLines String)
-toGmLines "" = GmLines GmPartial ""
-toGmLines s | isNewline (last s) = GmLines GmTerminated s
-toGmLines s = GmLines GmPartial s
-
-outputFns :: (GmEnv m, MonadIO m')
-          => m (GmLines String -> m' (), GmLines String -> m' ())
-outputFns = do
-  opts <- options
-  env <- gmeAsk
-  return $ outputFns' opts (gmOutput env)
-
-outputFns' :: MonadIO m'
-           => Options
-           -> GmOutput
-           -> (GmLines String -> m' (), GmLines String -> m' ())
-outputFns' opts output  = let
-  Options {..} = opts
-
-  pfx f = withLines f
-
-  outPfx, errPfx :: GmLines String -> GmLines String
-  (outPfx, errPfx) =
-      case linePrefix of
-        Nothing -> ( id, id )
-        Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
  in
-  case output of
+  case ooptLinePrefix of
-    GmOutputStdio  ->
+    Nothing -> stdioOutputFns
-        ( liftIO . putStr         . unGmLine . outPfx
+    Just _  -> chanOutputFns c
-        , liftIO . hPutStr stderr . unGmLine . errPfx)
+
-    GmOutputChan c ->
+stdioOutputFns :: MonadIO m => (String -> m (), String -> m ())
-        ( liftIO . writeChan c . (,) GmOut . outPfx
+stdioOutputFns =
-        , liftIO . writeChan c . (,) GmErr .errPfx)
+    ( liftIO . putStr
+    , liftIO . hPutStr stderr
+    )
+
+chanOutputFns :: MonadIO m
+              => Chan (Either (MVar ()) (GmStream, String))
+              -> (String -> m (), String -> m ())
+chanOutputFns c = (write GmOutStream, write GmErrStream)
+ where
+   write stream s = liftIO $ writeChan c $ Right $ (stream,s)
 
 gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
-    :: (MonadIO m, GmEnv m) => String -> m ()
+    :: (MonadIO m, GmOut m) => String -> m ()
 
 gmPutStr str = do
-  putOut <- fst `liftM` outputFns
+  putOut <- gmPutStrIO
-  putOut $ toGmLines str
+  putOut str
+
+gmErrStr str = do
+  putErr <- gmErrStrIO
+  putErr str
 
 gmPutStrLn = gmPutStr . (++"\n")
 gmErrStrLn = gmErrStr . (++"\n")
 
-gmErrStr str = do
+gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())
-  putErr <- snd `liftM` outputFns
-  putErr $ toGmLines str
 
--- | Only use these when you're sure there are no other writers on stdout
+gmPutStrIO = fst `liftM` outputFns
-gmUnsafePutStrLn, gmUnsafeErrStrLn
+gmErrStrIO = snd `liftM` outputFns
-    :: MonadIO m => Options -> String -> m ()
-gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines
-gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines
 
-gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
+
+gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)
 gmReadProcess = do
-  GhcModEnv {..} <- gmeAsk
+  GhcModOut {..} <- gmoAsk
-  case gmOutput of
+  case ooptLinePrefix gmoOptions of
-    GmOutputChan _ ->
+    Just _ ->
         readProcessStderrChan
-    GmOutputStdio ->
+    Nothing ->
         return $ readProcess
 
-stdoutGateway :: Chan (GmStream, GmLines String) -> IO ()
+flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO ()
-stdoutGateway chan = go ("", "")
+flushStdoutGateway c = do
+  mv <- newEmptyMVar
+  writeChan c $ Left mv
+  takeMVar mv
+
+type Line = String
+
+stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO ()
+stdoutGateway (outPf, errPf) chan = do
+  runEffect $ commandProc >-> evalStateP ("","") seperateStreams
  where
-   go buf@(obuf, ebuf) = do
+   commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()
-     (stream, GmLines ty l) <- readChan chan
+   commandProc = do
-     case ty of
+     cmd <- liftIO $ readChan chan
-       GmTerminated ->
+     case cmd of
-           case stream of
+       Left mv -> do
-             GmOut -> putStr (obuf++l) >> go ("", ebuf)
+           yield $ Left mv
-             GmErr -> putStr (ebuf++l) >> go (obuf, "")
+       Right input -> do
-       GmPartial -> case reverse $ lines l of
+           yield $ Right input
-                      [] -> go buf
+           commandProc
-                      [x] -> go (appendBuf stream buf x)
-                      x:xs -> do
-                        putStr $ unlines $ reverse xs
-                        go (appendBuf stream buf x)
 
-   appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf)
+   seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) ()
-   appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s)
+   seperateStreams  = do
+       ecmd <- await
+       case ecmd of
+         Left mv -> do
+           -- flush buffers
+           (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing)
+               `mapM_` [GmOutStream, GmErrStream]
 
+           liftIO $ putMVar mv ()
+         Right (stream, str) -> do
+           ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str)
+           case ls of
+               [] -> return ()
+               _  -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls
+
+           liftIO $ hFlush stdout
+           seperateStreams
+
+   sGetLine :: (Maybe String) -> StateT String IO [Line]
+   sGetLine mstr' = do
+     buf <- get
+     let mstr = (buf++) `liftM` mstr'
+     case mstr of
+       Nothing -> put "" >> return [buf]
+       Just "" -> return []
+       Just s | last s == '\n' -> put "" >> return (lines s)
+              | otherwise -> do
+                  let (p:ls') = reverse $ lines s
+                  put p
+                  return $ reverse $ ls'
+
+   streamLens GmOutStream = LB.fst
+   streamLens GmErrStream = LB.snd
+
+   streamPf GmOutStream = outPf
+   streamPf GmErrStream = errPf
+
+zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a
+zoom l (StateT a) =
+    StateT $ \f -> do
+      (a', s') <- a $ L.get l f
+      return (a', L.set l s' f)
 
 readProcessStderrChan ::
-    GmEnv m => m (FilePath -> [String] -> String -> IO String)
+    GmOut m => m (FilePath -> [String] -> String -> IO String)
 readProcessStderrChan = do
-  (_, e) <- outputFns
+  (_, e :: String -> IO ()) <- outputFns
-  return $ go e
+  return $ readProcessStderrChan' e
+
+readProcessStderrChan' ::
+    (String -> IO ()) -> FilePath -> [String] -> String -> IO String
+readProcessStderrChan' pute = go pute
  where
-   go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String
+   go :: (String -> IO ()) -> FilePath -> [String] -> String -> IO String
    go putErr exe args input = do
      let cp = (proc exe args) {
                 std_out = CreatePipe
@@ -175,13 +211,13 @@ readProcessStderrChan = do
      res <- waitForProcess h
      case res of
        ExitFailure rv ->
-           processFailedException "readProcessStderrChan" exe args rv
+           throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv
        ExitSuccess ->
            return output
     where
       ignoreSEx = handle (\(SomeException _) -> return ())
       reader h = ignoreSEx $ do
-        putErr . toGmLines . (++"\n") =<< hGetLine h
+        putErr . (++"\n") =<< hGetLine h
         reader h
 
 withForkWait :: IO () -> (IO () ->  IO a) -> IO a
@@ -191,9 +227,3 @@ withForkWait async body = do
     tid <- forkIO $ try (restore async) >>= putMVar waitVar
     let wait = takeMVar waitVar >>= either throwIO return
     restore (body wait) `onException` killThread tid
-
-processFailedException :: String -> String -> [String] -> Int -> IO a
-processFailedException fn exe args rv =
-      error $ concat [ fn, ": ", exe, " "
-                     , intercalate " " (map show args)
-                     , " (exit " ++ show rv ++ ")"]

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -20,7 +20,9 @@ module Language.Haskell.GhcMod.PathsAndFiles (
   ) where
 
 import Config (cProjectVersion)
+import Control.Arrow (second)
 import Control.Applicative
+import Control.Exception as E
 import Control.Monad
 import Data.List
 import Data.Char
@@ -32,7 +34,6 @@ import System.FilePath
 import System.Process
 
 import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Caching
 import qualified Language.Haskell.GhcMod.Utils as U
 import Utils (mightExist)
@@ -71,13 +72,18 @@ findCabalFile dir = do
    appendDir :: DirPath -> [FileName] -> [FilePath]
    appendDir d fs = (d </>) `map` fs
 
+findStackConfigFile :: FilePath -> IO (Maybe FilePath)
+findStackConfigFile dir = do
+    fs <- map (second listToMaybe) <$> findFileInParentsP  (=="stack.yaml") dir
+    case find (isJust . snd) fs of
+      Nothing           -> return Nothing
+      Just (d, Just a)  -> return $ Just $ d </> a
+      Just (_, Nothing) -> error "findStackConfigFile"
+
 -- | Get path to sandbox config file
-getSandboxDb :: FilePath
+getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)
-             -- ^ Path to the cabal package root directory (containing the
+getSandboxDb crdl = do
-             -- @cabal.sandbox.config@ file)
+  mConf <-traverse readFile =<< mightExist (sandboxConfigFile crdl)
-             -> IO (Maybe GhcPkgDb)
-getSandboxDb d = do
-  mConf <- traverse readFile =<< mightExist (d </> "cabal.sandbox.config")
   bp <- buildPlatform readProcess
   return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)
 
@@ -127,7 +133,7 @@ takeExtension' p =
 -- it's parent directories.
 findFileInParentsP :: (FilePath -> Bool) -> FilePath
                    -> IO [(DirPath, [FileName])]
-findFileInParentsP p dir =
+findFileInParentsP p dir' = U.makeAbsolute' dir' >>= \dir ->
     getFilesP p `zipMapM` parents dir
 
 -- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.
@@ -145,7 +151,7 @@ findCabalSandboxDir dir = do
              _ -> Nothing
 
  where
-   isSandboxConfig = (==sandboxConfigFile)
+   isSandboxConfig = (==sandboxConfigFileName)
 
 zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
 zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
@@ -179,17 +185,22 @@ parents dir' =
 ----------------------------------------------------------------
 
 setupConfigFile :: Cradle -> FilePath
-setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
+setupConfigFile crdl =
+    cradleRootDir crdl </> setupConfigPath (cradleDistDir crdl)
 
-sandboxConfigFile :: FilePath
+sandboxConfigFile :: Cradle -> FilePath
-sandboxConfigFile = "cabal.sandbox.config"
+sandboxConfigFile crdl = cradleRootDir crdl </> sandboxConfigFileName
+
+sandboxConfigFileName :: String
+sandboxConfigFileName = "cabal.sandbox.config"
 
 -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
-setupConfigPath :: FilePath
+setupConfigPath :: FilePath -> FilePath
-setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref
+setupConfigPath dist = dist </> "setup-config"
+ -- localBuildInfoFile defaultDistPref
 
 macrosHeaderPath :: FilePath
-macrosHeaderPath = "dist/build/autogen/cabal_macros.h"
+macrosHeaderPath = "build/autogen/cabal_macros.h"
 
 ghcSandboxPkgDbDir :: String -> String
 ghcSandboxPkgDbDir buildPlatf = do
@@ -205,20 +216,25 @@ symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
 symbolCacheFile :: String
 symbolCacheFile = "ghc-mod.symbol-cache"
 
-resolvedComponentsCacheFile :: String
+resolvedComponentsCacheFile :: FilePath -> FilePath
-resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components"
+resolvedComponentsCacheFile dist =
+    setupConfigPath dist <.> "ghc-mod.resolved-components"
 
-cabalHelperCacheFile :: String
+cabalHelperCacheFile :: FilePath -> FilePath
-cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components"
+cabalHelperCacheFile dist =
+    setupConfigPath dist <.> "ghc-mod.cabal-components"
 
-mergedPkgOptsCacheFile :: String
+mergedPkgOptsCacheFile :: FilePath -> FilePath
-mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options"
+mergedPkgOptsCacheFile dist =
+    setupConfigPath dist <.> "ghc-mod.package-options"
 
-pkgDbStackCacheFile :: String
+pkgDbStackCacheFile :: FilePath -> FilePath
-pkgDbStackCacheFile = setupConfigPath <.> "ghc-mod.package-db-stack"
+pkgDbStackCacheFile dist =
+    setupConfigPath dist <.> "ghc-mod.package-db-stack"
 
--- | @findCustomPackageDbFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.
+-- | @findCustomPackageDbFile dir@. Searches for a @ghc-mod.package-db-stack@ file in @dir@.
--- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@
+-- If it exists in the given directory it is returned otherwise @findCradleFile@
+-- returns @Nothing@
 findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)
 findCustomPackageDbFile directory = do
     let path = directory </> "ghc-mod.package-db-stack"

Language/Haskell/GhcMod/PkgDoc.hs

@@ -3,7 +3,7 @@ module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Utils
+import Language.Haskell.GhcMod.Output
 
 import Control.Applicative
 import Prelude
@@ -11,12 +11,14 @@ import Prelude
 -- | Obtaining the package name and the doc path of a module.
 pkgDoc :: IOish m => String -> GhcModT m String
 pkgDoc mdl = do
+    ghcPkg <- getGhcPkgProgram
+    readProc <- gmReadProcess
     pkgDbStack <- getPackageDbStack
-    pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) ""
+    pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) ""
     if pkg == "" then
         return "\n"
       else do
-        htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) ""
+        htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) ""
         let ret = pkg ++ " " ++ drop 14 htmlpath
         return ret
   where

Language/Haskell/GhcMod/Pretty.hs

@@ -55,11 +55,16 @@ fnDoc :: FilePath -> Doc
 fnDoc = doubleQuotes . text
 
 showDoc :: Show a => a -> Doc
-showDoc = text . show
+showDoc = strLnDoc . show
 
 warnDoc :: Doc -> Doc
 warnDoc d = text "Warning" <+>: d
 
+strLnDoc :: String -> Doc
+strLnDoc str = doc (dropWhileEnd isSpace str)
+ where
+   doc = lines >>> map text >>> foldr ($+$) empty
+
 strDoc :: String -> Doc
 strDoc str = doc (dropWhileEnd isSpace str)
  where

Language/Haskell/GhcMod/Stack.hs

@@ -0,0 +1,90 @@
+-- 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.Stack where
+
+
+import Control.Applicative
+import Control.Exception as E
+import Control.Monad
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Class
+import Data.List
+import Data.List.Split
+import Data.Maybe
+import System.Directory
+import System.FilePath
+import System.Info.Extra
+import Exception
+
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Output
+import qualified Language.Haskell.GhcMod.Utils as U
+import Prelude
+
+patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs
+patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do
+  Just ghc <- getStackGhcPath senv
+  Just ghcPkg <- getStackGhcPkgPath senv
+  return $ progs {
+      ghcProgram = ghc
+    , ghcPkgProgram = ghcPkg
+    }
+patchStackPrograms _crdl progs = return progs
+
+getStackEnv :: (IOish m, GmOut m) => FilePath -> m (Maybe StackEnv)
+getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do
+    env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"]
+    let look k = fromJust $ lookup k env
+    return StackEnv {
+        seDistDir       = look "dist-dir"
+      , seBinPath       = splitSearchPath $ look "bin-path"
+      , seSnapshotPkgDb = look "snapshot-pkg-db"
+      , seLocalPkgDb    = look "local-pkg-db"
+      }
+ where
+   liToTup [k,v] = (k,v)
+   liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'")
+   liToTup _ = error "getStackEnv"
+
+getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath)
+getStackGhcPath = findExecutablesInStackBinPath "ghc"
+
+getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath)
+getStackGhcPkgPath = findExecutablesInStackBinPath  "ghc-pkg"
+
+findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath)
+findExecutablesInStackBinPath exe StackEnv {..} =
+    liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe
+
+findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
+findExecutablesInDirectories' path binary =
+    U.findFilesWith' isExecutable path (binary <.> exeExtension)
+   where isExecutable file = do
+             perms <- getPermissions file
+             return $ executable perms
+
+         exeExtension = if isWindows then "exe" else ""
+
+readStack :: (IOish m, GmOut m) => [String] -> MaybeT m String
+readStack args = do
+  stack <- MaybeT $ liftIO $ findExecutable "stack"
+  readProc <- lift gmReadProcess
+  lift $ flip gcatch (\(e :: IOError) -> exToErr e) $ do
+    liftIO $ evaluate =<< readProc stack args ""
+ where
+   exToErr = throw . GMEStackBootstrap . GMEString . show

Language/Haskell/GhcMod/Target.hs

@@ -20,14 +20,10 @@ module Language.Haskell.GhcMod.Target where
 import Control.Arrow
 import Control.Applicative
 import Control.Category ((.))
-import Control.Monad.Reader (runReaderT)
 import GHC
 import GHC.Paths (libdir)
-import StaticFlags
 import SysTools
 import DynFlags
-import HscMain
-import HscTypes
 
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.Monad.Types
@@ -39,7 +35,10 @@ import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils as U
-
+import Language.Haskell.GhcMod.FileMapping
+import Language.Haskell.GhcMod.LightGhc
+import Language.Haskell.GhcMod.CustomPackageDb
+import Language.Haskell.GhcMod.Output
 
 import Data.Maybe
 import Data.Monoid as Monoid
@@ -53,41 +52,14 @@ import Data.Map (Map)
 import qualified Data.Map  as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Function (on)
 import Distribution.Helper
 import Prelude hiding ((.))
 
 import System.Directory
 import System.FilePath
 
-withLightHscEnv :: forall m a. IOish m
+runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a
-    => [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 =<< addCmdOpts opts =<< getSessionDynFlags
-         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, GmState m, GmLog m) => LightGhc a -> m a
 runGmPkgGhc action = do
     pkgOpts <- packageGhcOptions
     withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
@@ -97,8 +69,13 @@ initSession :: IOish m
 initSession opts mdf = do
    s <- gmsGet
    case gmGhcSession s of
-     Just GmGhcSession {..} -> when (gmgsOptions /= opts) $ putNewSession s
+     Just GmGhcSession {..} | gmgsOptions /= opts-> do
-     Nothing -> putNewSession s
+         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
+         putNewSession s
+     Just _ -> return ()
+     Nothing -> do
+         gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"
+         putNewSession s
 
  where
    putNewSession s = do
@@ -146,27 +123,33 @@ runGmlTWith :: IOish m
                  -> GhcModT m b
 runGmlTWith efnmns' mdf wrapper action = do
     crdl <- cradle
-    Options { ghcUserOptions } <- options
+    Options { optGhcUserOptions } <- options
 
     let (fns, mns) = partitionEithers efnmns'
         ccfns = map (cradleCurrentDir crdl </>) fns
-    cfns <- liftIO $ mapM canonicalizePath ccfns
+    cfns <- mapM getCanonicalFileNameSafe ccfns
     let serfnmn = Set.fromList $ map Right mns ++ map Left cfns
     opts <- targetGhcOptions crdl serfnmn
-    let opts' = opts ++ ["-O0"] ++ ghcUserOptions
+    let opts' = opts ++ ["-O0"] ++ optGhcUserOptions
 
     gmVomit
       "session-ghc-options"
       (text "Initializing GHC session with following options")
       (intercalate " " $ map (("\""++) . (++"\"")) opts')
 
-    initSession opts' $
+    GhcModLog { gmLogLevel = Just level } <- gmlHistory
-        setModeSimple >>> setEmptyLogger >>> mdf
+    putErr <- gmErrStrIO
+    let setLogger | level >= GmDebug = setDebugLogger putErr
+                  | otherwise = setEmptyLogger
 
-    let rfns = map (makeRelative $ cradleRootDir crdl) cfns
+    initSession opts' $
+        setModeSimple >>> setLogger >>> mdf
+
+    mappedStrs <- getMMappedFilePaths
+    let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns
 
     unGmlT $ wrapper $ do
-      loadTargets (map moduleNameString mns ++ rfns)
+      loadTargets opts targetStrs
       action
 
 targetGhcOptions :: forall m. IOish m
@@ -176,9 +159,10 @@ targetGhcOptions :: forall m. IOish m
 targetGhcOptions crdl sefnmn = do
     when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
 
-    case cradleProjectType crdl of
+    case cradleProject crdl of
-      CabalProject -> cabalOpts crdl
+      proj
-      _ -> sandboxOpts crdl
+          | isCabalHelperProject proj -> cabalOpts crdl
+          | otherwise -> sandboxOpts crdl
  where
    zipMap f l = l `zip` (f `map` l)
 
@@ -197,7 +181,7 @@ targetGhcOptions crdl sefnmn = do
             -- First component should be ChLibName, if no lib will take lexically first exe.
             let cns = filter (/= ChSetupHsName) $ Map.keys mcs
 
-            gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."
+            gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."
             return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs
           else do
             when noCandidates $
@@ -206,12 +190,13 @@ targetGhcOptions crdl sefnmn = do
             let cn = pickComponent candidates
             return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
 
-resolvedComponentsCache :: IOish m => Cached (GhcModT m) GhcModState
+resolvedComponentsCache :: IOish m => FilePath ->
+    Cached (GhcModT m) GhcModState
     [GmComponent 'GMCRaw (Set.Set ModulePath)]
     (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
-resolvedComponentsCache = Cached {
+resolvedComponentsCache distdir = Cached {
     cacheLens = Just (lGmcResolvedComponents . lGmCaches),
-    cacheFile  = resolvedComponentsCacheFile,
+    cacheFile = resolvedComponentsCacheFile distdir,
     cachedAction = \tcfs comps ma -> do
         Cradle {..} <- cradle
         let iifsM = invalidatingInputFiles tcfs
@@ -222,13 +207,13 @@ resolvedComponentsCache = Cached {
                 Just iifs ->
                   let
                       filterOutSetupCfg =
-                          filter (/= cradleRootDir </> setupConfigPath)
+                          filter (/= cradleRootDir </> setupConfigPath distdir)
                       changedFiles = filterOutSetupCfg iifs
                   in if null changedFiles
                        then Nothing
                        else Just $ map Left changedFiles
             setupChanged = maybe False
-                                 (elem $ cradleRootDir </> setupConfigPath)
+                                 (elem $ cradleRootDir </> setupConfigPath distdir)
                                  iifsM
         case (setupChanged, ma) of
           (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs }
@@ -245,7 +230,7 @@ resolvedComponentsCache = Cached {
               text "files changed" <+>: changedDoc
 
         mcs <- resolveGmComponents mums comps
-        return (setupConfigPath:flatten mcs , mcs)
+        return (setupConfigPath distdir : flatten mcs , mcs)
  }
 
  where
@@ -253,7 +238,8 @@ resolvedComponentsCache = Cached {
            -> [FilePath]
    flatten = Map.elems
       >>> map (gmcHomeModuleGraph >>> gmgGraph
-               >>> Map.elems
+               >>> (Map.keysSet &&& Map.elems)
+               >>> uncurry insert
                >>> map (Set.map mpPath)
                >>> Set.unions
               )
@@ -286,36 +272,37 @@ findCandidates scns = foldl1 Set.intersection scns
 pickComponent :: Set ChComponentName -> ChComponentName
 pickComponent scn = Set.findMin scn
 
-packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
+packageGhcOptions :: (Applicative m, IOish m, Gm m)
                   => m [GHCOption]
 packageGhcOptions = do
     crdl <- cradle
-    case cradleProjectType crdl of
+    case cradleProject crdl of
-      CabalProject -> getGhcMergedPkgOptions
+      proj
-      _ -> sandboxOpts crdl
+          | isCabalHelperProject proj -> getGhcMergedPkgOptions
+          | otherwise -> sandboxOpts crdl
 
 -- also works for plain projects!
-sandboxOpts :: MonadIO m => Cradle -> m [String]
+sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String]
 sandboxOpts crdl = do
-    pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl
+    mCusPkgDb <- getCustomPkgDbStack
-    let pkgOpts = ghcDbStackOpts pkgDbStack
+    pkgDbStack <- liftIO $ getSandboxPackageDbStack
+    let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb
     return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]
   where
     (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
 
-    getSandboxPackageDbStack :: FilePath
+    getSandboxPackageDbStack :: IO [GhcPkgDb]
-                      -- ^ Project Directory (where the cabal.sandbox.config
+    getSandboxPackageDbStack =
-                      -- file would be if it exists)
+        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl
-                      -> IO [GhcPkgDb]
-    getSandboxPackageDbStack cdir =
-        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
 
-resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
+resolveGmComponent :: (IOish m, Gm m)
     => Maybe [CompilationUnit] -- ^ Updated modules
     -> GmComponent 'GMCRaw (Set ModulePath)
     -> m (GmComponent 'GMCResolved (Set ModulePath))
 resolveGmComponent mums c@GmComponent {..} = do
-  withLightHscEnv ghcOpts $ \env -> do
+  distDir <- cradleDistDir <$> cradle
+  gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir
+  withLightHscEnv (ghcOpts distDir) $ \env -> do
     let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
     let mg = gmcHomeModuleGraph
     let simp = gmcEntrypoints
@@ -329,17 +316,18 @@ resolveGmComponent mums c@GmComponent {..} = do
 
     return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }
 
- where ghcOpts = concat [
+ where ghcOpts distDir = concat [
            gmcGhcSrcOpts,
            gmcGhcLangOpts,
-           [ "-optP-include", "-optP" ++ macrosHeaderPath ]
+           [ "-optP-include", "-optP" ++ distDir </> macrosHeaderPath ]
         ]
 
-resolveEntrypoint :: (IOish m, GmEnv m, GmLog m)
+resolveEntrypoint :: (IOish m, Gm m)
     => Cradle
     -> GmComponent 'GMCRaw ChEntrypoint
     -> m (GmComponent 'GMCRaw (Set ModulePath))
 resolveEntrypoint Cradle {..} c@GmComponent {..} = do
+    gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts
     withLightHscEnv gmcGhcSrcOpts $ \env -> do
       let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
       eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
@@ -367,7 +355,8 @@ resolveChEntrypoints srcDir ChSetupEntrypoint = do
 chModToMod :: ChModuleName -> ModuleName
 chModToMod (ChModuleName mn) = mkModuleName mn
 
-resolveModule :: (MonadIO m, GmEnv m, GmLog m) =>
+
+resolveModule :: (IOish m, Gm m) =>
   HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)
 resolveModule env _srcDirs (Right mn) =
     liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
@@ -377,7 +366,7 @@ resolveModule env srcDirs (Left fn') = do
       Nothing -> return Nothing
       Just fn'' -> do
           fn <-  liftIO $ canonicalizePath fn''
-          emn <-  liftIO $ fileModuleName env fn
+          emn <- fileModuleName env fn
           case emn of
               Left errs -> do
                 gmLog GmWarning ("resolveModule " ++ show fn) $
@@ -399,7 +388,7 @@ resolveModule env srcDirs (Left fn') = do
 
 type CompilationUnit = Either FilePath ModuleName
 
-resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
+resolveGmComponents :: (IOish m, Gm m)
     => Maybe [CompilationUnit]
         -- ^ Updated modules
     -> [GmComponent 'GMCRaw (Set ModulePath)]
@@ -427,12 +416,19 @@ resolveGmComponents mumns cs = do
    same f a b = (f a) == (f b)
 
 -- | Set the files as targets and load them.
-loadTargets :: IOish m => [String] -> GmlT m ()
+loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m ()
-loadTargets filesOrModules = do
+loadTargets opts targetStrs = do
-    gmLog GmDebug "loadTargets" $
+    targets' <-
-          text "Loading" <+>: fsep (map text filesOrModules)
+        withLightHscEnv opts $ \env ->
+                liftM (nubBy ((==) `on` targetId))
+                  (mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs)
+              >>= mapM relativize
+
+    let targets = map (\t -> t { targetAllowObjCode = False }) targets'
+
+    gmLog GmDebug "loadTargets" $
+          text "Loading" <+>: fsep (map (text . showTargetId) targets)
 
-    targets <- forM filesOrModules (flip guessTarget Nothing)
     setTargets targets
 
     mode <- getCompilerMode
@@ -449,7 +445,17 @@ loadTargets filesOrModules = do
             loadTargets' Intelligent
           else
             loadTargets' Simple
+
+    gmLog GmDebug "loadTargets" $ text "Loading done"
+
   where
+    relativize (Target (TargetFile filePath phase) taoc src) = do
+      crdl <- cradle
+      let tid = TargetFile relativeFilePath phase
+          relativeFilePath = makeRelative (cradleRootDir crdl) filePath
+      return $ Target tid taoc src
+    relativize tgt = return tgt
+
     loadTargets' Simple = do
         void $ load LoadAllTargets
         mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph
@@ -459,16 +465,19 @@ loadTargets filesOrModules = do
         void $ setSessionDynFlags (setModeIntelligent df)
         void $ load LoadAllTargets
 
-    resetTargets targets = do
+    resetTargets targets' = do
         setTargets []
         void $ load LoadAllTargets
-        setTargets targets
+        setTargets targets'
 
     setIntelligent = do
         newdf <- setModeIntelligent <$> getSessionDynFlags
         void $ setSessionDynFlags newdf
         setCompilerMode Intelligent
 
+    showTargetId (Target (TargetModule s) _ _) = moduleNameString s
+    showTargetId (Target (TargetFile s _) _ _) = s
+
 needsFallback :: ModuleGraph -> Bool
 needsFallback = any $ \ms ->
                 let df = ms_hspp_opts ms in
@@ -483,4 +492,4 @@ cabalResolvedComponents :: (IOish m) =>
 cabalResolvedComponents = do
     crdl@(Cradle{..}) <- cradle
     comps <- mapM (resolveEntrypoint crdl) =<< getComponents
-    cached cradleRootDir resolvedComponentsCache comps
+    cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps

Language/Haskell/GhcMod/Types.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric,
+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,
   StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
 module Language.Haskell.GhcMod.Types (
@@ -27,7 +27,8 @@ import Data.Maybe
 import Data.Typeable (Typeable)
 import Data.IORef
 import Data.Label.Derive
-import Distribution.Helper
+import Distribution.Helper hiding (Programs(..))
+import qualified Distribution.Helper as CabalHelper
 import Exception (ExceptionMonad)
 #if __GLASGOW_HASKELL__ < 708
 import qualified MonadUtils as GHC (MonadIO(..))
@@ -69,57 +70,96 @@ data OutputStyle = LispStyle  -- ^ S expression style.
 -- | The type for line separator. Historically, a Null string is used.
 newtype LineSeparator = LineSeparator String deriving (Show)
 
-data Options = Options {
+data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}
-    outputStyle   :: OutputStyle
+                  deriving Show
-  -- | Line separator string.
+
-  , lineSeparator :: LineSeparator
+type FileMappingMap = Map FilePath FileMapping
-  -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
+
-  -- @snd@ is stderr prefix.
+data ProgramSource = ProgramSourceUser | ProgramSourceStack
-  , linePrefix :: Maybe (String, String)
+
-  -- | Verbosity
+data Programs = Programs {
-  , logLevel      :: GmLogLevel
   -- | @ghc@ program name.
-  , ghcProgram    :: FilePath
+    ghcProgram    :: FilePath
   -- | @ghc-pkg@ program name.
   , ghcPkgProgram :: FilePath
   -- | @cabal@ program name.
   , cabalProgram  :: FilePath
+  -- | @stack@ program name.
+  , stackProgram   :: FilePath
+  } deriving (Show)
+
+data OutputOpts = OutputOpts {
+  -- | Verbosity
+    ooptLogLevel      :: GmLogLevel
+  , ooptStyle         :: OutputStyle
+  -- | Line separator string.
+  , ooptLineSeparator :: LineSeparator
+  -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
+  -- @snd@ is stderr prefix.
+  , ooptLinePrefix    :: Maybe (String, String)
+  } deriving (Show)
+
+data Options = Options {
+    optOutput         :: OutputOpts
+  , optPrograms       :: Programs
     -- | GHC command line options set on the @ghc-mod@ command line
-  , ghcUserOptions:: [GHCOption]
+  , optGhcUserOptions :: [GHCOption]
   -- | If 'True', 'browse' also returns operators.
-  , operators     :: Bool
+  , optOperators      :: Bool
   -- | If 'True', 'browse' also returns types.
-  , detailed      :: Bool
+  , optDetailed       :: Bool
   -- | If 'True', 'browse' will return fully qualified name
-  , qualified     :: Bool
+  , optQualified      :: Bool
-  , hlintOpts     :: [String]
+  , optHlintOpts      :: [String]
+  , optFileMappings   :: [(FilePath, Maybe FilePath)]
   } deriving (Show)
 
 -- | A default 'Options'.
 defaultOptions :: Options
 defaultOptions = Options {
-    outputStyle    = PlainStyle
+    optOutput     = OutputOpts {
-  , lineSeparator  = LineSeparator "\0"
+      ooptLogLevel       = GmWarning
-  , linePrefix     = Nothing
+    , ooptStyle          = PlainStyle
-  , logLevel       = GmWarning
+    , ooptLineSeparator  = LineSeparator "\0"
-  , ghcProgram     = "ghc"
+    , ooptLinePrefix     = Nothing
-  , ghcPkgProgram  = "ghc-pkg"
+    }
-  , cabalProgram   = "cabal"
+  , optPrograms       = Programs {
-  , ghcUserOptions = []
+      ghcProgram     = "ghc"
-  , operators      = False
+    , ghcPkgProgram  = "ghc-pkg"
-  , detailed       = False
+    , cabalProgram   = "cabal"
-  , qualified      = False
+    , stackProgram   = "stack"
-  , hlintOpts      = []
+    }
+  , optGhcUserOptions = []
+  , optOperators      = False
+  , optDetailed       = False
+  , optQualified      = False
+  , optHlintOpts      = []
+  , optFileMappings   = []
   }
 
 ----------------------------------------------------------------
 
-data ProjectType = CabalProject | SandboxProject | PlainProject
+data Project = CabalProject
-                 deriving (Eq, Show)
+             | SandboxProject
+             | PlainProject
+             | StackProject StackEnv
+               deriving (Eq, Show)
+
+isCabalHelperProject :: Project -> Bool
+isCabalHelperProject StackProject {} = True
+isCabalHelperProject CabalProject {} = True
+isCabalHelperProject _ = False
+
+data StackEnv = StackEnv {
+      seDistDir       :: FilePath
+    , seBinPath       :: [FilePath]
+    , seSnapshotPkgDb :: FilePath
+    , seLocalPkgDb    :: FilePath
+    } deriving (Eq, Show)
 
 -- | The environment where this library is used.
 data Cradle = Cradle {
-    cradleProjectType:: ProjectType
+    cradleProject    :: Project
   -- | The directory where this library is executed.
   , cradleCurrentDir :: FilePath
   -- | The project root directory.
@@ -128,28 +168,21 @@ data Cradle = Cradle {
   , cradleTempDir    :: FilePath
   -- | The file name of the found cabal file.
   , cradleCabalFile  :: Maybe FilePath
+  -- | The build info directory.
+  , cradleDistDir    :: FilePath
   } deriving (Eq, Show)
 
-
+data GmStream = GmOutStream | GmErrStream
-data GmStream = GmOut | GmErr
                 deriving (Show)
 
-data GmLineType = GmTerminated | GmPartial
-                deriving (Show)
-
-data GmLines a = GmLines GmLineType a
-              deriving (Show, Functor)
-
-unGmLine :: GmLines a -> a
-unGmLine (GmLines _ s) = s
-
-data GmOutput = GmOutputStdio
-              | GmOutputChan (Chan (GmStream, GmLines String))
-
 data GhcModEnv = GhcModEnv {
       gmOptions    :: Options
     , gmCradle     :: Cradle
-    , gmOutput     :: GmOutput
+    }
+
+data GhcModOut = GhcModOut {
+      gmoOptions :: OutputOpts
+    , gmoChan    :: Chan (Either (MVar ()) (GmStream, String))
     }
 
 data GhcModLog = GhcModLog {
@@ -182,13 +215,14 @@ data GhcModState = GhcModState {
     , gmComponents   :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
     , gmCompilerMode :: !CompilerMode
     , gmCaches       :: !GhcModCaches
+    , gmMMappedFiles :: !FileMappingMap
     }
 
 data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
 
 defaultGhcModState :: GhcModState
 defaultGhcModState =
-    GhcModState n Map.empty Simple (GhcModCaches n n n n)
+    GhcModState n Map.empty Simple (GhcModCaches n n n n) Map.empty
  where n = Nothing
 
 ----------------------------------------------------------------
@@ -335,18 +369,18 @@ data GhcModError
   | GMECabalConfigure GhcModError
   -- ^ Configuring a cabal project failed.
 
-  | GMECabalFlags GhcModError
+  | GMEStackConfigure GhcModError
-  -- ^ Retrieval of the cabal configuration flags failed.
+  -- ^ Configuring a stack project failed.
 
-  | GMECabalComponent ChComponentName
+  | GMEStackBootstrap GhcModError
-  -- ^ Cabal component could not be found
+    -- ^ Bootstrapping @stack@ environment failed (process exited with failure)
 
   | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
   -- ^ Could not find a consistent component assignment for modules
 
-  | GMEProcess String [String] (Either (String, String, Int) GhcModError)
+  | GMEProcess String String [String] (Either Int GhcModError)
   -- ^ Launching an operating system process failed. Fields in
-  -- order: command, arguments, (stdout, stderr, exitcode)
+  -- order: function, command, arguments, (stdout, stderr, exitcode)
 
   | GMENoCabalFile
   -- ^ No cabal file found.
@@ -354,8 +388,8 @@ data GhcModError
   | GMETooManyCabalFiles [FilePath]
   -- ^ Too many cabal files found.
 
-  | GMECabalStateFile GMConfigStateFileError
+  | GMEWrongWorkingDirectory FilePath FilePath
-    -- ^ Reading Cabal's state configuration file falied somehow.
+
     deriving (Eq,Show,Typeable)
 
 instance Error GhcModError where
@@ -364,22 +398,16 @@ instance Error GhcModError where
 
 instance Exception GhcModError
 
-data GMConfigStateFileError
-  = GMConfigStateFileNoHeader
-  | GMConfigStateFileBadHeader
-  | GMConfigStateFileNoParse
-  | GMConfigStateFileMissing
---  | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
-  deriving (Eq, Show, Read, Typeable)
-
-
 deriving instance Generic Version
 instance Serialize Version
 
-instance Serialize Programs
+instance Serialize CabalHelper.Programs
 instance Serialize ChModuleName
 instance Serialize ChComponentName
 instance Serialize ChEntrypoint
 
 mkLabel ''GhcModCaches
 mkLabel ''GhcModState
+mkLabel ''Options
+mkLabel ''OutputOpts
+mkLabel ''Programs

Language/Haskell/GhcMod/Utils.hs

@@ -25,14 +25,17 @@ module Language.Haskell.GhcMod.Utils (
 
 import Control.Applicative
 import Data.Char
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Either (rights)
+import Data.List (inits)
 import Exception
 import Language.Haskell.GhcMod.Error
+import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Monad.Types
-import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
+import System.Directory
-                         getTemporaryDirectory, canonicalizePath)
 import System.Environment
-import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
+import System.FilePath
-                        (</>))
 import System.IO.Temp (createTempDirectory)
 import System.Process (readProcess)
 import Text.Printf
@@ -157,3 +160,61 @@ canonFilePath f = do
   e <- doesFileExist p
   when (not e) $ error $ "canonFilePath: not a file: " ++ p
   return p
+
+withMappedFile :: (IOish m, GmState m, GmEnv m) =>
+                  forall a. FilePath -> (FilePath -> m a) -> m a
+withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile
+  where
+    runWithFile (Just to) = action $ fmPath to
+    runWithFile _ = action file
+
+getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath
+getCanonicalFileNameSafe fn = do
+  let fn' = normalise fn
+  pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn')
+  return $
+    if (length pl > 0)
+    then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn'))
+    else error "Current dir doesn't seem to exist?"
+  where
+#if __GLASGOW_HASKELL__ < 710
+    splitPath' = (".":) . splitPath
+#else
+    splitPath' = splitPath
+#endif
+
+mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)
+mkRevRedirMapFunc = do
+  rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles
+  crdl <- cradle
+  return $ \key ->
+    fromMaybe key
+    $ makeRelative (cradleRootDir crdl)
+    <$> M.lookup key rm
+  where
+    mf :: FilePath -> FileMapping -> (FilePath, FilePath)
+    mf from to = (fmPath to, from)
+
+findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]
+findFilesWith' _ [] _ = return []
+findFilesWith' f (d:ds) fileName = do
+    let file = d </> fileName
+    exist <- doesFileExist file
+    b <- if exist then f file else return False
+    if b then do
+               files <- findFilesWith' f ds fileName
+               return $ file : files
+        else findFilesWith' f ds fileName
+
+
+-- Copyright   :  (c) The University of Glasgow 2001
+-- | Make a path absolute by prepending the current directory (if it isn't
+-- already absolute) and applying 'normalise' to the result.
+--
+-- If the path is already absolute, the operation never fails.  Otherwise, the
+-- operation may fail with the same exceptions as 'getCurrentDirectory'.
+makeAbsolute' :: FilePath -> IO FilePath
+makeAbsolute' = (normalise <$>) . absolutize
+  where absolutize path -- avoid the call to `getCurrentDirectory` if we can
+          | isRelative path = (</> path) <$> getCurrentDirectory
+          | otherwise       = return path

Language/Haskell/GhcMod/World.hs

@@ -18,6 +18,7 @@ data World = World {
     worldPackageCaches :: [TimedFile]
   , worldCabalFile     :: Maybe TimedFile
   , worldCabalConfig   :: Maybe TimedFile
+  , worldCabalSandboxConfig :: Maybe TimedFile
   , worldSymbolCache   :: Maybe TimedFile
   } deriving (Eq, Show)
 
@@ -33,12 +34,14 @@ getCurrentWorld = do
     pkgCaches    <- timedPackageCaches
     mCabalFile   <- liftIO $ timeFile `traverse` cradleCabalFile crdl
     mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
+    mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
     mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
 
     return World {
         worldPackageCaches = pkgCaches
       , worldCabalFile     = mCabalFile
       , worldCabalConfig   = mCabalConfig
+      , worldCabalSandboxConfig = mCabalSandboxConfig
       , worldSymbolCache   = mSymbolCache
       }
 

README.md

@@ -28,11 +28,12 @@ package is called `ghc` there, not `ghc-mod`) and install the
 
 ### Nix & NixOS
 
-The installation is a little more involved in this environment as Nix needs some
+`ghc-mod` works fine for users of Nix who follow a recent version of the
-ugly hacks to get packages using the GHC API to work, please refer to this
+package database such as the `nixos-15.09` or `nixos-unstable` channel. Just
-stackoverflow answer:
+include the package `ghc-mod` into your `ghcWithPackages` environment like any
-
+other library. The [Nixpkgs Haskell User's
-http://stackoverflow.com/a/24228830
+Guide](http://hydra.nixos.org/job/nixpkgs/trunk/manual/latest/download-by-type/doc/manual#users-guide-to-the-haskell-infrastructure)
+covers this subject in gret detail.
 
 ## Using the development version
 
@@ -46,7 +47,7 @@ all sorts of nasty conflicts.
 
 ## Custom ghc-mod cradle
 
-To customize the package databases used by `ghc-mod`, put a file called `ghc-mod.cradle` beside the `.cabal` file with the following syntax:
+To customize the package databases used by `ghc-mod`, put a file called `ghc-mod.package-db-stack` beside the `.cabal` file with the following syntax:
 
 ```
 temp directory root

doc/presentation/SIL Open Font License.txt

@@ -0,0 +1,44 @@
+Copyright (c) 2011, Vernon Adams (vern@newtypography.co.uk),
+with Reserved Font Names "Rokkitt".
+
+This Font Software is licensed under the SIL Open Font License, Version 1.1.
+This license is copied below, and is also available with a FAQ at: http://scripts.sil.org/OFL
+
+-----------------------------------------------------------
+SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
+-----------------------------------------------------------
+
+PREAMBLE
+The goals of the Open Font License (OFL) are to stimulate worldwide development of collaborative font projects, to support the font creation efforts of academic and linguistic communities, and to provide a free and open framework in which fonts may be shared and improved in partnership with others.
+
+The OFL allows the licensed fonts to be used, studied, modified and redistributed freely as long as they are not sold by themselves. The fonts, including any derivative works, can be bundled, embedded, redistributed and/or sold with any software provided that any reserved names are not used by derivative works. The fonts and derivatives, however, cannot be released under any other type of license. The requirement for fonts to remain under this license does not apply to any document created using the fonts or their derivatives.
+
+DEFINITIONS
+"Font Software" refers to the set of files released by the Copyright Holder(s) under this license and clearly marked as such. This may include source files, build scripts and documentation.
+
+"Reserved Font Name" refers to any names specified as such after the copyright statement(s).
+
+"Original Version" refers to the collection of Font Software components as distributed by the Copyright Holder(s).
+
+"Modified Version" refers to any derivative made by adding to, deleting, or substituting -- in part or in whole -- any of the components of the Original Version, by changing formats or by porting the Font Software to a new environment.
+
+"Author" refers to any designer, engineer, programmer, technical writer or other person who contributed to the Font Software.
+
+PERMISSION & CONDITIONS
+Permission is hereby granted, free of charge, to any person obtaining a copy of the Font Software, to use, study, copy, merge, embed, modify, redistribute, and sell modified and unmodified copies of the Font Software, subject to the following conditions:
+
+1) Neither the Font Software nor any of its individual components, in Original or Modified Versions, may be sold by itself.
+
+2) Original or Modified Versions of the Font Software may be bundled, redistributed and/or sold with any software, provided that each copy contains the above copyright notice and this license. These can be included either as stand-alone text files, human-readable headers or in the appropriate machine-readable metadata fields within text or binary files as long as those fields can be easily viewed by the user.
+
+3) No Modified Version of the Font Software may use the Reserved Font Name(s) unless explicit written permission is granted by the corresponding Copyright Holder. This restriction only applies to the primary font name as presented to the users.
+
+4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font Software shall not be used to promote, endorse or advertise any Modified Version, except to acknowledge the contribution(s) of the Copyright Holder(s) and the Author(s) or with their explicit written permission.
+
+5) The Font Software, modified or unmodified, in part or in whole, must be distributed entirely under this license, and must not be distributed under any other license. The requirement for fonts to remain under this license does not apply to any document created using the Font Software.
+
+TERMINATION
+This license becomes null and void if any of the above conditions are not met.
+
+DISCLAIMER
+THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE.

doc/presentation/architecture.tex

@@ -0,0 +1,44 @@
+\documentclass{article}
+\usepackage{polyglossia}
+\usepackage{xcolor}
+\usepackage{fontspec}
+\usepackage{tikz}
+
+\begin{document}
+
+  % \begin{tikzpicture}
+  %   \draw (-1,0) -- (1,0);
+  %   \draw (0,-1) -- (0,1);
+
+  %   \draw (-0.5,-0.5) rectangle (-1,-1);
+  % \end{tikzpicture}.
+
+  \begin{tikzpicture}[every node/.style={draw}]
+    \matrix [draw=red,column sep=1cm]
+    {
+      \node {8}; & \node{1}; & \node {6}; \\
+      \node {3}; & \node{5}; & \node {7}; \\
+      \node {4}; & \node{9}; & \node {2}; \\
+    };
+  \end{tikzpicture}
+
+  \begin{tikzpicture}
+    \matrix[draw=black,nodes=draw,column sep=1mm] at (0, 0) {
+      \node {check}; &
+      \node {type}; &
+      \node {browse}; &
+      \node {find}; &
+      \node {refine}; \\
+    };
+
+    \matrix[draw=black,nodes=draw,column sep=1mm] at (0, 0) {
+      \node {check}; &
+      \node {type}; &
+      \node {browse}; &
+      \node {find}; &
+      \node {refine}; \\
+    };
+  \end{tikzpicture}
+
+
+\end{document}

doc/presentation/auto/main.el

@@ -0,0 +1,14 @@
+(TeX-add-style-hook
+ "main"
+ (lambda ()
+   (TeX-run-style-hooks
+    "latex2e"
+    "beamer"
+    "beamer10"
+    "polyglossia"
+    "xcolor"
+    "fontspec")
+   (TeX-add-symbols
+    "gm"
+    "gms")))
+

doc/presentation/main.tex

@@ -0,0 +1,204 @@
+\documentclass{beamer}
+
+\usepackage{polyglossia}
+\usepackage{xcolor}
+\usepackage{fontspec}
+
+\newfontfamily\Rokkitt{Rokkitt.otf}
+
+\newcommand\gm{{\Rokkitt ghc-mod}\ }
+\newcommand\gms{{\Rokkitt ghc-mod's}\ }
+
+\mode<presentation>
+{
+  \usetheme{Rochester}
+  \usecolortheme{default}
+}
+
+\definecolor{beamer@blendedblue}{HTML}{545488}
+\definecolor{gmgrey}{HTML}{F3F3FF}
+
+\setbeamercolor{normal text}{fg=black,bg=white}
+\setbeamercolor{alerted text}{fg=red}
+\setbeamercolor{example text}{fg=green!50!black}
+
+\setbeamercolor{structure}{fg=beamer@blendedblue}
+
+\setbeamercolor{background canvas}{parent=normal text}
+\setbeamercolor{background}{parent=background canvas}
+
+\setbeamercolor{palette primary}{fg=gmgrey,bg=beamer@blendedblue} % changed this
+\setbeamercolor{palette secondary}{use=structure,fg=structure.fg!100!green} % changed this
+\setbeamercolor{palette tertiary}{use=structure,fg=structure.fg!100!green} % changed this
+
+\title{\gm}
+\subtitle{Making Haskell development even more fun}
+
+\author{\includegraphics{logo} \\ \bigskip Daniel Gr\"ober \and Kazu Yamamoto \vspace{-1em} }
+
+\pgfdeclareimage[height=0.5cm]{logo}{logo}
+\logo{\pgfuseimage{logo}}
+
+% Delete this, if you do not want the table of contents to pop up at
+% the beginning of each subsection:
+\AtBeginSubsection[]
+{
+  \begin{frame}<beamer>{Outline}
+    \tableofcontents[currentsection,currentsubsection]
+  \end{frame}
+}
+
+\begin{document}
+
+\begin{frame}
+  \titlepage
+\end{frame}
+
+\begin{frame}{Outline}
+  \tableofcontents
+\end{frame}
+
+\section{Motivation}
+
+\subsection{What is it?}
+
+\begin{frame}{What is \gm?}
+  First some marketing blurb:
+
+  \begin{block}{}
+    \gm is a backend program for enhancing editors and other kinds of
+    development environments with support for Haskell, a library for abstracting
+    the black magic incantations required to use the API of the most popular
+    Haskell compiler in various build environments and an Emacs Lisp frontend
+    program to let users access it's features.
+  \end{block}
+\end{frame}
+
+\begin{frame}{What does it do?}
+  \begin{itemize}
+    \item \texttt{check} modules for compilation errors and warnings,
+    \item get the inferred \texttt{type} of an expression in a module,
+    \item \texttt{list} modules, compiler and \texttt{lang}uage \texttt{flag}s,
+    \item \texttt{browse} symbols defined in modules,
+    \item \texttt{find} which module a symbol was defined in,
+    \item lookup \texttt{doc}umentation for a symbol or module
+    \item and a bunch of more obscure things.
+  \end{itemize}
+\end{frame}
+
+\subsection{Why work on it?}
+
+\begin{frame}{Why?}
+  \begin{itemize}
+  \item It's actually rather popular: \vspace{1em}
+
+  \item GitHub
+    \includegraphics[width=\textwidth]{gh-stars}
+
+  \item Hackage (Haskell package repository)
+    \includegraphics[width=\textwidth]{hackage-dls}
+
+  \item Also working with compilers is fun, right?
+  \end{itemize}
+\end{frame}
+
+
+\section{Implementation details}
+
+\subsection{Current architecture}
+\begin{frame}{Current architecture}
+  \includegraphics[width=\textwidth]{current-architecture}
+\end{frame}
+
+\begin{frame}{\gm the Elisp program}
+  \begin{itemize}
+  \item Extends haskell-mode to allow access to \gms features
+  \item There really isn't much more to it than that
+  \end{itemize}
+\end{frame}
+
+\begin{frame}{\gm the program}
+  \begin{itemize}
+  \item Development environment communicates with \gm process
+  \item Exists as a one-shot and long running process version
+  \begin{itemize}
+    \item \gm simple, doesn't have to worry about caching
+    \item \gm ``interactive'' much more complex, needs to be very aware of
+      changing environment and how that affects compiler internal caches
+  \end{itemize}
+  \item interactive \gm is generally much faster than \gm at least for features
+      that require compilation though
+  \end{itemize}
+\end{frame}
+
+\begin{frame}{\gm the library}
+  \begin{itemize}
+  \item \gm frontend programs use the library to implement all functionality
+  \item Frontends are very thin wrappers around the library, all the
+    intelligence is in there
+  \item Primary entry point abstracts away environment setup and just gives the
+    underlying tool a compiler session to work with
+  \item Right now it's only of limited use for implementing new \gm like tools
+    on top of it and definitely needs a redesign (for v6.0 probably)
+  \item Alan Zimmerman's Haskell Refactorer (HaRe) uses it for example
+  \end{itemize}
+\end{frame}
+
+\begin{frame}{Problems}
+  \begin{itemize}
+  \item Extending \gm from the outside is hard to impossible
+  \item External tools end up depending on ghc-mod making it difficult for us to
+    make use of them
+  \item This all just leads to fragmentation in the already fragmented Haskell
+    Tooling Landscape
+  \item one tool, \texttt{mote}, just ended up copy-pasting part of \gms
+    environment support code straight into it's codebase \texttt{-.-}
+  \item development environments essentially need to support every tooling
+    project themselves
+  \end{itemize}
+\end{frame}
+
+\subsection{Redesigned architecture}
+\begin{frame}{Redesigned architecture}
+  \includegraphics[width=\textwidth]{planned-architecture}
+\end{frame}
+
+\begin{frame}{Redesigned architecture}
+  \begin{itemize}
+  \item Factor out commands from library into a seperate package
+  \item Refine the library so any tool can actually make use of it
+  \item Design a communication library towards the development environment which
+    provides some common ground for tools and frontend developers
+  \end{itemize}
+\end{frame}
+
+\section{The internship}
+
+\subsection{What we have done so far}
+
+\begin{frame}{Bitrot}
+  \begin{itemize}
+  \item Cabal version 1.22 completely broke \gms hack'y way of getting
+    information about the build system state
+  \item To fix this (recurring) problem once and for all we had to completely
+    re-design how we access Cabal's internal state
+  \item Next GHC version 7.10 came along and also broke \gm
+  \item Adding support for the new compiler version was easy
+  \item Cabal-1.22 support was however still blocking the release
+  \end{itemize}
+\end{frame}
+
+\subsection{What is still to be done}
+
+\begin{frame}{TODO}
+  \begin{itemize}
+  \item Essentially implement all of the architectural changes
+  \item Support for implementing REPLs on top of ghc-mod
+  \item Speed up \gm program by adding network RPC support
+  \end{itemize}
+\end{frame}
+
+\begin{frame}{Questions?}
+\end{frame}
+
+\end{document}

elisp/Makefile

@@ -1,17 +1,17 @@
 SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el \
        ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-rewrite.el
 EMACS = emacs
-DETECT = xemacs
 
 TEMPFILE  = temp.el
+TEMPFILE2 = temp2.el
 
 all: $(TEMPFILE) ghc.el
 	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile
 	rm -f $(TEMPFILE)
 
-detect: $(TEMPFILE) ghc.el
+lint: $(TEMPFILE2) ghc.el
-	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile
+	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE2) -f ghc-compile
-	rm -f $(DETECT)
+	rm -f $(TEMPFILE2)
 
 $(TEMPFILE):
 	@echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE)
@@ -19,8 +19,15 @@ $(TEMPFILE):
 	@echo $(SRCS)| sed -e 's/\(ghc[^ ]*\.el\)/"\1"/g' >> $(TEMPFILE)
 	@echo ')))' >> $(TEMPFILE)
 
+$(TEMPFILE2):
+	@echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE2)
+	@echo '(setq hack-local-variables-hook (lambda () (setq lexical-binding t)))' >> $(TEMPFILE2)
+	@echo '(defun ghc-compile () (mapcar (lambda (x) (byte-compile-file x)) (list ' >> $(TEMPFILE2)
+	@echo $(SRCS)| sed -e 's/\(ghc[^ ]*\.el\)/"\1"/g' >> $(TEMPFILE2)
+	@echo ')))' >> $(TEMPFILE2)
+
 clean:
-	rm -f *.elc $(TEMPFILE)
+	rm -f *.elc $(TEMPFILE) $(TEMPFILE2)
 
 VERSION = `grep version ghc.el | sed -e 's/[^0-9\.]//g'`
 

elisp/ghc-check.el

@@ -66,14 +66,10 @@ nil            do not display errors/warnings.
   (interactive)
   ;; Only check syntax of visible buffers
   (when (and (buffer-file-name)
-	     (file-exists-p (buffer-file-name))
+	     (file-exists-p (buffer-file-name)))
-	     (get-buffer-window (current-buffer) t))
-    (with-timeout
-        (10 (error "ghc process may have hung or exited with an error"))
-      (while ghc-process-running (sleep-for 0.1)))
     (ghc-with-process (ghc-check-send)
-                      'ghc-check-callback
+		      'ghc-check-callback
-                      (lambda () (setq mode-line-process " -:-")))))
+		      (lambda () (setq mode-line-process " -:-")))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -136,7 +132,7 @@ nil            do not display errors/warnings.
 (defun ghc-to-info (errs)
   ;; [^\t] to include \n.
   (let ((regex "^\\([^\n]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\([^\t]+\\)")
-	info infos)
+	infos)
     (dolist (err errs (nreverse infos))
       (when (string-match regex err)
 	(let* ((file (expand-file-name (match-string 1 err) ghc-process-root)) ;; for Windows
@@ -174,7 +170,7 @@ nil            do not display errors/warnings.
 	  ;; If this is a bottleneck for a large code, let's fix.
 	  (goto-char (point-min))
 	  (cond
-	   ((string= (file-truename ofile) (file-truename file))
+	   ((file-equal-p ofile file)
             (if hole
               (progn
                 (forward-line (1- line))
@@ -186,7 +182,8 @@ nil            do not display errors/warnings.
                 (forward-line (1- line))
                 (forward-char (1- coln))
                 (setq beg (point))
-                (skip-chars-forward "^[:space:]" (line-end-position))
+		(forward-sexp)
+                ;; (skip-chars-forward "^[:space:]" (line-end-position))
                 (setq end (point)))))
 	   (t
 	    (setq beg (point))
@@ -294,14 +291,13 @@ nil            do not display errors/warnings.
   (let ((file-msgs (ghc-get-only-holes)))
     (if (null file-msgs)
 	(message "No holes")
-      (let ((file (ghc-file-msgs-get-file file-msgs))
+      (let ((msgs (ghc-file-msgs-get-msgs file-msgs)))
-	    (msgs (ghc-file-msgs-get-msgs file-msgs)))
 	(ghc-display
 	 nil
 	 (lambda ()
            (progn
 	     (mapc (lambda (x) (insert x "\n\n")) msgs)
-             (buttonize-buffer)) ))))))
+             (buttonize-buffer))))))))
 
 (defun ghc-display-holes-to-minibuf ()
   (let ((file-msgs (ghc-get-only-holes)))
@@ -419,6 +415,10 @@ nil            do not display errors/warnings.
 	  (let ((old (match-string 1 data))
 		(new (match-string 2 data)))
 	    (ghc-check-replace old new)))
+	 ((string-match "Found hole .\\(_[_[:alnum:]]*\\). with type: \\([^\t\n]+\\)" data)
+	  (let ((old (match-string 1 data))
+		(new (match-string 2 data)))
+	    (ghc-check-replace old new)))
 	 (t
 	  (setq ret nil)))))))
 
@@ -474,7 +474,7 @@ nil            do not display errors/warnings.
 	(forward-line)
 	(re-search-forward "^$" nil t)
 	(insert fn)
-	(dotimes (i arity)
+	(dotimes (_i arity)
 	  (insert " _"))
 	(insert  " = error \"" fn "\"\n")))))
 

elisp/ghc-command.el

@@ -53,7 +53,7 @@
       (let ((inhibit-field-text-motion t))
         (sort-subr nil 'forward-line 'end-of-line
 		   (lambda ()
-		     (re-search-forward "^import\\( *qualified\\)? *" nil t)
+		     (re-search-forward "^import +\\(qualified\\)? *" nil t)
 		     nil)
 		   'end-of-line))
       (ghc-merge-lines))))
@@ -64,7 +64,7 @@
     (while (not (eolp))
       ;; qualified modlues are not merged at this moment.
       ;; fixme if it is improper.
-      (if (looking-at "^import *\\([A-Z][^ \n]+\\) *(\\(.*\\))$")
+      (if (looking-at "^import +\\([A-Z][^ \n]+\\) *(\\(.*\\))$")
 	  (let ((mod (match-string-no-properties 1))
 		(syms (match-string-no-properties 2))
 		(beg (point)))
@@ -73,7 +73,7 @@
 	(forward-line)))))
 
 (defun ghc-merge-line (beg mod syms)
-  (let ((regex (concat "^import *" (regexp-quote mod) " *(\\(.*\\))$"))
+  (let ((regex (concat "^import +" (regexp-quote mod) " *(\\(.*\\))$"))
 	duplicated)
     (while (looking-at regex)
       (setq duplicated t)

elisp/ghc-comp.el

@@ -101,7 +101,7 @@ unloaded modules are loaded")
 (defun ghc-boot (n)
   (prog2
       (message "Initializing...")
-      (ghc-sync-process "boot\n" n)
+      (ghc-sync-process "boot\n" n nil 'skip-map-file)
     (message "Initializing...done")))
 
 (defun ghc-load-modules (mods)
@@ -265,7 +265,7 @@ unloaded modules are loaded")
   (let (ret)
     (save-excursion
       (goto-char (point-min))
-      (while (re-search-forward "^import\\( *qualified\\)? +\\([^\n ]+\\)" nil t)
+      (while (re-search-forward "^import +\\(qualified\\)? *\\([^\n ]+\\)" nil t)
 	(ghc-add ret (match-string-no-properties 2))
 	(forward-line)))
     ret))

elisp/ghc-doc.el

@@ -10,6 +10,17 @@
 (require 'ghc-comp)
 (require 'ghc-info)
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Customize Variables
+;;;
+
+(defcustom ghc-doc-browser-function #'browse-url
+  "Function used to browse documentation."
+  :type '(radio (function-item browse-url)
+                (function-item ghc-browse-url-safari))
+  :group 'ghc-mod)
+
 ;;; Code:
 
 (defun ghc-browse-document (&optional haskell-org)
@@ -30,32 +41,41 @@
 (ghc-defstruct pkg-ver-path pkg ver path)
 
 (defun ghc-resolve-document-path (mod)
-  (with-temp-buffer
+  (let ((root ghc-process-root))
-    (ghc-call-process ghc-module-command nil t nil "doc" mod)
+    (with-temp-buffer
-    (goto-char (point-min))
+      (let ((default-directory root))
-    (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")
+	(ghc-call-process ghc-module-command nil t nil "doc" mod))
-      (ghc-make-pkg-ver-path
+      (goto-char (point-min))
-       :pkg (match-string-no-properties 1)
+      (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")
-       :ver (match-string-no-properties 2)
+	(ghc-make-pkg-ver-path
-       :path (match-string-no-properties 4)))))
+	 :pkg (match-string-no-properties 1)
+	 :ver (match-string-no-properties 2)
+	 :path (match-string-no-properties 4))))))
 
 (defconst ghc-doc-local-format "file://%s/%s.html")
 (defconst ghc-doc-hackage-format
   "http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html")
 
+(defun ghc-browse-url-safari (uri &rest _args)
+"Open a URI in Safari using AppleScript. This preserves anchors."
+  (let ((script (format "
+tell application \"Safari\"
+  open location \"%s\"
+  activate
+end tell" uri)))
+    (do-applescript script)))
+
 (defun ghc-display-document (pkg-ver-path mod haskell-org &optional symbol)
-  (let* ((mod- (ghc-replace-character mod ?. ?-))
+  (let* ((pkg  (ghc-pkg-ver-path-get-pkg pkg-ver-path))
-	 (pkg  (ghc-pkg-ver-path-get-pkg pkg-ver-path))
+         (mod- (ghc-replace-character mod ?. ?-))
 	 (ver  (ghc-pkg-ver-path-get-ver pkg-ver-path))
 	 (path (ghc-pkg-ver-path-get-path pkg-ver-path))
-	 (pkg-with-ver (format "%s-%s" pkg ver))
 	 (local (format ghc-doc-local-format path mod-))
 	 (remote (format ghc-doc-hackage-format pkg ver mod-))
 	 (file (format "%s/%s.html" path mod-))
 	 (url0 (if (or haskell-org (not (file-exists-p file))) remote local))
 	 (url (if symbol (ghc-add-anchor url0 symbol) url0)))
-    ;; Mac's "open" removes the anchor from "file://", sigh.
+    (funcall ghc-doc-browser-function url)))
-    (browse-url url)))
 
 (defun ghc-add-anchor (url symbol)
   (let ((case-fold-search nil))

elisp/ghc-func.el

@@ -18,9 +18,10 @@
 (defun ghc-replace-character (string from to)
   "Replace characters equal to FROM to TO in STRING."
   (let ((ret (copy-sequence string)))
-    (dotimes (cnt (length ret) ret)
+    (dotimes (cnt (length ret))
       (if (char-equal (aref ret cnt) from)
-	  (aset ret cnt to)))))
+	  (aset ret cnt to)))
+    ret))
 
 (defun ghc-replace-character-buffer (from-c to-c)
   (let ((from (char-to-string from-c))
@@ -66,7 +67,7 @@
     (dolist (lst lol)
       (dolist (key lst)
 	(puthash key key hash)))
-    (maphash (lambda (key val) (ghc-add ret key)) hash)
+    (maphash (lambda (key _val) (ghc-add ret key)) hash)
     ret))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -90,8 +91,9 @@
     (condition-case nil
 	(let ((m (set-marker (make-marker) 1 (current-buffer)))
 	      ret)
-	  (dotimes (i n (nreverse ret))
+	  (dotimes (_i n)
-	    (ghc-add ret (read m))))
+	    (ghc-add ret (read m)))
+	  (nreverse ret))
       (error ()))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -108,10 +110,11 @@
 
 (defun ghc-keyword-number-pair (spec)
   (let ((len (length spec)) key ret)
-    (dotimes (i len (nreverse ret))
+    (dotimes (i len)
       (setq key (intern (concat ":" (symbol-name (car spec)))))
       (setq ret (cons (cons key i) ret))
-      (setq spec (cdr spec)))))
+      (setq spec (cdr spec)))
+    (nreverse ret)))
 
 (defmacro ghc-defstruct (type &rest spec)
   `(progn
@@ -204,12 +207,13 @@
 (defun ghc-run-ghc-mod (cmds &optional prog)
   (let ((target (or prog ghc-module-command)))
     (ghc-executable-find target
-      (let ((cdir default-directory))
+      (let ((cdir (or ghc-process-root  ;; ghc-mod version/debug
+		      default-directory))) ;; ghc-mod root
 	(with-temp-buffer
-	  (cd cdir)
+	  (let ((default-directory cdir))
-	  (apply 'ghc-call-process target nil t nil
+	    (apply 'ghc-call-process target nil t nil
-		 (append (ghc-make-ghc-options) cmds))
+		   (append (ghc-make-ghc-options) cmds))
-	  (buffer-substring (point-min) (1- (point-max))))))))
+	    (buffer-substring (point-min) (1- (point-max)))))))))
 
 (defmacro ghc-executable-find (cmd &rest body)
   ;; (declare (indent 1))

elisp/ghc-indent.el

@@ -10,11 +10,11 @@
 
 (defvar ghc-indent-offset 4)
 
-(defun ghc-make-indent-shallower (beg end)
+(defun ghc-make-indent-shallower (_beg _end)
   (interactive "r")
   (indent-rigidly (region-beginning) (region-end) (- ghc-indent-offset)))
 
-(defun ghc-make-indent-deeper (beg end)
+(defun ghc-make-indent-deeper (_beg _end)
   (interactive "r")
   (indent-rigidly (region-beginning) (region-end) ghc-indent-offset))
 

elisp/ghc-info.el

@@ -63,7 +63,7 @@
 	(cons 'ghc-type-clear-overlay after-change-functions))
   (add-hook 'post-command-hook 'ghc-type-post-command-hook))
 
-(defun ghc-type-clear-overlay (&optional beg end len)
+(defun ghc-type-clear-overlay (&optional _beg _end _len)
   (when (overlayp ghc-type-overlay)
     (ghc-type-set-ix 0)
     (ghc-type-set-point 0)

elisp/ghc-ins-mod.el

@@ -56,7 +56,7 @@
 
 (defun ghc-goto-module-position ()
   (goto-char (point-max))
-  (if (re-search-backward "^import" nil t)
+  (if (re-search-backward "^import +" nil t)
       (ghc-goto-empty-line)
     (if (not (re-search-backward "^module" nil t))
 	(goto-char (point-min))

elisp/ghc-process.el

@@ -16,6 +16,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defvar ghc-process-running nil)
+(defvar ghc-process-file-mapping nil)
 
 (defvar-local ghc-process-process-name nil)
 (defvar-local ghc-process-original-buffer nil)
@@ -33,49 +34,77 @@
 (defun ghc-get-project-root ()
   (ghc-run-ghc-mod '("root")))
 
-(defun ghc-with-process (cmd callback &optional hook1 hook2)
+(defun ghc-with-process (cmd callback &optional hook1 hook2 skip-map-file)
-  (let ((root (ghc-get-project-root)))
+  (unless ghc-process-process-name
-    (unless ghc-process-process-name
+    (setq ghc-process-process-name (ghc-get-project-root)))
-      (setq ghc-process-process-name root))
+  (when (and ghc-process-process-name (not ghc-process-running))
-    (when (and ghc-process-process-name (not ghc-process-running))
+    (setq ghc-process-running t)
-      (setq ghc-process-running t)
+    (if hook1 (funcall hook1))
-      (if hook1 (funcall hook1))
+    (let* ((cbuf (current-buffer))
-      (let* ((cbuf (current-buffer))
+	   (name ghc-process-process-name)
-	     (name ghc-process-process-name)
+	   (root (file-name-as-directory ghc-process-process-name))
-	     (buf (get-buffer-create (concat " ghc-mod:" name)))
+	   (buf (get-buffer-create (concat " ghc-mod:" name)))
-	     (file (buffer-file-name))
+	   (file (buffer-file-name))
-	     (cpro (get-process name)))
+	   (cpro (get-process name)))
-	(ghc-with-current-buffer buf
+      ;; setting root in the original buffer, sigh
-	  (setq ghc-process-original-buffer cbuf)
+      (setq ghc-process-root root)
-	  (setq ghc-process-original-file file)
+      (ghc-with-current-buffer buf
-	  (setq ghc-process-callback callback)
+        (setq ghc-process-original-buffer cbuf)
-	  (setq ghc-process-hook hook2)
+	(setq ghc-process-original-file file)
-	  (setq ghc-process-root root)
+	(setq ghc-process-hook hook2)
-	  (erase-buffer)
+	(setq ghc-process-root root)
-	  (let ((pro (ghc-get-process cpro name buf)))
+	(let ((pro (ghc-get-process cpro name buf root))
-	    (process-send-string pro cmd)
+	      (map-cmd (format "map-file %s\n" file)))
+	  ;; map-file
+	  (unless skip-map-file
+	    (setq ghc-process-file-mapping t)
+	    (setq ghc-process-callback nil)
+	    (erase-buffer)
 	    (when ghc-debug
 	      (ghc-with-debug-buffer
-	       (insert (format "%% %s" cmd))))
+	       (insert (format "%% %s" map-cmd))
-	    pro))))))
+	       (insert "CONTENTS + EOT\n")))
+	    (process-send-string pro map-cmd)
+	    (with-current-buffer cbuf
+	      (save-restriction
+		(widen)
+		(process-send-region pro (point-min) (point-max))))
+	    (process-send-string pro "\004\n")
+	    (condition-case nil
+		(let ((inhibit-quit nil))
+		  (while ghc-process-file-mapping
+		    (accept-process-output pro 0.1 nil t)))
+	      (quit
+	       (setq ghc-process-running nil)
+	       (setq ghc-process-file-mapping nil))))
+	  ;; command
+	  (setq ghc-process-callback callback)
+	  (erase-buffer)
+	  (when ghc-debug
+	    (ghc-with-debug-buffer
+	     (insert (format "%% %s" cmd))))
+	  (process-send-string pro cmd)
+	  pro)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defun ghc-get-process (cpro name buf)
+(defun ghc-get-process (cpro name buf root)
   (cond
    ((not cpro)
-    (ghc-start-process name buf))
+    (ghc-start-process name buf root))
    ((not (eq (process-status cpro) 'run))
     (delete-process cpro)
-    (ghc-start-process name buf))
+    (ghc-start-process name buf root))
    (t cpro)))
 
-(defun ghc-start-process (name buf)
+(defun ghc-start-process (name buf root)
-  (let* ((opts (append ghc-debug-options
+  (let* ((default-directory root)
+	 (process-connection-type nil) ;; using PIPE due to ^D
+	 (opts (append ghc-debug-options
 		       '("-b" "\n" "-l" "--line-prefix=O: ,E: ")
 		       (ghc-make-ghc-options)
 		       '("legacy-interactive")))
-	 (pro (apply 'start-file-process name buf ghc-command opts)))
+	 (pro (apply 'start-process name buf ghc-command opts)))
     (set-process-filter pro 'ghc-process-filter)
     (set-process-sentinel pro 'ghc-process-sentinel)
     (set-process-query-on-exit-flag pro nil)
@@ -97,7 +126,7 @@
 	  (insert string)
 	  (goto-char (point-min))
 	  (let ((cont t) end out)
-	    (while (and cont (not (eobp)))
+	    (while (and cont (not (eobp)) ghc-process-running)
 	      (cond
 	       ((looking-at "^O: ")
 		(setq out t))
@@ -126,23 +155,27 @@
 		      (with-selected-window cwin
 			(goto-char (point-max))
 			(insert-buffer-substring tbuf 1 end)
-			(set-buffer-modified-p nil)
+			(set-buffer-modified-p nil))
-			(redisplay)))))
+		      (redisplay))))
 		(delete-region 1 end)))))
 	(goto-char (point-max))
 	(forward-line -1)
 	(cond
 	 ((looking-at "^OK$")
-	  (if ghc-process-hook (funcall ghc-process-hook))
+	  (delete-region (point) (point-max))
-	  (goto-char (point-min))
+	  (setq ghc-process-file-mapping nil)
-	  (funcall ghc-process-callback 'ok)
+	  (when ghc-process-callback
-	  (setq ghc-process-running nil))
+	    (if ghc-process-hook (funcall ghc-process-hook))
+	    (goto-char (point-min))
+	    (funcall ghc-process-callback 'ok)
+	    (setq ghc-process-running nil)))
 	 ((looking-at "^NG ")
 	  (funcall ghc-process-callback 'ng)
 	  (setq ghc-process-running nil)))))))
 
-(defun ghc-process-sentinel (process event)
+(defun ghc-process-sentinel (_process _event)
-  (setq ghc-process-running nil))
+  (setq ghc-process-running nil)
+  (setq ghc-process-file-mapping nil))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -150,12 +183,12 @@
 (defvar ghc-process-num-of-results nil)
 (defvar ghc-process-results nil)
 
-(defun ghc-sync-process (cmd &optional n hook)
+(defun ghc-sync-process (cmd &optional n hook skip-map-file)
   (unless ghc-process-running
     (setq ghc-process-rendezvous nil)
     (setq ghc-process-results nil)
     (setq ghc-process-num-of-results (or n 1))
-    (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook)))
+    (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook skip-map-file)))
       ;; ghc-process-running is now t.
       ;; But if the process exits abnormally, it is set to nil.
       (condition-case nil
@@ -183,11 +216,12 @@
 
 (defun ghc-kill-process ()
   (interactive)
-  (let* ((name ghc-process-process-name)
+  (when (eq major-mode 'haskell-mode)
-	 (cpro (if name (get-process name))))
+    (let* ((name ghc-process-process-name)
-    (if (not cpro)
+	   (cpro (if name (get-process name))))
-	(message "No process")
+      (if (not cpro)
-      (delete-process cpro)
+	  (message "No ghc-mod process")
-      (message "A process was killed"))))
+	(delete-process cpro)
+	(message "ghc-mod process was killed")))))
 
 (provide 'ghc-process)

elisp/ghc-rewrite.el

@@ -126,12 +126,9 @@
       (lambda ()
         (insert "Possible completions:\n")
         (mapc
-          (lambda (x)
+          (lambda (_x)
-            (let* (; (ins1      (insert "- "))
+            (let ((pos-begin (point))
-                   (pos-begin (point))
+                  (pos-end   (point)))
-                   (ins       (insert x))
-                   (pos-end   (point))
-                   (ins3      (insert "\n")))
               (make-button pos-begin pos-end :type 'auto-button)))
           (ghc-sinfo-get-info info))))
     (select-window (ghc-auto-completion-window))))

elisp/ghc.el

@@ -28,7 +28,9 @@
 	       (< emacs-minor-version minor)))
       (error "ghc-mod requires at least Emacs %d.%d" major minor)))
 
-(defconst ghc-version "5.3.0.0")
+(defconst ghc-version "5.4.0.0")
+
+(defgroup ghc-mod '() "ghc-mod customization")
 
 ;; (eval-when-compile
 ;;  (require 'haskell-mode))
@@ -115,11 +117,9 @@
     (define-key haskell-mode-map ghc-next-hole-key   'ghc-goto-next-hole)
     (ghc-comp-init)
     (setq ghc-initialized t)
+    (add-hook 'kill-buffer-hook 'ghc-kill-process)
     (defadvice save-buffer (after ghc-check-syntax-on-save activate)
       "Check syntax with GHC when a haskell-mode buffer is saved."
-      (when (eq 'haskell-mode major-mode) (ghc-check-syntax)))
-    (defadvice switch-to-buffer (after ghc-check-syntax-on-switch-to-buffer activate)
-      "Check syntax with GHC when switching to a haskell-mode buffer."
       (when (eq 'haskell-mode major-mode) (ghc-check-syntax))))
   (ghc-import-module)
   (ghc-check-syntax))
@@ -136,7 +136,8 @@
 	(el-ver ghc-version)
 	(ghc-ver (ghc-run-ghc-mod '("--version") "ghc"))
 	(ghc-mod-ver (ghc-run-ghc-mod '("version")))
-	(path (getenv "PATH")))
+	(path (getenv "PATH"))
+	(debug (ghc-run-ghc-mod '("debug")))) ;; before switching buffers.
     (switch-to-buffer (get-buffer-create "**GHC Debug**"))
     (erase-buffer)
     (insert "Path: check if you are using intended programs.\n")
@@ -148,7 +149,10 @@
     (insert (format "\t %s\n" ghc-mod-ver))
     (insert (format "\t%s\n" ghc-ver))
     (insert "\nEnvironment variables:\n")
-    (insert (format "\tPATH=%s\n" path))))
+    (insert (format "\tPATH=%s\n" path))
+    (insert "\nThe result of \"ghc-mod debug\":\n")
+    (insert debug)
+    (goto-char (point-min))))
 
 (defun ghc-insert-template-or-signature (&optional flag)
   (interactive "P")

ghc-mod.cabal

@@ -1,5 +1,5 @@
 Name:                   ghc-mod
-Version:                5.3.0.0
+Version:                5.4.0.0
 Author:                 Kazu Yamamoto <kazu@iij.ad.jp>,
                         Daniel Gröber <dxld@darkboxed.org>,
                         Alejandro Serrano <trupill@gmail.com>
@@ -32,6 +32,7 @@ Data-Files:             LICENSE COPYING.BSD3 COPYING.AGPL3
 Extra-Source-Files:     ChangeLog
                         SetupCompat.hs
                         NotCPP/*.hs
+                        NotCPP/COPYING
                         test/data/annotations/*.hs
                         test/data/broken-cabal/*.cabal
                         test/data/broken-cabal/cabal.sandbox.config.in
@@ -81,17 +82,25 @@ Extra-Source-Files:     ChangeLog
                         test/data/cabal-preprocessors/*.cabal
                         test/data/cabal-preprocessors/*.hs
                         test/data/cabal-preprocessors/*.hsc
+                        test/data/file-mapping/*.hs
+                        test/data/file-mapping/preprocessor/*.hs
+                        test/data/file-mapping/lhs/*.lhs
+                        test/data/nice-qualification/*.hs
+                        test/data/stack-project/stack.yaml
+                        test/data/stack-project/new-template.cabal
+                        test/data/stack-project/*.hs
+                        test/data/stack-project/app/*.hs
+                        test/data/stack-project/src/*.hs
+                        test/data/stack-project/test/*.hs
 
 Library
   Default-Language:     Haskell2010
   GHC-Options:          -Wall -fno-warn-deprecations
   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
                         ConstraintKinds, FlexibleContexts,
-                        DataKinds, KindSignatures, TypeOperators
+                        DataKinds, KindSignatures, TypeOperators, ViewPatterns
   Exposed-Modules:      Language.Haskell.GhcMod
                         Language.Haskell.GhcMod.Internal
-  Other-Modules:        Paths_ghc_mod
-                        Utils
                         Language.Haskell.GhcMod.Boot
                         Language.Haskell.GhcMod.Browse
                         Language.Haskell.GhcMod.CabalHelper
@@ -101,10 +110,13 @@ Library
                         Language.Haskell.GhcMod.Check
                         Language.Haskell.GhcMod.Convert
                         Language.Haskell.GhcMod.Cradle
+                        Language.Haskell.GhcMod.CustomPackageDb
                         Language.Haskell.GhcMod.Debug
+                        Language.Haskell.GhcMod.DebugLogger
                         Language.Haskell.GhcMod.Doc
                         Language.Haskell.GhcMod.DynFlags
                         Language.Haskell.GhcMod.Error
+                        Language.Haskell.GhcMod.FileMapping
                         Language.Haskell.GhcMod.FillSig
                         Language.Haskell.GhcMod.Find
                         Language.Haskell.GhcMod.Flag
@@ -114,6 +126,7 @@ Library
                         Language.Haskell.GhcMod.Info
                         Language.Haskell.GhcMod.Lang
                         Language.Haskell.GhcMod.Lint
+                        Language.Haskell.GhcMod.LightGhc
                         Language.Haskell.GhcMod.Logger
                         Language.Haskell.GhcMod.Logging
                         Language.Haskell.GhcMod.Modules
@@ -125,15 +138,18 @@ Library
                         Language.Haskell.GhcMod.Pretty
                         Language.Haskell.GhcMod.Read
                         Language.Haskell.GhcMod.SrcUtils
+                        Language.Haskell.GhcMod.Stack
                         Language.Haskell.GhcMod.Target
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.World
+  Other-Modules:        Paths_ghc_mod
+                        Utils
   Build-Depends:        base >= 4.0 && < 5
                       , bytestring
                       , cereal >= 0.4
                       , containers
-                      , cabal-helper == 0.5.* && >= 0.5.1.0
+                      , cabal-helper == 0.6.* && >= 0.6.0.0
                       , deepseq
                       , directory
                       , filepath
@@ -156,7 +172,9 @@ Library
                       , haskell-src-exts
                       , text
                       , djinn-ghc >= 0.0.2.2
-                      , fclabels
+                      , fclabels == 2.0.*
+                      , extra == 1.4.*
+                      , pipes == 4.1.*
   if impl(ghc < 7.8)
     Build-Depends:      convertible
   if impl(ghc < 7.5)
@@ -168,7 +186,7 @@ Executable ghc-mod
   Default-Language:     Haskell2010
   Main-Is:              GHCMod.hs
   Other-Modules:        Paths_ghc_mod
-  GHC-Options:          -Wall -fno-warn-deprecations
+  GHC-Options:          -Wall -fno-warn-deprecations -threaded
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
@@ -181,6 +199,7 @@ Executable ghc-mod
                       , mtl >= 2.0
                       , ghc
                       , ghc-mod
+                      , fclabels == 2.0.*
 
 Executable ghc-modi
   Default-Language:     Haskell2010
@@ -216,7 +235,7 @@ Test-Suite spec
   Default-Language:     Haskell2010
   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
                         ConstraintKinds, FlexibleContexts,
-                        DataKinds, KindSignatures, TypeOperators
+                        DataKinds, KindSignatures, TypeOperators, ViewPatterns
   Main-Is:              Main.hs
   Hs-Source-Dirs:       test, .
   Ghc-Options:          -Wall -fno-warn-deprecations
@@ -227,6 +246,7 @@ Test-Suite spec
                         Spec
                         TestUtils
                         BrowseSpec
+                        CustomPackageDbSpec
                         CheckSpec
                         FlagSpec
                         InfoSpec
@@ -236,6 +256,7 @@ Test-Suite spec
                         MonadSpec
                         PathsAndFilesSpec
                         HomeModuleGraphSpec
+                        FileMappingSpec
 
   Build-Depends:        hspec >= 2.0.0
   if impl(ghc == 7.4.*)
@@ -246,4 +267,4 @@ Test-Suite spec
 
 Source-Repository head
   Type:                 git
-  Location:             git://github.com/kazu-yamamoto/ghc-mod.git
+  Location:             https://github.com/kazu-yamamoto/ghc-mod.git

src/GHCMod.hs

@@ -3,11 +3,13 @@
 module Main where
 
 import Config (cProjectVersion)
-import MonadUtils (liftIO)
+import Control.Category
 import Control.Applicative
+import Control.Arrow
 import Control.Monad
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
+import Data.Label
 import Data.List
 import Data.List.Split
 import Data.Char (isSpace)
@@ -15,6 +17,8 @@ import Data.Maybe
 import Exception
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad
 import Paths_ghc_mod
 import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
 import qualified System.Console.GetOpt as O
@@ -22,11 +26,10 @@ import System.FilePath ((</>))
 import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
                         removeDirectoryRecursive)
 import System.Environment (getArgs)
-import System.Exit (exitFailure)
+import System.IO
-import System.IO (stdout, hSetEncoding, utf8, hFlush)
+import System.Exit
-import System.Exit (exitSuccess)
 import Text.PrettyPrint
-import Prelude
+import Prelude hiding ((.))
 
 import Misc
 
@@ -173,7 +176,7 @@ usage =
  \    - lint FILE\n\
  \        Check files using `hlint'.\n\
  \      Flags:\n\
- \        -l\n\
+ \        -h\n\
  \            Option to be passed to hlint.\n\
  \\n\
  \    - root\n\
@@ -247,47 +250,93 @@ intToLogLevel = toEnum
 globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
 globalArgSpec =
       [ option "v" ["verbose"] "Increase or set log level. (0-7)" $
-               optArg "LEVEL" $ \ml o -> Right $ o {
+          optArg "LEVEL" $ \ml o -> Right $ case ml of
-                   logLevel = case ml of
+              Nothing ->
-                                Nothing -> increaseLogLevel (logLevel o)
+                  modify (lOoptLogLevel . lOptOutput) increaseLogLevel o
-                                Just l -> toEnum $ min 7 $ read l
+              Just l ->
-                 }
+                  set (lOoptLogLevel . lOptOutput) (toEnum $ min 7 $ read l) o
 
       , option "s" [] "Be silent, set log level to 0" $
-               NoArg $ \o -> Right $ o { logLevel = toEnum 0 }
+          NoArg $ \o -> Right $ set (lOoptLogLevel . lOptOutput) (toEnum 0) o
 
       , option "l" ["tolisp"] "Format output as an S-Expression" $
-               NoArg $ \o -> Right $ o { outputStyle = LispStyle }
+          NoArg $ \o -> Right $ set (lOoptStyle . lOptOutput) LispStyle o
 
       , option "b" ["boundary", "line-seperator"] "Output line separator"$
-               reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s }
+          reqArg "SEP" $ \s o -> Right $ set (lOoptLineSeparator . lOptOutput) (LineSeparator s) o
+
       , option "" ["line-prefix"] "Output line separator"$
-               reqArg "OUT,ERR" $ \s o -> let
+          reqArg "OUT,ERR" $ \s o -> let
-                     [out, err] = splitOn "," s
+                [out, err] = splitOn "," s
-                   in Right $ o { linePrefix = Just (out, err) }
+              in Right $ set (lOoptLinePrefix . lOptOutput) (Just (out, err)) o
 
       , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
-               reqArg "OPT" $ \g o -> Right $
+          reqArg "OPT" $ \g o -> Right $
-                   o { ghcUserOptions = g : ghcUserOptions o }
+              o { optGhcUserOptions = g : optGhcUserOptions o }
+
+{-
+File map docs:
+
+CLI options:
+* `--map-file "file1.hs=file2.hs"` can be used to tell
+    ghc-mod that it should take source code for `file1.hs` from `file2.hs`.
+    `file1.hs` can be either full path, or path relative to project root.
+    `file2.hs` has to be either relative to project root,
+    or full path (preferred).
+* `--map-file "file.hs"` can be used to tell ghc-mod that it should take
+    source code for `file.hs` from stdin. File end marker is `\EOT\n`,
+    i.e. `\x04\x0A`. `file.hs` may or may not exist, and should be
+    either full path, or relative to project root.
+
+Interactive commands:
+* `map-file file.hs` -- tells ghc-modi to read `file.hs` source from stdin.
+    Works the same as second form of `--map-file` CLI option.
+* `unmap-file file.hs` -- unloads previously mapped file, so that it's
+    no longer mapped. `file.hs` can be full path or relative to
+    project root, either will work.
+
+Exposed functions:
+* `loadMappedFile :: FilePath -> FilePath -> GhcModT m ()` -- maps `FilePath`,
+    given as first argument to take source from `FilePath` given as second
+    argument. Works exactly the same as first form of `--map-file`
+    CLI option.
+* `loadMappedFileSource :: FilePath -> String -> GhcModT m ()` -- maps
+    `FilePath`, given as first argument to have source as given
+    by second argument. Works exactly the same as second form of `--map-file`
+    CLI option, sans reading from stdin.
+* `unloadMappedFile :: FilePath -> GhcModT m ()` -- unmaps `FilePath`, given as
+    first argument, and removes any temporary files created when file was
+    mapped. Works exactly the same as `unmap-file` interactive command
+-}
+      , option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $
+          reqArg "OPT" $ \g o ->
+             let m = case second (drop 1) $ span (/='=') g of
+                       (s,"") -> (s, Nothing)
+                       (f,t)  -> (f, Just t)
+             in
+             Right $ o { optFileMappings = m : optFileMappings o }
 
       , option "" ["with-ghc"] "GHC executable to use" $
-               reqArg "PROG" $ \p o -> Right $ o { ghcProgram = p }
+          reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lOptPrograms) p o
 
       , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
-               reqArg "PROG" $ \p o -> Right $ o { ghcPkgProgram = p }
+          reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lOptPrograms) p o
 
       , option "" ["with-cabal"] "cabal-install executable to use" $
-               reqArg "PROG" $ \p o -> Right $ o { cabalProgram = p }
+          reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lOptPrograms) p o
+
+      , option "" ["with-stack"] "stack executable to use" $
+          reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lOptPrograms) p o
 
       , option "" ["version"] "print version information" $
-               NoArg $ \_ -> Left ["version"]
+          NoArg $ \_ -> Left ["version"]
 
       , option "" ["help"] "print this help message" $
-               NoArg $ \_ -> Left ["help"]
+          NoArg $ \_ -> Left ["help"]
-
   ]
 
 
+
 parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
 parseGlobalArgs argv
     = case O.getOpt' RequireOrder globalArgSpec argv of
@@ -330,6 +379,8 @@ data InteractiveOptions = InteractiveOptions {
 handler :: IOish m => GhcModT m a -> GhcModT m a
 handler = flip gcatches $
           [ GHandler $ \(FatalError msg) -> exitError msg
+          , GHandler $ \e@(ExitSuccess) -> throw e
+          , GHandler $ \e@(ExitFailure _) -> throw e
           , GHandler $ \(InvalidCommandLine e) -> do
                 case e of
                   Left cmd ->
@@ -346,21 +397,16 @@ main = do
     args <- getArgs
     case parseGlobalArgs args of
       Left e -> throw e
-      Right res -> progMain res
+      Right res@(globalOptions,_) -> catches (progMain res) [
+            Handler $ \(e :: GhcModError) ->
+              runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
+          ]
 
 progMain :: (Options,[String]) -> IO ()
-progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
+progMain (globalOptions,cmdArgs) = runGmOutT globalOptions $
     case globalCommands cmdArgs of
       Just s -> gmPutStr s
-      Nothing -> ghcCommands cmdArgs
+      Nothing -> wrapGhcCommands globalOptions cmdArgs
- where
-   hndle action = do
-     (e, _l) <- action
-     case e of
-       Right _ ->
-           return ()
-       Left ed ->
-           exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)
 
 globalCommands :: [String] -> Maybe String
 globalCommands (cmd:_)
@@ -374,7 +420,8 @@ legacyInteractive = do
     opt <- options
     prepareCabalHelper
     tmpdir <- cradleTempDir <$> cradle
-    symdbreq <- liftIO $ newSymDbReq opt tmpdir
+    gmo <- gmoAsk
+    symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir
     world <- getCurrentWorld
     legacyInteractiveLoop symdbreq world
 
@@ -403,6 +450,11 @@ legacyInteractiveLoop symdbreq world = do
     -- after blocking, we need to see if the world has changed.
 
     changed <- didWorldChange world
+
+    world' <- if changed
+                then getCurrentWorld -- TODO: gah, we're hitting the fs twice
+                else return world
+
     when changed $ do
         dropSession
 
@@ -429,22 +481,64 @@ legacyInteractiveLoop symdbreq world = do
         "boot"   -> bootCmd []
         "browse" -> browseCmd args
 
+        "map-file"   ->  liftIO getFileSourceFromStdin
+                     >>= loadMappedFileSource arg
+                     >>  return ""
+
+        "unmap-file" ->  unloadMappedFile arg
+                     >>  return ""
+
         "quit"   -> liftIO $ exitSuccess
         ""       -> liftIO $ exitSuccess
         _        -> fatalError $ "unknown command: `" ++ cmd ++ "'"
 
     gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
-    legacyInteractiveLoop symdbreq world
+    legacyInteractiveLoop symdbreq world'
  where
    interactiveHandlers =
           [ GHandler $ \e@(FatalError _) -> throw e
+          , GHandler $ \e@(ExitSuccess) -> throw e
+          , GHandler $ \e@(ExitFailure _) -> throw e
           , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
           ]
 
+getFileSourceFromStdin :: IO String
+getFileSourceFromStdin = do
+  let loop' acc = do
+        line <- getLine
+        if not (null line) && last line == '\EOT'
+        then return $ acc ++ init line
+        else loop' (acc++line++"\n")
+  loop' ""
+
+-- Someone please already rewrite the cmdline parsing code *weep* :'(
+wrapGhcCommands :: (IOish m, GmOut m) => Options -> [String] -> m ()
+wrapGhcCommands _opts []            = fatalError "No command given (try --help)"
+wrapGhcCommands _opts ("root":_) = gmPutStr =<< rootInfo
+wrapGhcCommands opts args = do
+    handleGmError $ runGhcModT opts $ handler $ do
+      forM_ (reverse $ optFileMappings opts) $
+        uncurry loadMMappedFiles
+
+      ghcCommands args
+ where
+   handleGmError action = do
+     (e, _l) <- liftIO . evaluate =<< action
+     case e of
+       Right _ ->
+           return ()
+       Left ed ->
+           exitError $ renderStyle ghcModStyle (gmeDoc ed)
+
+   loadMMappedFiles from (Just to) = loadMappedFile from to
+   loadMMappedFiles from (Nothing) = do
+       src <- liftIO getFileSourceFromStdin
+       loadMappedFileSource from src
+
+
 ghcCommands :: IOish m => [String] -> GhcModT m ()
 ghcCommands []         = fatalError "No command given (try --help)"
-ghcCommands (cmd:args) = do
+ghcCommands (cmd:args) = gmPutStr =<< action args
-    gmPutStr =<< action args
  where
    action = case cmd of
      _ | cmd == "list" || cmd == "modules" -> modulesCmd
@@ -463,7 +557,7 @@ ghcCommands (cmd:args) = do
      "auto"    -> autoCmd
      "find"    -> findSymbolCmd
      "lint"    -> lintCmd
-     "root"    -> rootInfoCmd
+--     "root"    -> rootInfoCmd
      "doc"     -> pkgDocCmd
      "dumpsym" -> dumpSymbolCmd
      "boot"    -> bootCmd
@@ -478,13 +572,9 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String)
     deriving (Show, Typeable)
 instance Exception InvalidCommandLine
 
-exitError :: IOish m => String -> GhcModT m a
+exitError :: (MonadIO m, GmOut m) => String -> m a
 exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
 
-exitError' :: Options -> String -> IO a
-exitError' opts msg =
-    gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
-
 fatalError :: String -> a
 fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
 
@@ -513,7 +603,7 @@ catchArgs cmd action =
 
 modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
   debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
-  refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
+  refineCmd, autoCmd, findSymbolCmd, lintCmd, pkgDocCmd,
   dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
   :: IOish m => [String] -> GhcModT m String
 
@@ -522,7 +612,6 @@ modulesCmd    = withParseCmd' "modules" s $ \[] -> modules
 languagesCmd  = withParseCmd' "lang"    [] $ \[] -> languages
 flagsCmd      = withParseCmd' "flag"    [] $ \[] -> flags
 debugInfoCmd  = withParseCmd' "debug"   [] $ \[] -> debugInfo
-rootInfoCmd   = withParseCmd' "root"    [] $ \[] -> rootInfo
 componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
 -- internal
 bootCmd       = withParseCmd' "boot" [] $ \[] -> boot
@@ -577,24 +666,24 @@ locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
 modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]
 modulesArgSpec =
     [ option "d" ["detailed"] "Print package modules belong to." $
-             NoArg $ \o -> Right $ o { detailed = True }
+             NoArg $ \o -> Right $ o { optDetailed = True }
     ]
 
 
 hlintArgSpec :: [OptDescr (Options -> Either [String] Options)]
 hlintArgSpec =
     [ option "h" ["hlintOpt"] "Option to be passed to hlint" $
-             reqArg "hlintOpt" $ \h o -> Right $ o { hlintOpts = h : hlintOpts o }
+             reqArg "hlintOpt" $ \h o -> Right $ o { optHlintOpts = h : optHlintOpts o }
     ]
 
 browseArgSpec :: [OptDescr (Options -> Either [String] Options)]
 browseArgSpec =
     [ option "o" ["operators"] "Also print operators." $
-             NoArg $ \o -> Right $ o { operators = True }
+             NoArg $ \o -> Right $ o { optOperators = True }
     , option "d" ["detailed"] "Print symbols with accompanying signature." $
-             NoArg $ \o -> Right $ o { detailed = True }
+             NoArg $ \o -> Right $ o { optDetailed = True }
     , option "q" ["qualified"] "Qualify symbols" $
-             NoArg $ \o -> Right $ o { qualified = True }
+             NoArg $ \o -> Right $ o { optQualified = True }
     ]
 
 nukeCaches :: IOish m => GhcModT m ()
@@ -602,9 +691,10 @@ nukeCaches = do
   chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
   c <- cradle
 
-  when (cradleProjectType c == CabalProject) $ do
+  when (isCabalHelperProject $ cradleProject c) $ do
     let root = cradleRootDir c
-    liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> "dist"]
+    let dist = cradleDistDir c
+    liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> dist]
 
 trySome :: IO a -> IO (Either SomeException a)
 trySome = try

src/Misc.hs

@@ -8,21 +8,22 @@ module Misc (
   ) where
 
 import Control.Concurrent.Async (Async, async, wait)
-import CoreMonad (liftIO)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Prelude
 
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad
 
 ----------------------------------------------------------------
 
 type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
 data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
 
-newSymDbReq :: Options -> FilePath -> IO SymDbReq
+newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq
-newSymDbReq opt dir = do
+newSymDbReq opt gmo tmpdir = do
-    let act = runGhcModT opt $ loadSymbolDb dir
+    let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir
     req <- async act
     ref <- newIORef req
     return $ SymDbReq ref act

stack.yaml

@@ -0,0 +1,6 @@
+flags: {}
+packages:
+- '.'
+extra-deps:
+- cabal-helper-0.6.0.0
+resolver: lts-3.1

test/BrowseSpec.hs

@@ -3,6 +3,7 @@ module BrowseSpec where
 import Control.Applicative
 import Language.Haskell.GhcMod
 import Test.Hspec
+import Prelude
 
 import TestUtils
 import Dir
@@ -16,18 +17,18 @@ spec = do
 
     describe "browse -d Data.Either" $ do
         it "contains functions (e.g. `either') including their type signature" $ do
-            syms <- run defaultOptions { detailed = True }
+            syms <- run defaultOptions { optDetailed = True }
                     $ lines <$> browse "Data.Either"
             syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]
 
         it "contains type constructors (e.g. `Left') including their type signature" $ do
-            syms <- run defaultOptions { detailed = True}
+            syms <- run defaultOptions { optDetailed = True}
                     $ lines <$> browse "Data.Either"
             syms `shouldContain` ["Left :: a -> Either a b"]
 
     describe "`browse' in a project directory" $ do
         it "can list symbols defined in a a local module" $ do
-            withDirectory_ "test/data/ghc-mod-check/lib" $ do
+            withDirectory_ "test/data/ghc-mod-check/" $ do
                 syms <- runD $ lines <$> browse "Data.Foo"
                 syms `shouldContain` ["foo"]
                 syms `shouldContain` ["fibonacci"]

test/CabalHelperSpec.hs

@@ -9,7 +9,8 @@ import Language.Haskell.GhcMod.Error
 import Test.Hspec
 import System.Directory
 import System.FilePath
-import System.Process (readProcess, system)
+import System.Process
+import Prelude
 
 import Dir
 import TestUtils
@@ -56,6 +57,12 @@ spec = do
               then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp])
               else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp])
 
+        it "handles stack project" $ do
+            let tdir = "test/data/stack-project"
+            [ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents
+            let pkgs = pkgOptions ghcOpts
+            sort pkgs `shouldBe` ["base", "bytestring"]
+
         it "extracts build dependencies" $ do
             let tdir = "test/data/cabal-project"
             opts <- map gmcGhcOpts <$> runD' tdir getComponents
@@ -72,25 +79,3 @@ spec = do
             let ghcOpts = head opts
                 pkgs = pkgOptions ghcOpts
             pkgs `shouldBe` ["Cabal","base"]
-
-    describe "getCustomPkgDbStack" $ do
-        it "works" $ do
-            let tdir = "test/data/custom-cradle"
-            Just stack <- runD' tdir $ getCustomPkgDbStack
-            stack `shouldBe` [ GlobalDb
-                             , UserDb
-                             , PackageDb "package-db-a"
-                             , PackageDb "package-db-b"
-                             , PackageDb "package-db-c"
-                             ]
-
-    describe "getPackageDbStack'" $ do
-        it "fixes out of sync custom pkg-db stack" $ do
-            withDirectory_ "test/data/custom-cradle" $ do
-                _ <- system "cabal configure"
-                (s, s') <- runD $ do
-                    Just stack <- getCustomPkgDbStack
-                    withCabal $ do
-                        stack' <- getCabalPackageDbStack
-                        return (stack, stack')
-                s' `shouldBe` s

test/CheckSpec.hs

@@ -67,3 +67,12 @@ spec = do
                 _ <- system "cabal build"
                 res <- runD $ checkSyntax ["Main.hs"]
                 res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n"
+
+        it "Uses the right qualification style" $ do
+            withDirectory_ "test/data/nice-qualification" $ do
+                res <- runD $ checkSyntax ["NiceQualification.hs"]
+#if __GLASGOW_HASKELL__ >= 708
+                res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n"
+#else
+                res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n"
+#endif

test/CradleSpec.hs

@@ -7,6 +7,8 @@ import Language.Haskell.GhcMod.Types
 import System.Directory (canonicalizePath)
 import System.FilePath (pathSeparator)
 import Test.Hspec
+import TestUtils
+import Prelude
 
 import Dir
 
@@ -35,14 +37,14 @@ spec = do
         it "returns the current directory" $ do
             withDirectory_ "/" $ do
                 curDir <- stripLastDot <$> canonicalizePath "/"
-                res <- clean_ findCradle
+                res <- clean_ $ runGmOutDef findCradle
                 cradleCurrentDir res `shouldBe` curDir
                 cradleRootDir    res `shouldBe` curDir
                 cradleCabalFile  res `shouldBe` Nothing
 
         it "finds a cabal file and a sandbox" $ do
             withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
-                res <- relativeCradle dir <$> clean_ findCradle
+                res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
 
                 cradleCurrentDir res `shouldBe`
                     "test/data/cabal-project/subdir1/subdir2"
@@ -54,7 +56,7 @@ spec = do
 
         it "works even if a sandbox config file is broken" $ do
             withDirectory "test/data/broken-sandbox" $ \dir -> do
-                res <- relativeCradle dir <$> clean_ findCradle
+                res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
                 cradleCurrentDir res `shouldBe`
                     "test" </> "data" </> "broken-sandbox"
 

test/CustomPackageDbSpec.hs

@@ -0,0 +1,35 @@
+module CustomPackageDbSpec where
+
+import Language.Haskell.GhcMod.CabalHelper
+import Language.Haskell.GhcMod.CustomPackageDb
+import Language.Haskell.GhcMod.Error
+import System.Process
+import Test.Hspec
+import Prelude
+
+import Dir
+import TestUtils
+
+spec :: Spec
+spec = do
+    describe "getCustomPkgDbStack" $ do
+        it "works" $ do
+            let tdir = "test/data/custom-cradle"
+            Just stack <- runD' tdir $ getCustomPkgDbStack
+            stack `shouldBe` [ GlobalDb
+                             , UserDb
+                             , PackageDb "package-db-a"
+                             , PackageDb "package-db-b"
+                             , PackageDb "package-db-c"
+                             ]
+
+    describe "getPackageDbStack'" $ do
+        it "fixes out of sync custom pkg-db stack" $ do
+            withDirectory_ "test/data/custom-cradle" $ do
+                _ <- system "cabal configure"
+                (s, s') <- runD $ do
+                    Just stack <- getCustomPkgDbStack
+                    withCabal $ do
+                        stack' <- getCabalPackageDbStack
+                        return (stack, stack')
+                s' `shouldBe` s

test/FileMappingSpec.hs

@@ -0,0 +1,240 @@
+module FileMappingSpec where
+
+import Language.Haskell.GhcMod.FileMapping
+import Language.Haskell.GhcMod.Utils (withMappedFile)
+import Test.Hspec
+import TestUtils
+import qualified Data.Map as M
+import Dir
+import System.IO.Temp
+import System.Directory
+
+import Language.Haskell.GhcMod
+
+spec :: Spec
+spec = do
+      describe "loadMappedFile" $ do
+        it "inserts a given FilePath FileMapping into state with canonicalized path" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            mappedFiles <- runD $ do
+              loadMappedFile "File.hs" "File.hs"
+              getMMappedFiles
+            dir <- getCurrentDirectory
+            show mappedFiles `shouldBe` show (M.fromList [(dir </> "File.hs", FileMapping "File.hs" False)])
+        it "should try to guess a canonical name if file doesn't exist" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            mappedFiles <- runD $ do
+              loadMappedFile "NonExistantFile.hs" "File.hs"
+              getMMappedFiles
+            dir <- getCurrentDirectory
+            show mappedFiles `shouldBe` show (M.fromList [(dir </> "NonExistantFile.hs", FileMapping "File.hs" False)])
+
+      describe "loadMappedFileSource" $ do
+        it "inserts a given FilePath FileMapping into state with canonicalized path" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            mappedFiles <- runD $ do
+              loadMappedFileSource "File.hs" "main :: IO ()"
+              getMMappedFiles
+            dir <- getCurrentDirectory
+            -- TODO
+            M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] ->
+              fn == dir </> "File.hs"
+        it "should try to guess a canonical name if file doesn't exist" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            mappedFiles <- runD $ do
+              loadMappedFileSource "NonExistantFile.hs" "main :: IO ()"
+              getMMappedFiles
+            dir <- getCurrentDirectory
+            -- TODO
+            M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] ->
+              fn == dir </> "NonExistantFile.hs"
+
+      describe "unloadMappedFile" $ do
+        it "removes a given FilePath from state" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            mappedFiles <- runD $ do
+              loadMappedFile "File.hs" "File2.hs"
+              unloadMappedFile "File.hs"
+              getMMappedFiles
+            show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)]))
+        it "should work even if file does not exist" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            mappedFiles <- runD $ do
+              loadMappedFile "NonExistantFile.hs" "File2.hs"
+              unloadMappedFile "NonExistantFile.hs"
+              getMMappedFiles
+            show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)]))
+        it "should remove created temporary files" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            dir <- getCurrentDirectory
+            fileExists <- runD $ do
+              loadMappedFileSource "NonExistantFile.hs" "main :: IO ()"
+              fp <- maybe undefined fmPath `fmap` lookupMMappedFile (dir </> "NonExistantFile.hs")
+              unloadMappedFile "NonExistantFile.hs"
+              liftIO $ doesFileExist fp
+            not fileExists `shouldBe` True
+
+      describe "withMappedFile" $ do
+        it "checks if there is a redirected file and calls and action with its FilePath" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            res <- runD $ do
+              loadMappedFile "File.hs" "File_Redir.hs"
+              withMappedFile "File.hs" return
+            res `shouldBe` "File_Redir.hs"
+        it "checks if there is an in-memory file and calls and action with temporary file" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            (fn, src) <- runD $ do
+              loadMappedFileSource "File.hs" "main = test"
+              withMappedFile "File.hs" $ \fn -> do
+                src <- liftIO $ readFile fn
+                return (fn, src)
+            fn `shouldSatisfy` (/="File.hs")
+            src `shouldBe` "main = test"
+        it "runs action with original filename if there is no mapping" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            fn <- runD $ do
+              withMappedFile "File.hs" return
+            fn `shouldBe` "File.hs"
+
+      describe "integration tests" $ do
+        it "checks redirected file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            let fm = [("File.hs", "File_Redir.hs")]
+            res <- run defaultOptions $ do
+              mapM_ (uncurry loadMappedFile) fm
+              checkSyntax ["File.hs"]
+            res `shouldBe` "File.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
+        it "checks in-memory file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            let fm = [("File.hs", "main = putStrLn \"Hello World!\"\n")]
+            res <- run defaultOptions $ do
+              mapM_ (uncurry loadMappedFileSource) fm
+              checkSyntax ["File.hs"]
+            res `shouldBe` "File.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
+        it "should work even if file doesn't exist" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            let fm = [("Nonexistent.hs", "main = putStrLn \"Hello World!\"\n")]
+            res <- run defaultOptions $ do
+              mapM_ (uncurry loadMappedFileSource) fm
+              checkSyntax ["Nonexistent.hs"]
+            res `shouldBe` "Nonexistent.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
+        it "lints redirected file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            res <- runD $ do
+              loadMappedFile "File.hs" "File_Redir_Lint.hs"
+              lint "File.hs"
+            res `shouldBe` "File.hs:4:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"
+        it "lints in-memory file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping" $ do
+            res <- runD $ do
+              loadMappedFileSource "File.hs" "func a b = (++) a b\n"
+              lint "File.hs"
+            res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL  func a b = (++) a b\NULWhy not:\NUL  func = (++)\n"
+        it "shows types of the expression for redirected files" $ do
+            let tdir = "test/data/file-mapping"
+            res <- runD' tdir $ do
+              loadMappedFile "File.hs" "File_Redir_Lint.hs"
+              types "File.hs" 4 12
+            res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n"
+        it "shows types of the expression for in-memory files" $ do
+            let tdir = "test/data/file-mapping"
+            res <- runD' tdir $ do
+              loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\""
+              types "File.hs" 1 14
+            res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n"
+        it "shows info for the expression for redirected files" $ do
+            let tdir = "test/data/file-mapping"
+            res <- runD' tdir $ do
+              loadMappedFile "File.hs" "File_Redir_Lint.hs"
+              info "File.hs" $ Expression "func"
+            res `shouldBe` "func :: Num a => a -> a -> a \t-- Defined at File.hs:4:1\n"
+        it "shows info for the expression for in-memory files" $ do
+            let tdir = "test/data/file-mapping"
+            res <- runD' tdir $ do
+              loadMappedFileSource "File.hs" "module File where\n\ntestfun = putStrLn \"Hello!\""
+              info "File.hs" $ Expression "testfun"
+            res `shouldBe` "testfun :: IO () \t-- Defined at File.hs:3:1\n"
+
+      describe "preprocessor tests" $ do
+        it "checks redirected file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping/preprocessor" $ do
+            let fm = [("File.hs", "File_Redir.hs")]
+            res <- run defaultOptions $ do
+              mapM_ (uncurry loadMappedFile) fm
+              checkSyntax ["File.hs"]
+            res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
+        it "checks in-memory file" $ do
+          withDirectory_ "test/data/file-mapping/preprocessor" $ do
+            src <- readFile "File_Redir.hs"
+            let fm = [("File.hs", src)]
+            res <- run defaultOptions $ do
+              mapM_ (uncurry loadMappedFileSource) fm
+              checkSyntax ["File.hs"]
+            res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
+        it "lints redirected file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping/preprocessor" $ do
+            res <- runD $ do
+              loadMappedFile "File.hs" "File_Redir_Lint.hs"
+              lint "File.hs"
+            res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"
+        it "lints in-memory file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping/preprocessor" $ do
+            src <- readFile "File_Redir_Lint.hs"
+            res <- runD $ do
+              loadMappedFileSource "File.hs" src
+              lint "File.hs"
+            res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"
+      describe "literate haskell tests" $ do
+        it "checks redirected file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping/lhs" $ do
+            let fm = [("File.lhs", "File_Redir.lhs")]
+            res <- run defaultOptions $ do
+              mapM_ (uncurry loadMappedFile) fm
+              checkSyntax ["File.lhs"]
+            res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n"
+        it "checks in-memory file if one is specified and outputs original filename" $ do
+          withDirectory_ "test/data/file-mapping/lhs" $ do
+            src <- readFile "File_Redir.lhs"
+            let fm = [("File.lhs", src)]
+            res <- run defaultOptions $ do
+              mapM_ (uncurry loadMappedFileSource) fm
+              checkSyntax ["File.lhs"]
+            res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n"
+        -- NOTE: There is a bug in hlint that prevents it from linting lhs files.
+        -- it "lints redirected file if one is specified and outputs original filename" $ do
+        --   withDirectory_ "test/data/file-mapping/lhs" $ do
+        --     res <- runD $ do
+        --       loadMappedFile "File.lhs" (RedirectedMapping "File_Redir_Lint.lhs")
+        --       lint "File.lhs"
+        --     res `shouldBe` "File.lhs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"
+        -- it "lints in-memory file if one is specified and outputs original filename" $ do
+        --   withDirectory_ "test/data/file-mapping/lhs" $ do
+        --     src <- readFile "File_Redir_Lint.lhs"
+        --     res <- runD $ do
+        --       loadMappedFile "File.lhs" (MemoryMapping $ Just src)
+        --       lint "File.lhs"
+        --     res `shouldBe` "File.lhs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"
+      describe "template haskell" $ do
+        it "works with a redirected module using TemplateHaskell" $ do
+          withSystemTempDirectory "ghc-mod-test" $ \tmpdir -> do
+            srcFoo <- readFile "test/data/template-haskell/Foo.hs"
+            srcBar <- readFile "test/data/template-haskell/Bar.hs"
+            withDirectory_ "test/data/file-mapping" $ do
+              writeFile (tmpdir </> "Foo_Redir.hs") srcFoo
+              writeFile (tmpdir </> "Bar_Redir.hs") srcBar
+              let fm = [("Foo.hs", tmpdir </> "Foo_Redir.hs")
+                       ,("Bar.hs", tmpdir </> "Bar_Redir.hs")]
+              res <- run defaultOptions $ do
+                mapM_ (uncurry loadMappedFile) fm
+                types "Bar.hs" 5 1
+              res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
+        it "works with a memory module using TemplateHaskell" $ do
+          srcFoo <- readFile "test/data/template-haskell/Foo.hs"
+          srcBar <- readFile "test/data/template-haskell/Bar.hs"
+          withDirectory_ "test/data/file-mapping" $ do
+            let fm = [("Foo.hs", srcFoo)
+                     ,("Bar.hs", srcBar)]
+            res <- run defaultOptions $ do
+              mapM_ (uncurry loadMappedFileSource) fm
+              types "Bar.hs" 5 1
+            res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]

test/FlagSpec.hs

@@ -4,6 +4,7 @@ import Control.Applicative
 import Language.Haskell.GhcMod
 import Test.Hspec
 import TestUtils
+import Prelude
 
 spec :: Spec
 spec = do

test/GhcPkgSpec.hs

@@ -1,20 +1,13 @@
 module GhcPkgSpec where
 
-import Control.Arrow
-import Control.Applicative
-import Distribution.Helper
 import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.CabalHelper
-import Language.Haskell.GhcMod.Error
+import Language.Haskell.GhcMod.CustomPackageDb
 import Test.Hspec
-import System.Directory
+import System.Process (system)
-import System.FilePath
-import System.Process (readProcess, system)
 
 import Dir
 import TestUtils
-import Data.List
 
 spec :: Spec
 spec = do

test/HomeModuleGraphSpec.hs

@@ -19,7 +19,7 @@
 module HomeModuleGraphSpec where
 
 import Language.Haskell.GhcMod.HomeModuleGraph
-import Language.Haskell.GhcMod.Target
+import Language.Haskell.GhcMod.LightGhc
 import TestUtils
 
 import GHC

test/InfoSpec.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP #-}
 module InfoSpec where
 
-import Control.Applicative ((<$>))
+import Control.Applicative
 import Data.List (isPrefixOf)
 import Language.Haskell.GhcMod
 #if __GLASGOW_HASKELL__ < 706
@@ -12,6 +12,7 @@ import System.Environment (getExecutablePath)
 import System.FilePath
 import Test.Hspec
 import TestUtils
+import Prelude
 
 spec :: Spec
 spec = do

test/LangSpec.hs

@@ -4,6 +4,7 @@ import Control.Applicative
 import Language.Haskell.GhcMod
 import Test.Hspec
 import TestUtils
+import Prelude
 
 spec :: Spec
 spec = do

test/ListSpec.hs

@@ -4,6 +4,7 @@ import Control.Applicative
 import Language.Haskell.GhcMod
 import Test.Hspec
 import TestUtils
+import Prelude
 
 spec :: Spec
 spec = do

test/Main.hs

@@ -36,16 +36,26 @@ main = do
                , "setup-config.ghc-mod.package-db-stack"
                , "ghc-mod.cache"
                ]
-      cachesFindExp :: String
+      findExp = unwords $ intersperse "-o " $ concat [
-      cachesFindExp = unwords $ intersperse "-o " $ map ("-name "++) caches
+                 stackWorkFindExp,
+                 cachesFindExp
+                ]
+      cachesFindExp = map ("-name "++) caches
+      stackWorkFindExp = ["-name .stack-work -type d"]
 
-      cleanCmd = "find test \\( "++ cachesFindExp ++" \\) -exec rm {} \\;"
+      cleanCmd = "find test \\( "++ findExp ++" \\) -exec rm -r {} \\;"
 
   putStrLn $ "$ " ++ cleanCmd
   void $ system cleanCmd
   void $ system "cabal --version"
   void $ system "ghc --version"
 
+  let stackDir = "test/data/stack-project"
+  void $ withDirectory_ stackDir $ do
+--    void $ system "stack init --force"
+    void $ system "stack setup"
+    void $ system "stack build"
+
   (putStrLn =<< runD debugInfo)
       `E.catch` (\(_ :: E.SomeException) -> return () )
 

test/MonadSpec.hs

@@ -9,7 +9,7 @@ spec = do
     describe "When using GhcModT in a do block" $
         it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do
              (a, _h)
-                 <- runGhcModT defaultOptions $
+                 <- runGmOutDef $ runGhcModT defaultOptions $
                        do
                          Just _ <- return Nothing
                          return "hello"

test/PathsAndFilesSpec.hs

@@ -1,7 +1,11 @@
 module PathsAndFilesSpec where
 
-import Language.Haskell.GhcMod.PathsAndFiles
 
+import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.Cradle
+import qualified Language.Haskell.GhcMod.Utils as U
+
+import Control.Monad.Trans.Maybe
 import System.Directory
 import System.FilePath
 import Test.Hspec
@@ -12,22 +16,33 @@ spec = do
     describe "getSandboxDb" $ do
         it "can parse a config file and extract the sandbox package-db" $ do
             cwd <- getCurrentDirectory
-            Just db <- getSandboxDb "test/data/cabal-project"
+            Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"
+            Just db <- getSandboxDb crdl
             db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
 
         it "returns Nothing if the sandbox config file is broken" $ do
-            getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing
+            Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox"
+            getSandboxDb crdl  `shouldReturn` Nothing
 
     describe "findCabalFile" $ do
         it "works" $ do
-            findCabalFile "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal"
+            p <- U.makeAbsolute' "test/data/cabal-project/cabalapi.cabal"
+            findCabalFile "test/data/cabal-project" `shouldReturn` Just p
 
         it "finds cabal files in parent directories" $ do
-            findCabalFile "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal"
+            p <- U.makeAbsolute' "test/data/cabal-project/cabalapi.cabal"
+            findCabalFile "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just p
+
+    describe "findStackConfigFile" $ do
+        it "works" $ do
+            p <- U.makeAbsolute' "test/data/stack-project/stack.yaml"
+            findStackConfigFile "test/data/stack-project" `shouldReturn` Just p
 
     describe "findCabalSandboxDir" $ do
         it "works" $ do
-            findCabalSandboxDir "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project"
+            p <- U.makeAbsolute' "test/data/cabal-project"
+            findCabalSandboxDir "test/data/cabal-project" `shouldReturn` Just p
 
         it "finds sandboxes in parent directories" $ do
-            findCabalSandboxDir "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project"
+            p <- U.makeAbsolute' "test/data/cabal-project"
+            findCabalSandboxDir "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just p

test/TargetSpec.hs

@@ -2,6 +2,7 @@
 module TargetSpec where
 
 import Language.Haskell.GhcMod.Target
+import Language.Haskell.GhcMod.LightGhc
 import Language.Haskell.GhcMod.Gap
 import Test.Hspec
 

test/TestUtils.hs

@@ -5,6 +5,7 @@ module TestUtils (
   , runD'
   , runE
   , runNullLog
+  , runGmOutDef
   , shouldReturnError
   , isPkgDbAt
   , isPkgConfDAt
@@ -18,14 +19,17 @@ import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.Types
 
 import Control.Arrow
+import Control.Category
 import Control.Applicative
 import Control.Monad.Error (ErrorT, runErrorT)
 import Control.Monad.Trans.Journal
 import Data.List.Split
+import Data.Label
 import Data.String
 import System.FilePath
 import System.Directory
 import Test.Hspec
+import Prelude hiding ((.))
 
 import Exception
 
@@ -39,12 +43,22 @@ extract action = do
     Right a ->  return a
     Left e -> error $ show e
 
-withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
+withSpecCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a
-withSpecCradle cradledir f =
+withSpecCradle cradledir f = do
-    gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f
+    gbracket (findSpecCradle cradledir) (liftIO . cleanupCradle) $ \crdl ->
+      bracketWorkingDirectory (cradleRootDir crdl) $
+        f crdl
 
-withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
+bracketWorkingDirectory ::
-withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f
+    (ExceptionMonad m, MonadIO m) => FilePath -> m c -> m c
+bracketWorkingDirectory dir a =
+    gbracket (swapWorkingDirectory dir) (liftIO . setCurrentDirectory) (const a)
+
+swapWorkingDirectory :: MonadIO m => FilePath -> m FilePath
+swapWorkingDirectory ndir = liftIO $ do
+  odir <- getCurrentDirectory >>= canonicalizePath
+  setCurrentDirectory $ ndir
+  return odir
 
 runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
 runGhcModTSpec opt action = do
@@ -53,10 +67,11 @@ runGhcModTSpec opt action = do
 
 runGhcModTSpec' :: IOish m
     => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
-runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
+runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
-    withGhcModEnvSpec dir' opt $ \env -> do
+  runGmOutT opt $
-      first (fst <$>) <$> runGhcModT'' env defaultGhcModState
+    withGhcModEnv' withSpecCradle dir' opt $ \env -> do
-        (gmSetLogLevel (logLevel opt) >> action)
+      first (fst <$>) <$> runGhcModT' env defaultGhcModState
+        (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
 
 -- | Run GhcMod
 run :: Options -> GhcModT IO a -> IO a
@@ -65,11 +80,14 @@ run opt a = extract $ runGhcModTSpec opt a
 -- | Run GhcMod with default options
 runD :: GhcModT IO a -> IO a
 runD =
-    extract . runGhcModTSpec defaultOptions { logLevel = testLogLevel }
+    extract . runGhcModTSpec (setLogLevel testLogLevel defaultOptions)
 
 runD' :: FilePath -> GhcModT IO a -> IO a
 runD' dir =
-    extract . runGhcModTSpec' dir defaultOptions { logLevel = testLogLevel }
+    extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions)
+
+setLogLevel :: GmLogLevel -> Options -> Options
+setLogLevel = set (lOoptLogLevel . lOptOutput)
 
 runE :: ErrorT e IO a -> IO (Either e a)
 runE = runErrorT
@@ -80,6 +98,9 @@ runNullLog action = do
   liftIO $ print w
   return a
 
+runGmOutDef :: IOish m => GmOutT m a -> m a
+runGmOutDef = runGmOutT defaultOptions
+
 shouldReturnError :: Show a
                   => IO (Either GhcModError a, GhcModLog)
                   -> Expectation

test/data/file-mapping/File.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Hello World!"

test/data/file-mapping/File_Redir.hs

@@ -0,0 +1 @@
+main = putStrLn "Hello World!"

test/data/file-mapping/File_Redir_Lint.hs

@@ -0,0 +1,4 @@
+module File where
+
+func :: Num a => a -> a -> a
+func a b = (*) a b

test/data/file-mapping/lhs/File.lhs

@@ -0,0 +1,2 @@
+> main :: IO ()
+> main = putStrLn "Hello World!"

test/data/file-mapping/lhs/File_Redir.lhs

@@ -0,0 +1 @@
+> main = putStrLn "Hello World!"

test/data/file-mapping/lhs/File_Redir_Lint.lhs

@@ -0,0 +1,4 @@
+> module File where
+
+> func :: Num a => a -> a -> a
+> func a b = (*) a b

test/data/file-mapping/preprocessor/File.hs

@@ -0,0 +1,7 @@
+{-# LANGUAGE CPP #-}
+#ifndef NOTHING
+main :: IO ()
+main = putStrLn "Hello World!"
+#else
+INVALID
+#endif

test/data/file-mapping/preprocessor/File_Redir.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE CPP #-}
+#ifndef NOTHING
+main = putStrLn "Hello World!"
+#else
+INVALID
+#endif

test/data/file-mapping/preprocessor/File_Redir_Lint.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE CPP #-}
+#ifndef NOTHING
+module File where
+
+func :: Num a => a -> a -> a
+func a b = (*) a b
+#else
+INVALID
+#endif

test/data/nice-qualification/NiceQualification.hs

@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = "wrong type"

test/data/stack-project/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

test/data/stack-project/app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Lib
+
+main :: IO ()
+main = someFunc

test/data/stack-project/new-template.cabal

@@ -0,0 +1,42 @@
+name:                new-template
+version:             0.1.0.0
+synopsis:            Initial project template from stack
+description:         Please see README.md
+homepage:            http://github.com/name/project
+-- license:             BSD3
+-- license-file:        LICENSE
+author:              Your name here
+maintainer:          your.address@example.com
+-- copyright:
+category:            Web
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Lib
+  build-depends:       base >= 4.7 && < 5
+  default-language:    Haskell2010
+
+executable new-template-exe
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , new-template
+                     , bytestring
+  default-language:    Haskell2010
+
+test-suite new-template-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:       base
+                     , new-template
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/name/project

test/data/stack-project/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

test/data/stack-project/stack.yaml

@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps: []
+resolver: lts-2.17

test/data/stack-project/test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"