Merge branch 'master' into ghc-8

Language/Haskell/GhcMod/CaseSplit.hs

@@ -27,6 +27,7 @@ import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Doc
 import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils (withMappedFile)
 import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
 
 ----------------------------------------------------------------
@@ -57,12 +58,14 @@ splits file lineNo colNo =
       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 $
+          t <- withMappedFile file $ \file' ->
+                genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $
                                              getTyCons dflag style varName varT)
           return (fourInts bndLoc, t)
         (TySplitInfo varName bndLoc (varLoc,varT)) -> do
           let varName' = showName dflag style varName  -- Convert name to string
-          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
+          t <- withMappedFile file $ \file' ->
+                genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $
                                              getTyCons dflag style varName varT)
           return (fourInts bndLoc, t)
  where

Language/Haskell/GhcMod/Cradle.hs

@@ -34,24 +34,29 @@ import Control.Monad.Trans.Journal (runJournalT)
 --   Find a cabal file by tracing ancestor directories.
 --   Find a sandbox according to a cabal sandbox config
 --   in a cabal directory.
-findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle
+findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
-findCradle = findCradle' =<< liftIO getCurrentDirectory
+findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
 
-findCradleNoLog  :: forall m. (IOish m, GmOut m) => m Cradle
+findCradleNoLog  :: forall m. (IOish m, GmOut m) => Programs -> m Cradle
-findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
+findCradleNoLog progs =
+    fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
 
-findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
+findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
-findCradle' dir = run $
+findCradle' Programs { stackProgram, cabalProgram } dir = run $
-    msum [ stackCradle dir
+    msum [ stackCradle stackProgram dir
-         , cabalCradle dir
+         , cabalCradle cabalProgram dir
          , sandboxCradle dir
          , plainCradle dir
          ]
  where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
 
-findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
+findSpecCradle ::
-findSpecCradle dir = do
+    (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
-    let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]
+findSpecCradle Programs { stackProgram, cabalProgram } dir = do
+    let cfs = [ stackCradleSpec stackProgram
+              , cabalCradle cabalProgram
+              , sandboxCradle
+              ]
     cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
     gcs <- filterM isNotGmCradle cs
     fillTempDir =<< case gcs of
@@ -69,12 +74,18 @@ fillTempDir crdl = do
   tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
   return crdl { cradleTempDir = tmpDir }
 
-cabalCradle :: IOish m => FilePath -> MaybeT m Cradle
+cabalCradle ::
-cabalCradle wdir = do
+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
-    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
+cabalCradle cabalProg wdir = do
+    -- If cabal doesn't exist the user probably wants to use something else
+    whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do
+      gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
+      mzero
 
+    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
     let cabalDir = takeDirectory cabalFile
 
+    gmLog GmInfo "" $ text "found Cabal project at" <+>: text cabalDir
     return Cradle {
         cradleProject    = CabalProject
       , cradleCurrentDir = wdir
@@ -84,12 +95,19 @@ cabalCradle wdir = do
       , cradleDistDir    = "dist"
       }
 
-stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
+stackCradle ::
-stackCradle wdir = do
+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
+stackCradle stackProg wdir = do
 #if !MIN_VERSION_ghc(7,8,0)
     -- GHC < 7.8 is not supported by stack
     mzero
 #endif
+
+    -- If cabal doesn't exist the user probably wants to use something else
+    whenM ((==Nothing) <$> liftIO (findExecutable stackProg)) $ do
+      gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
+      mzero
+
     cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
 
     let cabalDir = takeDirectory cabalFile
@@ -99,11 +117,12 @@ stackCradle wdir = do
     -- 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 $ cabalDir </> setupConfigPath "dist") $ do
-      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
+      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead"
       mzero
 
     senv <- MaybeT $ getStackEnv cabalDir
 
+    gmLog GmInfo "" $ text "found Stack project at" <+>: text cabalDir
     return Cradle {
         cradleProject    = StackProject senv
       , cradleCurrentDir = wdir
@@ -113,9 +132,10 @@ stackCradle wdir = do
       , cradleDistDir    = seDistDir senv
       }
 
-stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
+stackCradleSpec ::
-stackCradleSpec wdir = do
+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
-  crdl <- stackCradle wdir
+stackCradleSpec stackProg wdir = do
+  crdl <- stackCradle stackProg wdir
   case crdl of
     Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
       b <- isGmDistDir seDistDir
@@ -126,9 +146,10 @@ stackCradleSpec wdir = do
    isGmDistDir dir =
        liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")
 
-sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
+sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
 sandboxCradle wdir = do
     sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
+    gmLog GmInfo "" $ text "Found sandbox project at" <+>: text sbDir
     return Cradle {
         cradleProject    = SandboxProject
       , cradleCurrentDir = wdir
@@ -138,8 +159,9 @@ sandboxCradle wdir = do
       , cradleDistDir    = "dist"
       }
 
-plainCradle :: IOish m => FilePath -> MaybeT m Cradle
+plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
 plainCradle wdir = do
+    gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"
     return $ Cradle {
         cradleProject    = PlainProject
       , cradleCurrentDir = wdir

Language/Haskell/GhcMod/Debug.hs

@@ -3,11 +3,12 @@ module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
 import Control.Arrow (first)
 import Control.Applicative
 import Control.Monad
-import Control.Monad.Trans.Journal
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Char
+import Data.Version
 import Data.List.Split
+import System.Directory
 import Text.PrettyPrint
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
@@ -17,6 +18,11 @@ import Language.Haskell.GhcMod.Pretty
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.Stack
+import Language.Haskell.GhcMod.Output
+
+import Paths_ghc_mod (version)
+
+import Config (cProjectVersion)
 
 ----------------------------------------------------------------
 
@@ -34,14 +40,20 @@ debugInfo = do
 
     pkgOpts <- packageGhcOptions
 
+    readProc <- gmReadProcess
+
+    ghcVersion <- liftIO $
+        dropWhileEnd isSpace <$> readProc "ghc" ["--numeric-version"] ""
+
     return $ unlines $
-      [ "Root directory:       " ++ cradleRootDir
+      [ "Version:              ghc-mod-" ++ showVersion version
+      , "Library GHC Version:  " ++ cProjectVersion
+      , "System GHC Version:   " ++ ghcVersion
+      , "Root directory:       " ++ cradleRootDir
       , "Current directory:    " ++ cradleCurrentDir
       , "GHC Package flags:\n"   ++ render (nest 4 $
               fsep $ map text pkgOpts)
       , "GHC System libraries: " ++ ghcLibDir
-      , "GHC user options:\n"    ++ render (nest 4 $
-              fsep $ map text optGhcUserOptions)
       ] ++ cabal
 
 stackPaths :: IOish m => GhcModT m [String]
@@ -63,9 +75,24 @@ cabalDebug = do
         opts        = Map.map gmcGhcOpts mcs
         srcOpts     = Map.map gmcGhcSrcOpts mcs
 
+    readProc <- gmReadProcess
+    cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal"
+
+    cabalInstVersion <-
+        if cabalExists
+          then liftIO $
+            dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] ""
+          else return ""
+
+    packages <- liftIO $ readProc "ghc-pkg" ["list", "--simple-output"] ""
+    let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages
+
     return $
-         [ "Cabal file:           " ++ show cradleCabalFile
+         [ "cabal-install Version: "    ++ cabalInstVersion
-         , "Project:   " ++ show cradleProject
+         , "Cabal Library Versions:\n"  ++ render (nest 4 $
+              fsep $ map text cabalPackages)
+         , "Cabal file:            "    ++ show cradleCabalFile
+         , "Project:               " ++ show cradleProject
          , "Cabal entrypoints:\n"       ++ render (nest 4 $
               mapDoc gmComponentNameDoc smpDoc entrypoints)
          , "Cabal components:\n"        ++ render (nest 4 $
@@ -139,5 +166,7 @@ mapDoc kd ad m = vcat $
 ----------------------------------------------------------------
 
 -- | Obtaining root information.
-rootInfo :: forall m. (IOish m, GmOut m) => m String
+rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
-rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
+rootInfo = do
+    crdl <- findCradleNoLog =<< (optPrograms <$> options)
+    return $ cradleRootDir crdl ++ "\n"

Language/Haskell/GhcMod/Find.hs

@@ -56,7 +56,8 @@ import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Set (Set)
 import qualified Data.Set as S
-
+import Language.Haskell.GhcMod.PathsAndFiles
+import System.Directory
 import Prelude
 
 ----------------------------------------------------------------
@@ -83,7 +84,7 @@ isOutdated db =
 -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
 --   which will be concatenated. 'loadSymbolDb' is called internally.
 findSymbol :: IOish m => String -> GhcModT m String
-findSymbol sym = loadSymbolDb >>= lookupSymbol sym
+findSymbol sym = loadSymbolDb' >>= lookupSymbol sym
 
 -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
 --   which will be concatenated.
@@ -95,6 +96,21 @@ lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.t
 
 ---------------------------------------------------------------
 
+loadSymbolDb' :: IOish m => GhcModT m SymbolDb
+loadSymbolDb' = do
+  cache <- symbolCache <$> cradle
+  let doLoad True = do
+        db <- decode <$> liftIO (LBS.readFile cache)
+        outdated <- isOutdated db
+        if outdated
+        then doLoad False
+        else return db
+      doLoad False = do
+        db <- loadSymbolDb
+        liftIO $ LBS.writeFile cache $ encode db
+        return db
+  doLoad =<< liftIO (doesFileExist cache)
+
 -- | Loading a file and creates 'SymbolDb'.
 loadSymbolDb :: IOish m => GhcModT m SymbolDb
 loadSymbolDb = do

Language/Haskell/GhcMod/Gap.hs

@@ -75,6 +75,10 @@ import qualified InstEnv
 import qualified Pretty
 import qualified StringBuffer as SB
 
+#if __GLASGOW_HASKELL__ >= 710
+import CoAxiom (coAxiomTyCon)
+#endif
+
 #if __GLASGOW_HASKELL__ >= 708
 import FamInstEnv
 import ConLike (ConLike(..))
@@ -364,28 +368,44 @@ pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [F
 pprInfo m _ (thing, fixity, insts, famInsts)
     = pprTyThingInContextLoc' thing
    $$ show_fixity fixity
-   $$ InstEnv.pprInstances insts
+   $$ vcat (map pprInstance' insts)
-   $$ pprFamInsts famInsts
+   $$ vcat (map pprFamInst' famInsts)
 #else
 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)
+   $$ 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
+    pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
-                                        (char '\t' <> ptext (sLit "--") <+> loc)
+#if __GLASGOW_HASKELL__ >= 710
-                         where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
+    pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
+      = pprTyThingInContextLoc (ATyCon rep_tc)
+
+    pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
+                        , fi_tys = lhs_tys, fi_rhs = rhs })
+      = showWithLoc (pprDefinedAt' (getName axiom)) $
+        hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
+           2 (equals <+> ppr rhs)
 #else
-    pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2
+    pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
-                                    (char '\t' <> ptext (sLit "--") <+> loc)
-                               where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
 #endif
+#else
+    pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')
+#endif
+    showWithLoc loc doc
+        = hang doc 2 (char '\t' <> comment <+> loc)
+        -- The tab tries to make them line up a bit
+      where
+        comment = ptext (sLit "--")
+    pprInstance' ispec = hang (pprInstanceHdr ispec)
+        2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))
+    pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
     pprNameDefnLoc' name
       = case Name.nameSrcLoc name of
            RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)

Language/Haskell/GhcMod/Monad.hs

@@ -53,11 +53,17 @@ import System.Directory
 import System.IO.Unsafe
 import Prelude
 
-withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog)  -> m a) -> m a
+withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
-withGhcModEnv = withGhcModEnv' withCradle
+withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
  where
