ghc-mod 5.3.0.0 → 5.4.0.0

raw patch · 82 files changed

+2431/−963 lines, 82 filesdep +extradep +pipesdep ~basedep ~cabal-helperdep ~doctestPVP ok

version bump matches the API change (PVP)

Dependencies added: extra, pipes

Dependency ranges changed: base, cabal-helper, doctest, haskell-src-exts, hspec

API changes (from Hackage documentation)

Files

• ChangeLog +19/−1
• Language/Haskell/GhcMod.hs +7/−3
• Language/Haskell/GhcMod/Browse.hs +4/−4
• Language/Haskell/GhcMod/CabalHelper.hs +145/−82
• Language/Haskell/GhcMod/Caching/Types.hs +2/−2
• Language/Haskell/GhcMod/CaseSplit.hs +7/−5
• Language/Haskell/GhcMod/Convert.hs +53/−53
• Language/Haskell/GhcMod/Cradle.hs +69/−21
• Language/Haskell/GhcMod/CustomPackageDb.hs +25/−0
• Language/Haskell/GhcMod/Debug.hs +18/−5
• Language/Haskell/GhcMod/DebugLogger.hs +90/−0
• Language/Haskell/GhcMod/DynFlags.hs +11/−5
• Language/Haskell/GhcMod/Error.hs +13/−46
• Language/Haskell/GhcMod/FileMapping.hs +72/−0
• Language/Haskell/GhcMod/FillSig.hs +28/−23
• Language/Haskell/GhcMod/Gap.hs +62/−33
• Language/Haskell/GhcMod/GhcPkg.hs +18/−2
• Language/Haskell/GhcMod/HomeModuleGraph.hs +20/−14
• Language/Haskell/GhcMod/Info.hs +9/−7
• Language/Haskell/GhcMod/Internal.hs +4/−0
• Language/Haskell/GhcMod/LightGhc.hs +44/−0
• Language/Haskell/GhcMod/Lint.hs +10/−2
• Language/Haskell/GhcMod/Logger.hs +80/−56
• Language/Haskell/GhcMod/Logging.hs +2/−2
• Language/Haskell/GhcMod/Modules.hs +3/−3
• Language/Haskell/GhcMod/Monad.hs +51/−42
• Language/Haskell/GhcMod/Monad/Types.hs +191/−68
• Language/Haskell/GhcMod/Output.hs +128/−98
• Language/Haskell/GhcMod/PathsAndFiles.hs +41/−25
• Language/Haskell/GhcMod/PkgDoc.hs +5/−3
• Language/Haskell/GhcMod/Pretty.hs +6/−1
• Language/Haskell/GhcMod/Stack.hs +90/−0
• Language/Haskell/GhcMod/Target.hs +90/−81
• Language/Haskell/GhcMod/Types.hs +94/−66
• Language/Haskell/GhcMod/Utils.hs +65/−4
• Language/Haskell/GhcMod/World.hs +3/−0
• NotCPP/COPYING +30/−0
• elisp/Makefile +12/−5
• elisp/ghc-check.el +14/−14
• elisp/ghc-command.el +3/−3
• elisp/ghc-comp.el +2/−2
• elisp/ghc-doc.el +33/−13
• elisp/ghc-func.el +16/−12
• elisp/ghc-indent.el +2/−2
• elisp/ghc-info.el +1/−1
• elisp/ghc-ins-mod.el +1/−1
• elisp/ghc-process.el +80/−46
• elisp/ghc-rewrite.el +3/−6
• elisp/ghc.el +10/−6
• ghc-mod.cabal +30/−9
• src/GHCMod.hs +145/−55
• src/Misc.hs +5/−4
• test/BrowseSpec.hs +4/−3
• test/CheckSpec.hs +9/−0
• test/CustomPackageDbSpec.hs +35/−0
• test/FileMappingSpec.hs +240/−0
• test/FlagSpec.hs +1/−0
• test/HomeModuleGraphSpec.hs +1/−1
• test/InfoSpec.hs +2/−1
• test/LangSpec.hs +1/−0
• test/ListSpec.hs +1/−0
• test/Main.hs +13/−3
• test/MonadSpec.hs +1/−1
• test/PathsAndFilesSpec.hs +21/−6
• test/TestUtils.hs +32/−11
• test/data/file-mapping/File.hs +2/−0
• test/data/file-mapping/File_Redir.hs +1/−0
• test/data/file-mapping/File_Redir_Lint.hs +4/−0
• test/data/file-mapping/lhs/File.lhs +2/−0
• test/data/file-mapping/lhs/File_Redir.lhs +1/−0
• test/data/file-mapping/lhs/File_Redir_Lint.lhs +4/−0
• test/data/file-mapping/preprocessor/File.hs +7/−0
• test/data/file-mapping/preprocessor/File_Redir.hs +6/−0
• test/data/file-mapping/preprocessor/File_Redir_Lint.hs +9/−0
• test/data/nice-qualification/NiceQualification.hs +4/−0
• test/data/stack-project/Setup.hs +2/−0
• test/data/stack-project/app/Main.hs +6/−0
• test/data/stack-project/new-template.cabal +42/−0
• test/data/stack-project/src/Lib.hs +6/−0
• test/data/stack-project/stack.yaml +5/−0
• test/data/stack-project/test/Spec.hs +2/−0
• test/doctests.hs +1/−1

@@ -1,9 +1,27 @@+2015-09-16 v5.4.0.0+	* Add support for the Stack build tool+	* Fix #554, `module not interpreted` errors when using the `type`+	  command+	* Merge #484, support for file redirection+	* Add support for file redirection to Emacs frontend so+	  all commands should work even with unsaved files now!+	* Support inserting holes in type signatures+	* Merge #543, Fix URL anchors being dropped in OS X+	* Fix GHC session always being dropped in interactive mode (caused+	  super slowness)+	* Expose all internal modules because API will get a major+	  redesign soon anyways+        * ghc-mod(i) executable must now be run in project directory for+          commands other than `root`+        * Add --line-prefix option for multiplexing stdout/err onto one stream+ 2015-08-14 v5.3.0.0 	* Re-license majority of code under the AGPL-3 	* Add support for GHC 7.10 and Cabal 1.22 	* Remove `cabalDependPackages', `cabalAllTargets' 	* Merge #434, Fix finding sandbox config file and directory.-	* Merge #431, Re-add output line separator global option for expand command.+	* Merge #431, Re-add output line separator global option for expand+          command. 	* Merge #470, Support for overriding the package-db stack 	* Merge #486, Fix ineffective cache invalidation for `find` 

@@ -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 @@   , gmErrStr   , gmPutStrLn   , gmErrStrLn-  , gmUnsafePutStrLn-  , gmUnsafeErrStrLn+  -- * FileMapping+  , loadMappedFile+  , loadMappedFileSource+  , unloadMappedFile   ) where  import Language.Haskell.GhcMod.Boot@@ -84,3 +87,4 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Output+import Language.Haskell.GhcMod.FileMapping

@@ -80,7 +80,7 @@ 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 @@   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"