-   withCradle dir =
+   withCradle dir' =
-       gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
+       gbracket
+         (runJournalT $ do
+            gmSetLogLevel $ ooptLogLevel $ optOutput opts
+            findCradle' (optPrograms opts) dir')
+         (liftIO . cleanupCradle . fst)
+
+
 
 cwdLock :: MVar ThreadId
 cwdLock = unsafePerformIO $ newEmptyMVar

Language/Haskell/GhcMod/Options/DocUtils.hs

@@ -14,7 +14,7 @@
 -- 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 GHCMod.Options.DocUtils (
+module Language.Haskell.GhcMod.Options.DocUtils (
   ($$),
   ($$$),
   (<=>),

Language/Haskell/GhcMod/Options/Help.hs

@@ -15,7 +15,7 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 {-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
 
-module GHCMod.Options.Help where
+module Language.Haskell.GhcMod.Options.Help where
 
 import Options.Applicative
 import Options.Applicative.Help.Pretty (Doc)

Language/Haskell/GhcMod/Options/Options.hs

@@ -0,0 +1,173 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
+module Language.Haskell.GhcMod.Options.Options (
+    globalArgSpec
+  , parseCmdLineOptions
+) where
+
+import Options.Applicative
+import Options.Applicative.Types
+import Language.Haskell.GhcMod.Types
+import Control.Arrow
+import Data.Char (toUpper, toLower)
+import Data.List (intercalate)
+import Language.Haskell.GhcMod.Read
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Help
+import Data.Monoid
+import Prelude
+
+-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing
+-- @Options@ set accordingly.
+parseCmdLineOptions :: [String] -> Maybe Options
+parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)
+
+splitOn :: Eq a => a -> [a] -> ([a], [a])
+splitOn c = second (drop 1) . break (==c)
+
+logLevelParser :: Parser GmLogLevel
+logLevelParser =
+    logLevelSwitch <*>
+           logLevelOption
+      <||> silentSwitch
+  where
+    logLevelOption =
+      option parseLL
+        $$  long "verbose"
+        <=> metavar "LEVEL"
+        <=> value GmWarning
+        <=> showDefaultWith showLL
+        <=> help' $$$ do
+          "Set log level ("
+            <> int' (fromEnum (minBound :: GmLogLevel))
+            <> "-"
+            <> int' (fromEnum (maxBound :: GmLogLevel))
+            <> ")"
+          "You can also use strings (case-insensitive):"
+          para'
+            $ intercalate ", "
+            $ map showLL ([minBound..maxBound] :: [GmLogLevel])
+    logLevelSwitch =
+      repeatAp succ' . length <$> many $$ flag' ()
+        $$  short 'v'
+        <=> help "Increase log level"
+    silentSwitch = flag' GmSilent
+        $$  long "silent"
+        <=> short 's'
+        <=> help "Be silent, set log level to 'silent'"
+    showLL = drop 2 . map toLower . show
+    repeatAp f n = foldr (.) id (replicate n f)
+    succ' x | x == maxBound = x
+            | otherwise     = succ x
+    parseLL = do
+      v <- readerAsk
+      let
+        il'= toEnum . min maxBound <$> readMaybe v
+        ll' = readMaybe ("Gm" ++ capFirst v)
+      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
+    capFirst (h:t) = toUpper h : map toLower t
+    capFirst [] = []
+
+outputOptsSpec :: Parser OutputOpts
+outputOptsSpec = OutputOpts
+      <$> logLevelParser
+      <*> flag PlainStyle LispStyle
+          $$  long "tolisp"
+          <=> short 'l'
+          <=> help "Format output as an S-Expression"
+      <*> LineSeparator <$$> strOption
+          $$  long "boundary"
+          <=> long "line-separator"
+          <=> short 'b'
+          <=> metavar "SEP"
+          <=> value "\0"
+          <=> showDefault
+          <=> help "Output line separator"
+      <*> optional $$ splitOn ',' <$$> strOption
+          $$  long "line-prefix"
+          <=> metavar "OUT,ERR"
+          <=> help "Output prefixes"
+
+programsArgSpec :: Parser Programs
+programsArgSpec = Programs
+      <$> strOption
+          $$  long "with-ghc"
+          <=> value "ghc"
+          <=> showDefault
+          <=> help "GHC executable to use"
+      <*> strOption
+          $$  long "with-ghc-pkg"
+          <=> value "ghc-pkg"
+          <=> showDefault
+          <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
+      <*> strOption
+          $$  long "with-cabal"
+          <=> value "cabal"
+          <=> showDefault
+          <=> help "cabal-install executable to use"
+      <*> strOption
+          $$  long "with-stack"
+          <=> value "stack"
+          <=> showDefault
+          <=> help "stack executable to use"
+
+-- | An optparse-applicative @Parser@ sepcification for @Options@ so that
+-- applications making use of the ghc-mod API can have a consistent way of
+-- parsing global options.
+globalArgSpec :: Parser Options
+globalArgSpec = Options
+      <$> outputOptsSpec
+      <*> programsArgSpec
+      <*> many $$ strOption
+          $$  long "ghcOpt"
+          <=> long "ghc-option"
+          <=> short 'g'
+          <=> metavar "OPT"
+          <=> help "Option to be passed to GHC"
+      <*> many fileMappingSpec
+      <*> strOption
+          $$  long "encoding"
+          <=> value "UTF-8"
+          <=> showDefault
+          <=> help "I/O encoding"
+  where
+    fileMappingSpec =
+      getFileMapping . splitOn '=' <$> strOption
+        $$  long "map-file"
+        <=> metavar "MAPPING"
+        <=> fileMappingHelp
+    fileMappingHelp = help' $ do
+        "Redirect one file to another"
+        "--map-file \"file1.hs=file2.hs\""
+        indent 4 $ do
+          "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\""
+        indent 4 $ do
+          "can be used to tell ghc-mod that it should take"
+            \\ "source code for `file.hs` from stdin. File end"
+            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
+            \\ "`file.hs` may or may not exist, and should be"
+            \\ "either full path, or relative to project root."
+    getFileMapping = second (\i -> if null i then Nothing else Just i)

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -220,7 +220,7 @@ packageCache = "package.cache"
 
 -- | Filename of the symbol table cache file.
 symbolCache :: Cradle -> FilePath
-symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
+symbolCache crdl = cradleRootDir crdl </> cradleDistDir crdl </> symbolCacheFile
 
 symbolCacheFile :: String
 symbolCacheFile = "ghc-mod.symbol-cache"

Language/Haskell/GhcMod/Pretty.hs

@@ -32,7 +32,8 @@ gmRenderDoc = renderStyle docStyle
 
 gmComponentNameDoc :: ChComponentName -> Doc
 gmComponentNameDoc ChSetupHsName   = text $ "Setup.hs"
-gmComponentNameDoc ChLibName       = text $ "library"
+gmComponentNameDoc (ChLibName "")  = text $ "library"
+gmComponentNameDoc (ChLibName n)   = text $ "library:" ++ n
 gmComponentNameDoc (ChExeName n)   = text $ "exe:" ++ n
 gmComponentNameDoc (ChTestName n)  = text $ "test:" ++ n
 gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n

Language/Haskell/GhcMod/Target.hs

@@ -466,7 +466,9 @@ loadTargets opts targetStrs = do
     case target' of
       HscNothing -> do
         void $ load LoadAllTargets
-        mapM_ (parseModule >=> typecheckModule >=> desugarModule) mg
+        forM_ mg $
+          handleSourceError (gmLog GmDebug "loadTargets" . text . show)
+          . void . (parseModule >=> typecheckModule >=> desugarModule)
       HscInterpreted -> do
         void $ load LoadAllTargets
       _ -> error ("loadTargets: unsupported hscTarget")

Language/Haskell/GhcMod/Types.hs

@@ -134,7 +134,7 @@ data Project = CabalProject
              | SandboxProject
              | PlainProject
              | StackProject StackEnv
-               deriving (Eq, Show)
+               deriving (Eq, Show, Ord)
 
 isCabalHelperProject :: Project -> Bool
 isCabalHelperProject StackProject {} = True
@@ -146,7 +146,7 @@ data StackEnv = StackEnv {
     , seBinPath       :: [FilePath]
     , seSnapshotPkgDb :: FilePath
     , seLocalPkgDb    :: FilePath
-    } deriving (Eq, Show)
+    } deriving (Eq, Show, Ord)
 
 -- | The environment where this library is used.
 data Cradle = Cradle {
@@ -161,7 +161,7 @@ data Cradle = Cradle {
   , cradleCabalFile  :: Maybe FilePath
   -- | The build info directory.
   , cradleDistDir    :: FilePath
-  } deriving (Eq, Show)
+  } deriving (Eq, Show, Ord)
 
 data GmStream = GmOutStream | GmErrStream
                 deriving (Show)

Language/Haskell/GhcMod/World.hs

@@ -19,7 +19,6 @@ data World = World {
   , worldCabalFile     :: Maybe TimedFile
   , worldCabalConfig   :: Maybe TimedFile
   , worldCabalSandboxConfig :: Maybe TimedFile
-  , worldSymbolCache   :: Maybe TimedFile
   } deriving (Eq)
 
 timedPackageCaches :: IOish m => GhcModT m [TimedFile]
@@ -35,14 +34,12 @@ getCurrentWorld = do
     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
       }
 
 didWorldChange :: IOish m => World -> GhcModT m Bool