@@ -20,7 +20,6 @@   ( getComponents   , getGhcMergedPkgOptions   , getCabalPackageDbStack-  , getCustomPkgDbStack   , prepareCabalHelper   ) #endif@@ -33,42 +32,45 @@ 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,-                                             cabalProgram)+import Language.Haskell.GhcMod.Types 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,-  cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do-    readProc <- gmReadProcess-    opts <- withCabal $ runQuery'' readProc progs rootdir distdir $-                ghcMergedPkgOptions-    return ([setupConfigPath], opts)+  cacheFile = mergedPkgOptsCacheFile distdir,+  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do+    opts <- withCabal $ runCHQuery ghcMergedPkgOptions+    return ([setupConfigPath distdir], opts)  } -getCabalPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb]-getCabalPackageDbStack = chCached Cached {+getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]+getCabalPackageDbStack = chCached $ \distdir -> Cached {   cacheLens = Just (lGmcPackageDbStack . lGmCaches),-  cacheFile = pkgDbStackCacheFile,-  cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do-    readProc <- gmReadProcess-    dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery'' readProc progs rootdir distdir packageDbStack-    return ([setupConfigPath, sandboxConfigFile], dbs)+  cacheFile = pkgDbStackCacheFile distdir,+  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do+    crdl <- cradle+    dbs <- withCabal $ map chPkgToGhcPkg <$>+             runCHQuery packageDbStack+    return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)  }  chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb@@ -81,14 +83,13 @@ -- -- 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,-    cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> do-      readProc <- gmReadProcess-      runQuery'' readProc progs rootdir distdir $ do+    cacheFile = cabalHelperCacheFile distdir,+    cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do+      runCHQuery $ do         q <- join7                <$> ghcOptions                <*> ghcPkgOptions@@ -98,7 +99,7 @@                <*> 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 @@                  , (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]-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 :: (IOish m, GmEnv m, GmOut 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-    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)+    mCabalFile          <- liftIO $ timeFile `traverse` cradleCabalFile 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 $-                 map chPkgToGhcPkg <$> packageDbStack+             let qe = (defaultQueryEnv projdir distdir) {+                          qeReadProcess = readProc+                        , qePrograms = helperProgs $ optPrograms opts+                        }+             pkgDb <- runQuery qe $ map chPkgToGhcPkg <$> packageDbStack              return $ pkgDb /= cusPkgDbStack             Nothing -> return False -    cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack--    --TODO: also invalidate when sandboxConfig file changed+    proj <- cradleProject <$> cradle      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) $-        withDirectory_ (cradleRootDir crdl) $ do-            let progOpts =-                    [ "--with-ghc=" ++ T.ghcProgram opts ]-                    -- Only pass ghc-pkg if it was actually set otherwise we-                    -- might break cabal's guessing logic-                    ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions-                         then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]-                         else []-                    ++ map pkgDbArg cusPkgStack-            liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) ""-            gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"-            liftIO $ writeAutogenFiles readProc projdir distdir+    when ( isSetupConfigOutOfDate mCabalFile mCabalConfig+        || pkgDbStackOutOfSync+        || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $+          case proj of+            CabalProject ->+                cabalReconfigure readProc (optPrograms opts) crdl projdir distdir+            StackProject {} ->++                stackReconfigure crdl (optPrograms opts)+            _ ->+                error $ "withCabal: unsupported project type: " ++ show proj+     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 @@ --   @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 worldCabalFile worldCabalConfig = do   worldCabalConfig < worldCabalFile --helperProgs :: Options -> Programs-helperProgs opts = Programs {-                            cabalProgram  = T.cabalProgram opts,-                            ghcProgram    = T.ghcProgram opts,-                            ghcPkgProgram = T.ghcPkgProgram opts-                          }+helperProgs :: Programs -> CH.Programs+helperProgs progs = CH.Programs {+    cabalProgram  = T.cabalProgram progs,+    ghcProgram    = T.ghcProgram progs,+    ghcPkgProgram = T.ghcPkgProgram progs+  } -chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a)-  => Cached m GhcModState ChCacheData a -> m a+chCached :: (Applicative m, IOish m, Gm m, Serialize a)+  => (FilePath -> Cached m GhcModState ChCacheData a) -> m a chCached c = do-  root <- cradleRootDir <$> cradle-  d <- cacheInputData root-  withCabal $ cached root c d+  projdir <- cradleRootDir <$> cradle+  distdir <- (projdir </>) . cradleDistDir <$> cradle+  d <- cacheInputData projdir+  withCabal $ cached projdir (c distdir) d  where-   cacheInputData root = do-               opt <- options-               return $ ( helperProgs opt-                        , root-                        , root </> "dist"+   -- we don't need to include the disdir in the cache input because when it+   -- changes the cache files will be gone anyways ;)+   cacheInputData projdir = do+               opts <- options+               crdl <- cradle+               progs' <- patchStackPrograms crdl (optPrograms opts)+               return $ ( helperProgs progs'+                        , projdir                         , (gmVer, chVer)                         ) 

@@ -47,6 +47,6 @@   -- ^ '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]))

@@ -9,6 +9,7 @@ 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.Doc import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)  ---------------------------------------------------------------- -- CASE SPLITTING@@ -47,12 +49,12 @@        -> 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)-      whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of+      modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)+      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 @@           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

@@ -25,99 +25,99 @@ 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 opt@Options { outputStyle = LispStyle  } x = toLisp opt x "\n"-convert opt@Options { outputStyle = PlainStyle } x+convert :: ToString a => OutputOpts -> a -> String+convert opt@OutputOpts { ooptStyle = LispStyle  } x = toLisp opt x "\n"+convert opt@OutputOpts { ooptStyle = PlainStyle } x   | str == "\n" = ""   | otherwise   = str   where     str = toPlain opt x "\n"  class ToString a where-  toLisp  :: Options -> a -> Builder-  toPlain :: Options -> a -> Builder+  toLisp  :: OutputOpts -> a -> Builder+  toPlain :: OutputOpts -> a -> Builder -lineSep :: Options -> String-lineSep opt = interpret lsep+lineSep :: OutputOpts -> String+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-  toPlain opt = replace '\n' (lineSep opt)+  toLisp  oopts = quote oopts+  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-  toPlain opt = inter '\n' . map (toPlain opt)+  toLisp  oopts = toSexp1 oopts+  toPlain oopts = inter '\n' . map (toPlain oopts)  instance ToString [ModuleString] where-  toLisp  opt = toLisp opt . map getModuleString-  toPlain opt = toPlain opt . map getModuleString+  toLisp  oopts = toLisp oopts . 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 . (')' :)-  toPlain opt = inter '\n' . map (tupToString opt)+      toS x = ('(' :) . tupToString oopts x . (')' :)+  toPlain oopts = inter '\n' . map (tupToString oopts)  instance ToString ((Int,Int,Int,Int),String) where-  toLisp  opt x = ('(' :) . tupToString opt x . (')' :)-  toPlain opt x = tupToString opt x+  toLisp  oopts x = ('(' :) . tupToString oopts x . (')' :)+  toPlain oopts x = tupToString oopts x  instance ToString ((Int,Int,Int,Int),[String]) where-  toLisp  opt (x,s) = ('(' :) . fourIntsToString opt x .-                      (' ' :) . toLisp opt s . (')' :)-  toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s+  toLisp  oopts (x,s) = ('(' :) .  fourIntsToString x .+                        (' ' :) . toLisp oopts 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]-  toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]+  toLisp  oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y]+  toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y] -toSexp1 :: Options -> [String] -> Builder-toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)+toSexp1 :: OutputOpts -> [String] -> Builder+toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)  toSexp2 :: [Builder] -> Builder toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) -fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder-fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)-                             . (show b ++) . (' ' :)-                             . (show c ++) . (' ' :)-                             . (show d ++)+fourIntsToString :: (Int,Int,Int,Int) -> Builder+fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)+                           . (show b ++) . (' ' :)+                           . (show c ++) . (' ' :)+                           . (show d ++) -tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder-tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)-                              . (show b ++) . (' ' :)-                              . (show c ++) . (' ' :)-                              . (show d ++) . (' ' :)-                              . quote opt s -- fixme: quote is not necessary+tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder+tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)+                                . (show b ++) . (' ' :)+                                . (show c ++) . (' ' :)+                                . (show d ++) . (' ' :)+                                . quote oopts s -- fixme: quote is not necessary -quote :: Options -> String -> Builder-quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)+quote :: OutputOpts -> String -> Builder+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 @@ ----------------------------------------------------------------  -- Empty result to be returned when no info can be gathered-emptyResult :: Monad m => Options -> m String-emptyResult opt = return $ convert opt ([] :: [String])+emptyResult :: Monad m => OutputOpts -> m 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 opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from+whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String+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' opt from f = maybe (emptyResult opt) (\x -> do y <- f x ; return (convert opt y)) =<< from+whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String+whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from