ghc-mod.cabal

@@ -153,6 +153,10 @@ Library
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.World
+
+                        Language.Haskell.GhcMod.Options.Options
+                        Language.Haskell.GhcMod.Options.DocUtils
+                        Language.Haskell.GhcMod.Options.Help
   Other-Modules:        Paths_ghc_mod
                         Utils
                         Data.Binary.Generic
@@ -161,14 +165,14 @@ Library
                       , bytestring        < 0.11
                       , binary            < 0.9 && >= 0.5.1.0
                       , containers        < 0.6
-                      , cabal-helper      < 0.7 && >= 0.6.3.0
+                      , cabal-helper      < 0.8 && >= 0.7.0.1
                       , deepseq           < 1.5
                       , directory         < 1.3
                       , filepath          < 1.5
                       , ghc               < 8.2 && >= 7.6
                       , ghc-paths         < 0.2
                       , ghc-syb-utils     < 0.3
-                      , hlint             < 1.10 && >= 1.9.26
+                      , hlint             < 1.10 && >= 1.9.27
                       , monad-journal     < 0.8 && >= 0.4
                       , old-time          < 1.2
                       , pretty            < 1.2
@@ -188,6 +192,7 @@ Library
                       , extra             == 1.4.*
                       , pipes             == 4.1.*
                       , safe              < 0.4 && >= 0.3.9
+                      , optparse-applicative >=0.11.0 && <0.13.0
                       , template-haskell
                       , syb
   if impl(ghc < 7.8)
@@ -202,9 +207,7 @@ Executable ghc-mod
                       , GHCMod.Options
                       , GHCMod.Options.Commands
                       , GHCMod.Version
-                      , GHCMod.Options.DocUtils
                       , GHCMod.Options.ShellParse
-                      , GHCMod.Options.Help
   GHC-Options:          -Wall -fno-warn-deprecations -threaded
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src

src/GHCMod.hs

@@ -111,7 +111,6 @@ getFileSourceFromStdin = do
         else return []
 
 wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
-wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
 wrapGhcCommands opts cmd =
     handleGmError $ runGhcModT opts $ handler $ do
       forM_ (reverse $ optFileMappings opts) $
@@ -141,7 +140,7 @@ ghcCommands (CmdDebug) = debugInfo
 ghcCommands (CmdDebugComponent ts) = componentInfo ts
 ghcCommands (CmdBoot) = boot
 -- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
--- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
+ghcCommands (CmdRoot) = rootInfo
 ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
 ghcCommands (CmdModules detail) = modules detail
 ghcCommands (CmdDumpSym) = dumpSymbol >> return ""

src/GHCMod/Options.hs

@@ -25,14 +25,10 @@ module GHCMod.Options (
 import Options.Applicative
 import Options.Applicative.Types
 import Language.Haskell.GhcMod.Types
-import Control.Arrow
-import Data.Char (toUpper, toLower)
-import Data.List (intercalate)
-import Language.Haskell.GhcMod.Read
 import GHCMod.Options.Commands
 import GHCMod.Version
-import GHCMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.Options
 import GHCMod.Options.ShellParse
 
 parseArgs :: IO (Options, GhcModCommands)
@@ -74,133 +70,3 @@ helpVersion =
 argAndCmdSpec :: Parser (Options, GhcModCommands)
 argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
 
-splitOn :: Eq a => a -> [a] -> ([a], [a])
-splitOn c = second (drop 1) . break (==c)
-
-logLevelParser :: Parser GmLogLevel
-logLevelParser =
-    logLevelSwitch <*>
-           logLevelOption
-      <||> silentSwitch
-  where
-    logLevelOption =
-      option parseLL
-        $$  long "verbose"
-        <=> metavar "LEVEL"
-        <=> value GmWarning
-        <=> showDefaultWith showLL
-        <=> help' $$$ do
-          "Set log level ("
-            <> int' (fromEnum (minBound :: GmLogLevel))
-            <> "-"
-            <> int' (fromEnum (maxBound :: GmLogLevel))
-            <> ")"
-          "You can also use strings (case-insensitive):"
-          para'
-            $ intercalate ", "
-            $ map showLL ([minBound..maxBound] :: [GmLogLevel])
-    logLevelSwitch =
-      repeatAp succ' . length <$> many $$ flag' ()
-        $$  short 'v'
-        <=> help "Increase log level"
-    silentSwitch = flag' GmSilent
-        $$  long "silent"
-        <=> short 's'
-        <=> help "Be silent, set log level to 'silent'"
-    showLL = drop 2 . map toLower . show
-    repeatAp f n = foldr (.) id (replicate n f)
-    succ' x | x == maxBound = x
-            | otherwise     = succ x
-    parseLL = do
-      v <- readerAsk
-      let
-        il'= toEnum . min maxBound <$> readMaybe v
-        ll' = readMaybe ("Gm" ++ capFirst v)
-      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
-    capFirst (h:t) = toUpper h : map toLower t
-    capFirst [] = []
-
-outputOptsSpec :: Parser OutputOpts
-outputOptsSpec = OutputOpts
-      <$> logLevelParser
-      <*> flag PlainStyle LispStyle
-          $$  long "tolisp"
-          <=> short 'l'
-          <=> help "Format output as an S-Expression"
-      <*> LineSeparator <$$> strOption
-          $$  long "boundary"
-          <=> long "line-separator"
-          <=> short 'b'
-          <=> metavar "SEP"
-          <=> value "\0"
-          <=> showDefault
-          <=> help "Output line separator"
-      <*> optional $$ splitOn ',' <$$> strOption
-          $$  long "line-prefix"
-          <=> metavar "OUT,ERR"
-          <=> help "Output prefixes"
-
-programsArgSpec :: Parser Programs
-programsArgSpec = Programs
-      <$> strOption
-          $$  long "with-ghc"
-          <=> value "ghc"
-          <=> showDefault
-          <=> help "GHC executable to use"
-      <*> strOption
-          $$  long "with-ghc-pkg"
-          <=> value "ghc-pkg"
-          <=> showDefault
-          <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
-      <*> strOption
-          $$  long "with-cabal"
-          <=> value "cabal"
-          <=> showDefault
-          <=> help "cabal-install executable to use"
-      <*> strOption
-          $$  long "with-stack"
-          <=> value "stack"
-          <=> showDefault
-          <=> help "stack executable to use"
-
-globalArgSpec :: Parser Options
-globalArgSpec = Options
-      <$> outputOptsSpec
-      <*> programsArgSpec
-      <*> many $$ strOption
-          $$  long "ghcOpt"
-          <=> long "ghc-option"
-          <=> short 'g'
-          <=> metavar "OPT"
-          <=> help "Option to be passed to GHC"
-      <*> many fileMappingSpec
-      <*> strOption
-          $$  long "encoding"
-          <=> value "UTF-8"
-          <=> showDefault
-          <=> help "I/O encoding"
-  where
-    fileMappingSpec =
-      getFileMapping . splitOn '=' <$> strOption
-        $$  long "map-file"
-        <=> metavar "MAPPING"
-        <=> fileMappingHelp
-    fileMappingHelp = help' $ do
-        "Redirect one file to another"
-        "--map-file \"file1.hs=file2.hs\""
-        indent 4 $ do
-          "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\""
-        indent 4 $ do
-          "can be used to tell ghc-mod that it should take"
-            \\ "source code for `file.hs` from stdin. File end"
-            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
-            \\ "`file.hs` may or may not exist, and should be"
-            \\ "either full path, or relative to project root."
-    getFileMapping = second (\i -> if null i then Nothing else Just i)

src/GHCMod/Options/Commands.hs

@@ -23,8 +23,8 @@ import Options.Applicative.Types
 import Options.Applicative.Builder.Internal
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Read
-import GHCMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.Help
 
 type Symbol = String
 type Expr = String

stack.yaml

@@ -1,6 +1,5 @@
 flags: {}
 packages:
 - '.'
-extra-deps:
+extra-deps: []
-- cabal-helper-0.6.2.0
+resolver: lts-5.3
-resolver: lts-3.20

test/CradleSpec.hs

@@ -37,14 +37,14 @@ spec = do
         it "returns the current directory" $ do
             withDirectory_ "/" $ do
                 curDir <- stripLastDot <$> canonicalizePath "/"
-                res <- clean_ $ runGmOutDef findCradleNoLog
+                res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions
                 cradleCurrentDir res `shouldBe` curDir
                 cradleRootDir    res `shouldBe` curDir
                 cradleCabalFile  res `shouldBe` Nothing
 
         it "finds a cabal file and a sandbox" $ do
             withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
-                res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
+                res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
 
                 cradleCurrentDir res `shouldBe`
                     "test/data/cabal-project/subdir1/subdir2"
@@ -56,7 +56,7 @@ spec = do
 
         it "works even if a sandbox config file is broken" $ do
             withDirectory "test/data/broken-sandbox" $ \dir -> do
-                res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
+                res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
                 cradleCurrentDir res `shouldBe`
                     "test" </> "data" </> "broken-sandbox"
 

test/PathsAndFilesSpec.hs

@@ -16,12 +16,12 @@ spec = do
     describe "getSandboxDb" $ do
         it "can parse a config file and extract the sandbox package-db" $ do
             cwd <- getCurrentDirectory
-            Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"
+            Just crdl <- runLogDef $ 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
-            Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox"
+            Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox"
             getSandboxDb crdl  `shouldReturn` Nothing
 
     describe "findCabalFile" $ do

test/TestUtils.hs

@@ -6,6 +6,7 @@ module TestUtils (
   , runE
   , runNullLog
   , runGmOutDef
+  , runLogDef
   , shouldReturnError
   , isPkgDbAt
   , isPkgConfDAt
@@ -43,10 +44,6 @@ extract action = do
     Right a ->  return a
     Left e -> error $ show e
 
-withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
-withSpecCradle cradledir f = do
-    gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f
-
 runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
 runGhcModTSpec opt action = do
   dir <- getCurrentDirectory
@@ -59,6 +56,13 @@ runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
     withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do
       first (fst <$>) <$> runGhcModT' env defaultGhcModState
         (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
+ where
+   withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
+   withSpecCradle cradledir f =
+     gbracket
+       (runJournalT $ findSpecCradle (optPrograms opt) cradledir)
+       (liftIO . cleanupCradle . fst) f
+
 
 -- | Run GhcMod
 run :: Options -> GhcModT IO a -> IO a
@@ -88,6 +92,9 @@ runNullLog action = do
 runGmOutDef :: IOish m => GmOutT m a -> m a
 runGmOutDef = runGmOutT defaultOptions
 
+runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a
+runLogDef = fmap fst . runJournalT . runGmOutDef
+
 shouldReturnError :: Show a
                   => IO (Either GhcModError a, GhcModLog)
                   -> Expectation