@@ -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 @@ --   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 = findCradle' =<< getCurrentDirectory+findCradle :: (IOish m, GmOut m) => m Cradle+findCradle = findCradle' =<< liftIO getCurrentDirectory -findCradle' :: FilePath -> IO Cradle-findCradle' dir = run $ do-    (cabalCradle dir `mplus`  sandboxCradle dir `mplus` plainCradle dir)+findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle+findCradle' dir = run $+    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 = do-     not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")+   isNotGmCradle crdl =+     liftIO $ 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+stackCradle wdir = do+    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 {+        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 $ findCabalSandboxDir wdir+    sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir     return Cradle {-        cradleProjectType = SandboxProject+        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"       }

@@ -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

@@ -8,13 +8,14 @@ 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 @@     Cradle {..} <- cradle      cabal <--        case cradleProjectType of+        case cradleProject of           CabalProject -> cabalDebug+          StackProject {} -> (++) <$> stackPaths <*> cabalDebug           _ -> return []      pkgOpts <- packageGhcOptions@@ -38,9 +40,19 @@               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 @@      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 @@ ----------------------------------------------------------------  -- | Obtaining root information.-rootInfo :: IOish m => GhcModT m String-rootInfo = convert' =<< cradleRootDir <$> cradle+rootInfo :: (IOish m, GmOut m) => m String+rootInfo = (++"\n") . cradleRootDir <$> findCradle

@@ -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'

@@ -3,19 +3,24 @@ module Language.Haskell.GhcMod.DynFlags where  import Control.Applicative-import Control.Monad (void)-import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..))+import Control.Monad+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 -- * Not friendly to -XTemplateHaskell and -XPatternSynonyms@@ -99,4 +104,5 @@  deferErrors :: DynFlags -> Ghc DynFlags deferErrors df = return $-  Gap.setWarnTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df+  Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $+  Gap.setDeferTypeErrors $ setNoWarningFlags df

@@ -17,7 +17,6 @@ {-# LANGUAGE ExistentialQuantification #-} module Language.Haskell.GhcMod.Error (     GhcModError(..)-  , GMConfigStateFileError(..)   , GmError   , gmeDoc   , ghcExceptionDoc@@ -33,7 +32,7 @@   , 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 @@  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 @@     GMEString msg ->         text msg     GMECabalConfigure msg ->-        text "Configuring cabal project failed: " <> gmeDoc msg-    GMECabalFlags msg ->-        text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg-    GMECabalComponent cn ->-        text "Cabal component " <> quotes (gmComponentNameDoc cn)-                                <> text " could not be found."+        text "Configuring cabal project failed" <+>: gmeDoc msg+    GMEStackConfigure msg ->+        text "Configuring stack project failed" <+>: gmeDoc msg+    GMEStackBootstrap msg ->+        text "Bootstrapping stack project environment failed" <+>: gmeDoc msg     GMECabalCompAssignment ctx ->         text "Could not find a consistent component assignment for modules:" $$           (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$@@ -125,21 +92,23 @@         compsDoc sc | Set.null sc = text "has no known components"         compsDoc sc = fsep $ punctuate comma $                         map gmComponentNameDoc $ Set.toList sc--    GMEProcess cmd args emsg -> let c = showCommandForUser cmd args in+    GMEProcess _fn 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 ->-        gmCsfeDoc csfe+    GMEWrongWorkingDirectory projdir cdir ->+        (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 e = text $ showGhcException e "" - liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a liftMaybe e action = maybe (throwError e) return =<< action @@ -174,7 +142,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

@@ -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'

@@ -9,15 +9,27 @@  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.Pretty (showDoc) import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Types-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 Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)  #if __GLASGOW_HASKELL__ >= 710 import GHC (unLoc)@@ -73,11 +78,11 @@     -> 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-      whenFound opt (getSignature modSum lineNo colNo) $ \s ->+      modSum <- fileModSummaryWithMapping file+      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 @@             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 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 @@              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 @@      -> 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 @@                  , 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]

@@ -4,16 +4,18 @@     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 @@   , lookupModulePackageInAllPackages   , Language.Haskell.GhcMod.Gap.isSynTyCon   , parseModuleHeader+  , mkErrStyle'   ) where  import Control.Applicative hiding (empty)@@ -67,6 +70,7 @@ 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 #endif -setLogAction :: DynFlags-             -> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ())-             -> DynFlags+#if __GLASGOW_HASKELL__ >= 706+type GmLogAction = LogAction+#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 @@         (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)     return ms -withContext :: GhcMonad m => m a -> m a-withContext action = gbracket setup teardown body+withInteractiveContext :: GhcMonad m => m a -> m a+withInteractiveContext action = gbracket setup teardown body   where     setup = getContext     teardown = setCtx@@ -220,32 +228,24 @@         topImports >>= setCtx         action     topImports = do-        mss <- getModuleGraph-        mns <- map modName <$> filterM isTop mss-        let ii = map IIModule mns+        ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph+        let iis = map (IIModule . modName) ms #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 = 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 @@   where     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -infoThing :: GhcMonad m => Expression -> m SDoc-infoThing (Expression str) = do+infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc+infoThing m (Expression str) = do     names <- parseName str #if __GLASGOW_HASKELL__ >= 708     mb_stuffs <- mapM (getInfo False) names@@ -338,30 +345,45 @@     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 _ (thing, fixity, insts, famInsts)-    = pprTyThingInContextLoc thing+pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc+pprInfo m _ (thing, fixity, insts, famInsts)+    = 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 pefas (thing, fixity, insts)-    = pprTyThingInContextLoc pefas thing+pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc+pprInfo m pefas (thing, fixity, insts)+    = 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 @@      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

@@ -6,6 +6,7 @@   , ghcDbOpt   , getPackageDbStack   , getPackageCachePaths+  , getGhcPkgProgram   ) where  import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)@@ -21,6 +22,8 @@ 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 @@  ---------------------------------------------------------------- +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]

@@ -54,12 +54,14 @@ 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 @@ 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 @@    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 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 @@             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 @@                    $ 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-    let env' = env { hsc_dflags = setDf (hsc_dflags env) }-    preprocess env' (file, Nothing)+  withLogger' env $ \setDf -> do+    withMappedFile file $ \fn -> do+      let env' = env { hsc_dflags = setDf (hsc_dflags env) }+      liftIO $ preprocess env' (fn, Nothing) -fileModuleName ::-  HscEnv -> FilePath -> IO (Either [String] (Maybe ModuleName))-fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do+fileModuleName :: (IOish m, GmEnv m, GmState m) =>+  HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))+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-            return $ Left $ errBagToStrList env errs+          Left errs -> return $ Left 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)

@@ -3,7 +3,6 @@   , 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.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 file expr =   ghandle handler $     runGmlT' [Left file] deferErrors $-      withContext $-        convert <$> options <*> body+      withInteractiveContext $ do+        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 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

@@ -40,6 +40,7 @@   , cradle   , getCompilerMode   , setCompilerMode+  , targetGhcOptions   , withOptions   -- * 'GhcModError'   , gmeDoc@@ -56,6 +57,8 @@   -- * Misc stuff   , GHandler(..)   , gcatches+  -- * FileMapping+  , module Language.Haskell.GhcMod.FileMapping   ) where  import GHC.Paths (libdir)@@ -70,6 +73,7 @@ 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

@@ -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

@@ -8,6 +8,10 @@ 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 @@      -> 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)

@@ -8,14 +8,17 @@  import Control.Arrow import Control.Applicative-import Data.List (isPrefixOf)-import Data.Maybe (fromMaybe)+import Data.Ord+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 GHC (DynFlags, SrcSpan, Severity(SevError))+import ErrUtils+import GHC import HscTypes import Outputable import qualified GHC as G@@ -26,6 +29,7 @@ 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 @@  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 @@     writeIORef ref emptyLog     return $ b [] -appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update+appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()+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---   executes a body. Logged messages are returned as 'String'.+-- | 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-  let conv = convert opts+  oopts <- outputOpts+  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-        pu = icPrintUnqual dflags (hsc_IC env)-        st = mkUserStyle pu AllTheWay+    rfm <- mkRevRedirMapFunc -        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)--  where-    setLogger logref df = Gap.setLogAction df $ appendLogRef df logref-    handlers df st = [-        GHandler $ \ex -> return $ Left $ sourceError df st ex,-        GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]-     ]+    return ((,) ls <$> a) -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+errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]+errBagToStrList env errs = do+   rfm <- mkRevRedirMapFunc+   return $ runReader+    (errsToStr (sortMsgBag errs))+    GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }  ----------------------------------------------------------------  -- | Converting 'SourceError' to 'String'.-sourceError :: DynFlags -> PprStyle -> SourceError -> [String]-sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err+sourceError :: SourceError -> GmPprEnvM [String]+sourceError = errsToStr . sortMsgBag . srcErrorMessages -errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String]-errsToStr df st = map (ppErrMsg df st)+errsToStr :: [ErrMsg] -> GmPprEnvM [String]+errsToStr = mapM ppErrMsg +sortMsgBag :: Bag ErrMsg -> [ErrMsg]+sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag+ ---------------------------------------------------------------- -ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String-ppErrMsg dflag st err =-    ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext)+ppErrMsg :: ErrMsg -> GmPprEnvM String+ppErrMsg err = do+    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 spn sev dflag st msg = prefix ++ cts-  where-    cts  = showPage dflag st msg-    prefix = ppMsgPrefix spn sev dflag st cts+ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String+ppMsg st spn sev msg = do+  dflags <- asks gpeDynFlags+  let cts  = showPage dflags st msg+  prefix <- ppMsgPrefix spn sev cts+  return $ prefix ++ cts -ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String-ppMsgPrefix spn sev dflag _st cts =+ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String+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-        (line,col,_,_) <- Gap.getSrcSpan spn-        file <- normalise <$> Gap.getSrcFile spn-        let severityCaption = Gap.showSeverityCaption sev-            pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)-                              = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"-                  | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption-        return pref0+  return $ fromMaybe defaultPrefix $ do+    (line,col,_,_) <- Gap.getSrcSpan spn+    file <- mr <$> normalise <$> Gap.getSrcFile spn+    let severityCaption = Gap.showSeverityCaption sev+        pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)+                          = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"+              | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption+    return pref0  checkErrorPrefix :: String checkErrorPrefix = "Dummy:0:0:Error:"

@@ -65,7 +65,7 @@ -- 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 @@    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 

@@ -14,13 +14,13 @@ ----------------------------------------------------------------  -- | 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

@@ -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.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-withCradle cradledir f =-    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, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a+withGhcModEnv = withGhcModEnv' withCradle+ where+   withCradle dir =+       gbracket (findCradle' dir) (liftIO . cleanupCradle) -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)+withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> (Cradle -> m a) -> m a) -> FilePath -> Options -> (GhcModEnv -> m a) -> m a+withGhcModEnv' withCradle dir opts f =+    withCradle dir $ \crdl ->+      withCradleRootDir crdl $+        f $ GhcModEnv opts crdl  where-   setup c = liftIO $ do-     setCurrentDirectory $ cradleRootDir crdl-     forkIO $ stdoutGateway c+   withCradleRootDir (cradleRootDir -> projdir) a = do+       cdir <- liftIO $ getCurrentDirectory+       eq <- liftIO $ pathsEqual projdir cdir+       if not eq+          then throw $ GMEWrongWorkingDirectory projdir cdir+          else a -   teardown olddir tid = liftIO $ do-     setCurrentDirectory olddir-     killThread tid+   pathsEqual a b = do+     ca <- canonicalizePath a+     cb <- canonicalizePath b+     return $ ca == cb -   gbracket_ ma mb mc = gbracket ma mb (const mc)+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-    dir <- liftIO getCurrentDirectory-    runGhcModT' dir opt action--runGhcModT' :: IOish m-            => 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)+runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do+    runGmOutT opt $+      withGhcModEnv dir' opt $ \env ->+        first (fst <$>) <$> runGhcModT' env defaultGhcModState+          (gmSetLogLevel (ooptLogLevel $ optOutput 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 @@     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)-runGhcModT'' r s a = do-  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s+             -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)+runGhcModT' r s a = do+  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)

@@ -22,7 +22,9 @@  module Language.Haskell.GhcMod.Monad.Types (   -- * Monad Types-    GhcModT(..)+    GhcModT+  , GmOutT(..)+  , GmT(..)   , GmlT(..)   , LightGhc(..)   , GmGhc@@ -43,11 +45,19 @@   , 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 Data.Monoid (Monoid) #endif +import qualified Data.Map as M import Data.Maybe import Data.Monoid import Data.IORef@@ -106,21 +117,29 @@  import qualified MonadUtils as GHC (MonadIO(..)) --- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'--- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that--- means you can run (almost) all functions from the GHC API on top of 'GhcModT'--- transparently.------ The inner monad @m@ should have instances for 'MonadIO' and--- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@--- monads already have 'MonadBaseControl' 'IO' instances, see the--- @monad-control@ package.-newtype GhcModT m a = GhcModT {-      unGhcModT :: StateT GhcModState-                     (ErrorT GhcModError-                       (JournalT GhcModLog-                         (ReaderT GhcModEnv m) ) ) a+type GhcModT m = GmT (GmOutT m)++newtype GmOutT m a = GmOutT {+      unGmOutT :: ReaderT GhcModOut m a     } deriving ( Functor+             , Applicative+             , Alternative+             , Monad+             , MonadPlus+             , MonadTrans+             , MTL.MonadIO+#if DIFFERENT_MONADIO+             , GHC.MonadIO+#endif+             , GmLog+             )++newtype GmT m a = GmT {+      unGmT :: StateT GhcModState+                 (ErrorT GhcModError+                   (JournalT GhcModLog+                     (ReaderT GhcModEnv m) ) ) a+    } deriving ( Functor                , Applicative                , Alternative                , Monad@@ -138,7 +157,6 @@              , Alternative              , Monad              , MonadPlus-             , MonadTrans              , MTL.MonadIO #if DIFFERENT_MONADIO              , GHC.MonadIO@@ -159,6 +177,9 @@ #endif              ) +--------------------------------------------------+-- Miscellaneous instances+ #if DIFFERENT_MONADIO instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where     liftIO = MTL.liftIO@@ -184,13 +205,26 @@     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 @@     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-    gmeAsk = GhcModT ask-    gmeReader = GhcModT . reader-    gmeLocal f a = GhcModT $ local f (unGhcModT a)+instance GmEnv m => GmEnv (GmOutT m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    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 @@       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-    gmsGet = GhcModT get-    gmsPut = GhcModT . put-    gmsState = GhcModT . state+instance Monad m => GmState (GmT m) where+    gmsGet = GmT get+    gmsPut = GmT . put+    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 @@     gmlHistory = history     gmlClear   = clear -instance Monad m => GmLog (GhcModT m) where-    gmlJournal = GhcModT . lift . lift . journal-    gmlHistory = GhcModT $ lift $ lift history-    gmlClear   = GhcModT $ lift $ lift clear+instance Monad m => GmLog (GmT m) where+    gmlJournal = GmT . lift . lift . journal+    gmlHistory = GmT $ lift $ lift history+    gmlClear   = GmT $ lift $ lift clear  instance (Monad m, GmLog m) => GmLog (ReaderT r m) where     gmlJournal = lift . gmlJournal@@ -268,19 +322,32 @@     gmlHistory = lift gmlHistory     gmlClear = lift gmlClear -instance Monad m => MonadJournal GhcModLog (GhcModT m) where-  journal !w = GhcModT $ lift $ lift $ (journal w)-  history    = GhcModT $ lift $ lift $ history-  clear      = GhcModT $ lift $ lift $ clear+-- GmOut -----------------------------------------+class Monad m => GmOut m where+    gmoAsk :: m GhcModOut -instance MonadTrans GhcModT where-    lift = GhcModT . lift . lift . lift . lift+instance Monad m => GmOut (GmOutT m) where+    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 @@      pass maww = maww >>= gmLiftInner . pass . return -instance MonadState s m => MonadState s (GhcModT m) where-    get = GhcModT $ lift $ lift $ lift get-    put = GhcModT . lift . lift . lift . put-    state = GhcModT . lift . lift . lift . state+instance MonadState s m => MonadState s (GmT m) where+    get = GmT $ lift $ lift $ lift get+    put = GmT . lift . lift . lift . put+    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-    liftWith = defaultLiftWith GmlT unGmlT-    restoreT = defaultRestoreT GmlT+    type StT GmlT a = StT GmT a+    liftWith f = 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-    type StM (GhcModT m) a =+-- GmT ------------------------------------------++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 = GhcModT (liftBaseWith $ \runInBase ->-        f $ runInBase . unGhcModT)--    restoreM = GhcModT . restoreM+    liftBaseWith f = GmT (liftBaseWith $ \runInBase ->+        f $ runInBase . unGmT)+    restoreM = GmT . restoreM     {-# INLINE liftBaseWith #-}     {-# INLINE restoreM #-} -instance MonadTransControl GhcModT where-    type StT GhcModT a = (Either GhcModError (a, GhcModState), GhcModLog)--    liftWith f = GhcModT $+instance MonadTransControl GmT where+    type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog)+    liftWith f = GmT $       liftWith $ \runS ->         liftWith $ \runE ->           liftWith $ \runJ ->             liftWith $ \runR ->-              f $ \ma -> runR $ runJ $ runE $ runS $ unGhcModT ma-    restoreT = GhcModT . restoreT . restoreT . restoreT . restoreT+              f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma+    restoreT = GmT . restoreT . restoreT . restoreT . restoreT     {-# INLINE liftWith #-}     {-# INLINE restoreT #-} -gmLiftInner :: Monad m => m a -> GhcModT m a-gmLiftInner = GhcModT . lift . lift . lift . lift+gmLiftInner :: Monad m => m a -> GmT m a+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 @@     getSession = gmlGetSession     setSession = gmlSetSession --- ---------------------------------------------------------------------- gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv gmlGetSession = do         ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet@@ -369,7 +462,6 @@         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,13 +474,20 @@     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)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r+ instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where     gcatch act handler = control $ \run ->         run act `gcatch` (run . handler)@@ -425,6 +524,9 @@ 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 @@ -433,6 +535,27 @@  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

@@ -22,133 +22,169 @@   , 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 Language.Haskell.GhcMod.Types hiding (LineSeparator)-import Language.Haskell.GhcMod.Monad.Types--withLines :: (String -> String) -> String -> String-withLines f s = let-    res = unlines $ map f $ lines s-  in-    case s of-      [] -> res-      _ | not $ isTerminated s ->-            reverse $ drop 1 $ reverse res-      _ -> res--isTerminated :: String -> Bool-isTerminated "" = False-isTerminated s = isNewline (last s)--isNewline :: Char -> Bool-isNewline c = c == '\n'+import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar+import Control.Concurrent.Chan+import Pipes+import Pipes.Lift+import Prelude -toGmLines :: String -> (GmLines String)-toGmLines "" = GmLines GmPartial ""-toGmLines s | isNewline (last s) = GmLines GmTerminated s-toGmLines s = GmLines GmPartial s+import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..))+import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..)) -outputFns :: (GmEnv m, MonadIO m')-          => m (GmLines String -> m' (), GmLines String -> m' ())-outputFns = do-  opts <- options-  env <- gmeAsk-  return $ outputFns' opts (gmOutput env)+outputFns :: (GmOut m, MonadIO m')+          => m (String -> m' (), String -> m' ())+outputFns =+  outputFns' `liftM` gmoAsk -outputFns' :: MonadIO m'-           => Options-           -> GmOutput-           -> (GmLines String -> m' (), GmLines String -> m' ())-outputFns' opts output  = let-  Options {..} = opts+outputFns' ::+  MonadIO m => GhcModOut -> (String -> m (), String -> m ())+outputFns' (GhcModOut oopts c)  = let+  OutputOpts {..} = oopts+ in+  case ooptLinePrefix of+    Nothing -> stdioOutputFns+    Just _  -> chanOutputFns c -  pfx f = withLines f+stdioOutputFns :: MonadIO m => (String -> m (), String -> m ())+stdioOutputFns =+    ( liftIO . putStr+    , liftIO . hPutStr stderr+    ) -  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-    GmOutputStdio  ->-        ( liftIO . putStr         . unGmLine . outPfx-        , liftIO . hPutStr stderr . unGmLine . errPfx)-    GmOutputChan c ->-        ( liftIO . writeChan c . (,) GmOut . outPfx-        , liftIO . writeChan c . (,) GmErr .errPfx)+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 $ toGmLines str+  putOut <- gmPutStrIO+  putOut str +gmErrStr str = do+  putErr <- gmErrStrIO+  putErr str+ gmPutStrLn = gmPutStr . (++"\n") gmErrStrLn = gmErrStr . (++"\n") -gmErrStr str = do-  putErr <- snd `liftM` outputFns-  putErr $ toGmLines str+gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ()) --- | Only use these when you're sure there are no other writers on stdout-gmUnsafePutStrLn, gmUnsafeErrStrLn-    :: MonadIO m => Options -> String -> m ()-gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines-gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines+gmPutStrIO = fst `liftM` outputFns+gmErrStrIO = snd `liftM` outputFns -gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)++gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String) gmReadProcess = do-  GhcModEnv {..} <- gmeAsk-  case gmOutput of-    GmOutputChan _ ->+  GhcModOut {..} <- gmoAsk+  case ooptLinePrefix gmoOptions of+    Just _ ->         readProcessStderrChan-    GmOutputStdio ->+    Nothing ->         return $ readProcess -stdoutGateway :: Chan (GmStream, GmLines String) -> IO ()-stdoutGateway chan = go ("", "")+flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO ()+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-     (stream, GmLines ty l) <- readChan chan-     case ty of-       GmTerminated ->-           case stream of-             GmOut -> putStr (obuf++l) >> go ("", ebuf)-             GmErr -> putStr (ebuf++l) >> go (obuf, "")-       GmPartial -> case reverse $ lines l of-                      [] -> go buf-                      [x] -> go (appendBuf stream buf x)-                      x:xs -> do-                        putStr $ unlines $ reverse xs-                        go (appendBuf stream buf x)+   commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()+   commandProc = do+     cmd <- liftIO $ readChan chan+     case cmd of+       Left mv -> do+           yield $ Left mv+       Right input -> do+           yield $ Right input+           commandProc -   appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf)-   appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s)+   seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) ()+   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-  return $ go e+  (_, e :: String -> IO ()) <- outputFns+  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 @@      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 @@     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 ++ ")"]

@@ -20,7 +20,9 @@   ) 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.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 @@    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-             -- ^ Path to the cabal package root directory (containing the-             -- @cabal.sandbox.config@ file)-             -> IO (Maybe GhcPkgDb)-getSandboxDb d = do-  mConf <- traverse readFile =<< mightExist (d </> "cabal.sandbox.config")+getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)+getSandboxDb crdl = do+  mConf <-traverse readFile =<< mightExist (sandboxConfigFile crdl)   bp <- buildPlatform readProcess   return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf) @@ -127,7 +133,7 @@ -- 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 @@              _ -> 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 @@ ----------------------------------------------------------------  setupConfigFile :: Cradle -> FilePath-setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath+setupConfigFile crdl =+    cradleRootDir crdl </> setupConfigPath (cradleDistDir crdl) -sandboxConfigFile :: FilePath-sandboxConfigFile = "cabal.sandbox.config"+sandboxConfigFile :: Cradle -> FilePath+sandboxConfigFile crdl = cradleRootDir crdl </> sandboxConfigFileName +sandboxConfigFileName :: String+sandboxConfigFileName = "cabal.sandbox.config"+ -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@-setupConfigPath :: FilePath-setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref+setupConfigPath :: FilePath -> FilePath+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 @@ symbolCacheFile :: String symbolCacheFile = "ghc-mod.symbol-cache" -resolvedComponentsCacheFile :: String-resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components"+resolvedComponentsCacheFile :: FilePath -> FilePath+resolvedComponentsCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.resolved-components" -cabalHelperCacheFile :: String-cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components"+cabalHelperCacheFile :: FilePath -> FilePath+cabalHelperCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.cabal-components" -mergedPkgOptsCacheFile :: String-mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options"+mergedPkgOptsCacheFile :: FilePath -> FilePath+mergedPkgOptsCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.package-options" -pkgDbStackCacheFile :: String-pkgDbStackCacheFile = setupConfigPath <.> "ghc-mod.package-db-stack"+pkgDbStackCacheFile :: FilePath -> FilePath+pkgDbStackCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.package-db-stack" --- | @findCustomPackageDbFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.--- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@+-- | @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@ findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath) findCustomPackageDbFile directory = do     let path = directory </> "ghc-mod.package-db-stack"

@@ -3,7 +3,7 @@ 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 @@ -- | 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

@@ -55,10 +55,15 @@ 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)

@@ -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

@@ -20,14 +20,10 @@ 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.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 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-    => [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 :: (IOish m, Gm m) => LightGhc a -> m a runGmPkgGhc action = do     pkgOpts <- packageGhcOptions     withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action@@ -97,8 +69,13 @@ initSession opts mdf = do    s <- gmsGet    case gmGhcSession s of-     Just GmGhcSession {..} -> when (gmgsOptions /= opts) $ putNewSession s-     Nothing -> putNewSession s+     Just GmGhcSession {..} | gmgsOptions /= opts-> do+         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 @@                  -> 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') +    GhcModLog { gmLogLevel = Just level } <- gmlHistory+    putErr <- gmErrStrIO+    let setLogger | level >= GmDebug = setDebugLogger putErr+                  | otherwise = setEmptyLogger+     initSession opts' $-        setModeSimple >>> setEmptyLogger >>> mdf+        setModeSimple >>> setLogger >>> mdf -    let rfns = map (makeRelative $ cradleRootDir crdl) cfns+    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 crdl sefnmn = do     when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" -    case cradleProjectType crdl of-      CabalProject -> cabalOpts crdl-      _ -> sandboxOpts crdl+    case cradleProject crdl of+      proj+          | isCabalHelperProject proj -> cabalOpts crdl+          | otherwise -> sandboxOpts crdl  where    zipMap f l = l `zip` (f `map` l) @@ -197,7 +181,7 @@             -- 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 @@             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 @@                 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 @@               text "files changed" <+>: changedDoc          mcs <- resolveGmComponents mums comps-        return (setupConfigPath:flatten mcs , mcs)+        return (setupConfigPath distdir : flatten mcs , mcs)  }   where@@ -253,7 +238,8 @@            -> [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 @@ 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-      CabalProject -> getGhcMergedPkgOptions-      _ -> sandboxOpts crdl+    case cradleProject crdl of+      proj+          | 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-    let pkgOpts = ghcDbStackOpts pkgDbStack+    mCusPkgDb <- getCustomPkgDbStack+    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-                      -- ^ Project Directory (where the cabal.sandbox.config-                      -- file would be if it exists)-                      -> IO [GhcPkgDb]-    getSandboxPackageDbStack cdir =-        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir+    getSandboxPackageDbStack :: IO [GhcPkgDb]+    getSandboxPackageDbStack =+        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl -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 @@      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 @@ 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 @@       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 @@  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 @@    same f a b = (f a) == (f b)  -- | Set the files as targets and load them.-loadTargets :: IOish m => [String] -> GmlT m ()-loadTargets filesOrModules = do+loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m ()+loadTargets opts targetStrs = do+    targets' <-+        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 filesOrModules)+          text "Loading" <+>: fsep (map (text . showTargetId) targets) -    targets <- forM filesOrModules (flip guessTarget Nothing)     setTargets targets      mode <- getCompilerMode@@ -449,7 +445,17 @@             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 @@         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 = do     crdl@(Cradle{..}) <- cradle     comps <- mapM (resolveEntrypoint crdl) =<< getComponents-    cached cradleRootDir resolvedComponentsCache comps+    cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps

@@ -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.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 @@ -- | The type for line separator. Historically, a Null string is used. newtype LineSeparator = LineSeparator String deriving (Show) -data Options = Options {-    outputStyle   :: OutputStyle-  -- | Line separator string.-  , lineSeparator :: LineSeparator-  -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,-  -- @snd@ is stderr prefix.-  , linePrefix :: Maybe (String, String)-  -- | Verbosity-  , logLevel      :: GmLogLevel+data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}+                  deriving Show++type FileMappingMap = Map FilePath FileMapping++data ProgramSource = ProgramSourceUser | ProgramSourceStack++data Programs = Programs {   -- | @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-  , hlintOpts     :: [String]+  , optQualified      :: Bool+  , optHlintOpts      :: [String]+  , optFileMappings   :: [(FilePath, Maybe FilePath)]   } deriving (Show)  -- | A default 'Options'. defaultOptions :: Options defaultOptions = Options {-    outputStyle    = PlainStyle-  , lineSeparator  = LineSeparator "\0"-  , linePrefix     = Nothing-  , logLevel       = GmWarning-  , ghcProgram     = "ghc"-  , ghcPkgProgram  = "ghc-pkg"-  , cabalProgram   = "cabal"-  , ghcUserOptions = []-  , operators      = False-  , detailed       = False-  , qualified      = False-  , hlintOpts      = []+    optOutput     = OutputOpts {+      ooptLogLevel       = GmWarning+    , ooptStyle          = PlainStyle+    , ooptLineSeparator  = LineSeparator "\0"+    , ooptLinePrefix     = Nothing+    }+  , optPrograms       = Programs {+      ghcProgram     = "ghc"+    , ghcPkgProgram  = "ghc-pkg"+    , cabalProgram   = "cabal"+    , stackProgram   = "stack"+    }+  , optGhcUserOptions = []+  , optOperators      = False+  , optDetailed       = False+  , optQualified      = False+  , optHlintOpts      = []+  , optFileMappings   = []   }  ---------------------------------------------------------------- -data ProjectType = CabalProject | SandboxProject | PlainProject-                 deriving (Eq, Show)+data Project = CabalProject+             | 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,30 +168,23 @@   , cradleTempDir    :: FilePath   -- | The file name of the found cabal file.   , cradleCabalFile  :: Maybe FilePath+  -- | The build info directory.+  , cradleDistDir    :: FilePath   } deriving (Eq, Show) --data GmStream = GmOut | GmErr-                deriving (Show)--data GmLineType = GmTerminated | GmPartial+data GmStream = GmOutStream | GmErrStream                 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 {       gmLogLevel     :: Maybe GmLogLevel,       gmLogVomitDump :: Last Bool,@@ -182,13 +215,14 @@     , 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 @@   | GMECabalConfigure GhcModError   -- ^ Configuring a cabal project failed. -  | GMECabalFlags GhcModError-  -- ^ Retrieval of the cabal configuration flags failed.+  | GMEStackConfigure GhcModError+  -- ^ Configuring a stack project failed. -  | GMECabalComponent ChComponentName-  -- ^ Cabal component could not be found+  | GMEStackBootstrap GhcModError+    -- ^ 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 @@   | GMETooManyCabalFiles [FilePath]   -- ^ Too many cabal files found. -  | GMECabalStateFile GMConfigStateFileError-    -- ^ Reading Cabal's state configuration file falied somehow.+  | GMEWrongWorkingDirectory FilePath FilePath+     deriving (Eq,Show,Typeable)  instance Error GhcModError where@@ -364,22 +398,16 @@  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

@@ -25,14 +25,17 @@  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,-                         getTemporaryDirectory, canonicalizePath)+import System.Directory 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 @@   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

@@ -18,6 +18,7 @@     worldPackageCaches :: [TimedFile]   , worldCabalFile     :: Maybe TimedFile   , worldCabalConfig   :: Maybe TimedFile+  , worldCabalSandboxConfig :: Maybe TimedFile   , worldSymbolCache   :: Maybe TimedFile   } deriving (Eq, Show) @@ -33,12 +34,14 @@     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       } 

@@ -0,0 +1,30 @@+Copyright Ben Millwood 2012++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ben Millwood nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -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-	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile-	rm -f $(DETECT)+lint: $(TEMPFILE2) ghc.el+	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE2) -f ghc-compile+	rm -f $(TEMPFILE2)  $(TEMPFILE): 	@echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE)@@ -19,8 +19,15 @@ 	@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'` 

@@ -66,14 +66,10 @@   (interactive)   ;; Only check syntax of visible buffers   (when (and (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)))+	     (file-exists-p (buffer-file-name)))     (ghc-with-process (ghc-check-send)-                      'ghc-check-callback-                      (lambda () (setq mode-line-process " -:-")))))+		      'ghc-check-callback+		      (lambda () (setq mode-line-process " -:-")))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -136,7 +132,7 @@ (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 @@ 	  ;; 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 @@                 (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 @@   (let ((file-msgs (ghc-get-only-holes)))     (if (null file-msgs) 	(message "No holes")-      (let ((file (ghc-file-msgs-get-file file-msgs))-	    (msgs (ghc-file-msgs-get-msgs file-msgs)))+      (let ((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 @@ 	  (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 @@ 	(forward-line) 	(re-search-forward "^$" nil t) 	(insert fn)-	(dotimes (i arity)+	(dotimes (_i arity) 	  (insert " _")) 	(insert  " = error \"" fn "\"\n"))))) 

@@ -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)

@@ -101,7 +101,7 @@ (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 @@   (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))

@@ -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-    (ghc-call-process ghc-module-command nil t nil "doc" mod)-    (goto-char (point-min))-    (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")-      (ghc-make-pkg-ver-path-       :pkg (match-string-no-properties 1)-       :ver (match-string-no-properties 2)-       :path (match-string-no-properties 4)))))+  (let ((root ghc-process-root))+    (with-temp-buffer+      (let ((default-directory root))+	(ghc-call-process ghc-module-command nil t nil "doc" mod))+      (goto-char (point-min))+      (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")+	(ghc-make-pkg-ver-path+	 :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 ?. ?-))-	 (pkg  (ghc-pkg-ver-path-get-pkg pkg-ver-path))+  (let* ((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.-    (browse-url url)))+    (funcall ghc-doc-browser-function url)))  (defun ghc-add-anchor (url symbol)   (let ((case-fold-search nil))

@@ -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))-	    (ghc-add ret (read m))))+	  (dotimes (_i n)+	    (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)-	  (apply 'ghc-call-process target nil t nil-		 (append (ghc-make-ghc-options) cmds))-	  (buffer-substring (point-min) (1- (point-max))))))))+	  (let ((default-directory cdir))+	    (apply 'ghc-call-process target nil t nil+		   (append (ghc-make-ghc-options) cmds))+	    (buffer-substring (point-min) (1- (point-max)))))))))  (defmacro ghc-executable-find (cmd &rest body)   ;; (declare (indent 1))

@@ -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)) 

@@ -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)

@@ -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))

@@ -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)-  (let ((root (ghc-get-project-root)))-    (unless ghc-process-process-name-      (setq ghc-process-process-name root))-    (when (and ghc-process-process-name (not ghc-process-running))-      (setq ghc-process-running t)-      (if hook1 (funcall hook1))-      (let* ((cbuf (current-buffer))-	     (name ghc-process-process-name)-	     (buf (get-buffer-create (concat " ghc-mod:" name)))-	     (file (buffer-file-name))-	     (cpro (get-process name)))-	(ghc-with-current-buffer buf-	  (setq ghc-process-original-buffer cbuf)-	  (setq ghc-process-original-file file)-	  (setq ghc-process-callback callback)-	  (setq ghc-process-hook hook2)-	  (setq ghc-process-root root)-	  (erase-buffer)-	  (let ((pro (ghc-get-process cpro name buf)))-	    (process-send-string pro cmd)+(defun ghc-with-process (cmd callback &optional hook1 hook2 skip-map-file)+  (unless ghc-process-process-name+    (setq ghc-process-process-name (ghc-get-project-root)))+  (when (and ghc-process-process-name (not ghc-process-running))+    (setq ghc-process-running t)+    (if hook1 (funcall hook1))+    (let* ((cbuf (current-buffer))+	   (name ghc-process-process-name)+	   (root (file-name-as-directory ghc-process-process-name))+	   (buf (get-buffer-create (concat " ghc-mod:" name)))+	   (file (buffer-file-name))+	   (cpro (get-process name)))+      ;; setting root in the original buffer, sigh+      (setq ghc-process-root root)+      (ghc-with-current-buffer buf+        (setq ghc-process-original-buffer cbuf)+	(setq ghc-process-original-file file)+	(setq ghc-process-hook hook2)+	(setq ghc-process-root root)+	(let ((pro (ghc-get-process cpro name buf root))+	      (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))))-	    pro))))))+	       (insert (format "%% %s" map-cmd))+	       (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)-  (let* ((opts (append ghc-debug-options+(defun ghc-start-process (name buf root)+  (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)-			(redisplay)))))+			(set-buffer-modified-p nil))+		      (redisplay)))) 		(delete-region 1 end))))) 	(goto-char (point-max)) 	(forward-line -1) 	(cond 	 ((looking-at "^OK$")-	  (if ghc-process-hook (funcall ghc-process-hook))-	  (goto-char (point-min))-	  (funcall ghc-process-callback 'ok)-	  (setq ghc-process-running nil))+	  (delete-region (point) (point-max))+	  (setq ghc-process-file-mapping nil)+	  (when ghc-process-callback+	    (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)-  (setq ghc-process-running nil))+(defun ghc-process-sentinel (_process _event)+  (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)-	 (cpro (if name (get-process name))))-    (if (not cpro)-	(message "No process")-      (delete-process cpro)-      (message "A process was killed"))))+  (when (eq major-mode 'haskell-mode)+    (let* ((name ghc-process-process-name)+	   (cpro (if name (get-process name))))+      (if (not cpro)+	  (message "No ghc-mod process")+	(delete-process cpro)+	(message "ghc-mod process was killed")))))  (provide 'ghc-process)

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

@@ -28,8 +28,10 @@ 	       (< 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")

@@ -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 @@ 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 @@                         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 @@                         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 @@                         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 @@                         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 @@                       , 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 @@   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 @@                       , mtl >= 2.0                       , ghc                       , ghc-mod+                      , fclabels == 2.0.*  Executable ghc-modi   Default-Language:     Haskell2010@@ -216,7 +235,7 @@   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 @@                         Spec                         TestUtils                         BrowseSpec+                        CustomPackageDbSpec                         CheckSpec                         FlagSpec                         InfoSpec@@ -236,6 +256,7 @@                         MonadSpec                         PathsAndFilesSpec                         HomeModuleGraphSpec+                        FileMappingSpec    Build-Depends:        hspec >= 2.0.0   if impl(ghc == 7.4.*)@@ -246,4 +267,4 @@  Source-Repository head   Type:                 git-  Location:             git://github.com/kazu-yamamoto/ghc-mod.git+  Location:             https://github.com/kazu-yamamoto/ghc-mod.git

@@ -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 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.Directory (setCurrentDirectory, getAppUserDataDirectory,                         removeDirectoryRecursive) import System.Environment (getArgs)-import System.Exit (exitFailure)-import System.IO (stdout, hSetEncoding, utf8, hFlush)-import System.Exit (exitSuccess)+import System.IO+import System.Exit import Text.PrettyPrint-import Prelude+import Prelude hiding ((.))  import Misc @@ -173,7 +176,7 @@  \    - 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 @@ globalArgSpec :: [OptDescr (Options -> Either [String] Options)] globalArgSpec =       [ option "v" ["verbose"] "Increase or set log level. (0-7)" $-               optArg "LEVEL" $ \ml o -> Right $ o {-                   logLevel = case ml of-                                Nothing -> increaseLogLevel (logLevel o)-                                Just l -> toEnum $ min 7 $ read l-                 }+          optArg "LEVEL" $ \ml o -> Right $ case ml of+              Nothing ->+                  modify (lOoptLogLevel . lOptOutput) increaseLogLevel o+              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-                     [out, err] = splitOn "," s-                   in Right $ o { linePrefix = Just (out, err) }+          reqArg "OUT,ERR" $ \s o -> let+                [out, err] = splitOn "," s+              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 $-                   o { ghcUserOptions = g : ghcUserOptions o }+          reqArg "OPT" $ \g o -> Right $+              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 @@ 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 @@     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- where-   hndle action = do-     (e, _l) <- action-     case e of-       Right _ ->-           return ()-       Left ed ->-           exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)+      Nothing -> wrapGhcCommands globalOptions cmdArgs  globalCommands :: [String] -> Maybe String globalCommands (cmd:_)@@ -374,7 +420,8 @@     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 @@     -- 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 @@         "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-    gmPutStr =<< action args+ghcCommands (cmd:args) = gmPutStr =<< action args  where    action = case cmd of      _ | cmd == "list" || cmd == "modules" -> modulesCmd@@ -463,7 +557,7 @@      "auto"    -> autoCmd      "find"    -> findSymbolCmd      "lint"    -> lintCmd-     "root"    -> rootInfoCmd+--     "root"    -> rootInfoCmd      "doc"     -> pkgDocCmd      "dumpsym" -> dumpSymbolCmd      "boot"    -> bootCmd@@ -478,13 +572,9 @@     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 @@  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 @@ 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 @@ 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 @@   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

@@ -8,21 +8,22 @@   ) 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 opt dir = do-    let act = runGhcModT opt $ loadSymbolDb dir+newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq+newSymDbReq opt gmo tmpdir = do+    let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir     req <- async act     ref <- newIORef req     return $ SymDbReq ref act

@@ -3,6 +3,7 @@ import Control.Applicative import Language.Haskell.GhcMod import Test.Hspec+import Prelude  import TestUtils import Dir@@ -16,18 +17,18 @@      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"]

@@ -67,3 +67,12 @@                 _ <- 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

@@ -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

@@ -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]\""]

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

@@ -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

@@ -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.FilePath import Test.Hspec import TestUtils+import Prelude  spec :: Spec spec = do

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

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

@@ -36,15 +36,25 @@                , "setup-config.ghc-mod.package-db-stack"                , "ghc-mod.cache"                ]-      cachesFindExp :: String-      cachesFindExp = unwords $ intersperse "-o " $ map ("-name "++) caches+      findExp = unwords $ intersperse "-o " $ concat [+                 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 () )

@@ -9,7 +9,7 @@     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"

@@ -1,7 +1,11 @@ module PathsAndFilesSpec where + 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 @@     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

@@ -5,6 +5,7 @@   , runD'   , runE   , runNullLog+  , runGmOutDef   , shouldReturnError   , isPkgDbAt   , isPkgConfDAt@@ -18,14 +19,17 @@ 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,13 +43,23 @@     Right a ->  return a     Left e -> error $ show e -withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a-withSpecCradle cradledir f =-    gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f+withSpecCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a+withSpecCradle cradledir f = do+    gbracket (findSpecCradle cradledir) (liftIO . cleanupCradle) $ \crdl ->+      bracketWorkingDirectory (cradleRootDir crdl) $+        f crdl -withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a-withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f+bracketWorkingDirectory ::+    (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   dir <- getCurrentDirectory@@ -53,10 +67,11 @@  runGhcModTSpec' :: IOish m     => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)-runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->-    withGhcModEnvSpec dir' opt $ \env -> do-      first (fst <$>) <$> runGhcModT'' env defaultGhcModState-        (gmSetLogLevel (logLevel opt) >> action)+runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do+  runGmOutT opt $+    withGhcModEnv' withSpecCradle dir' opt $ \env -> do+      first (fst <$>) <$> runGhcModT' env defaultGhcModState+        (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)  -- | Run GhcMod run :: Options -> GhcModT IO a -> IO a@@ -65,12 +80,15 @@ -- | 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 @@ -79,6 +97,9 @@   (a,w) <- runJournalT action   liftIO $ print w   return a++runGmOutDef :: IOish m => GmOutT m a -> m a+runGmOutDef = runGmOutT defaultOptions  shouldReturnError :: Show a                   => IO (Either GhcModError a, GhcModLog)

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

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

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

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

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

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

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

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

@@ -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

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

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

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

@@ -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

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

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

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

@@ -9,7 +9,7 @@   , "-package", "transformers-" ++ VERSION_transformers   , "-package", "mtl-" ++ VERSION_mtl   , "-package", "directory-" ++ VERSION_directory-  , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators"+  , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns"   , "-idist/build/autogen/"   , "-optP-include"   , "-optPdist/build/autogen/cabal_macros.h"