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 = findCradle' =<< liftIO getCurrentDirectory
+findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
+findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
 
-findCradleNoLog  :: forall m. (IOish m, GmOut m) => m Cradle
-findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
+findCradleNoLog  :: forall m. (IOish m, GmOut m) => Programs -> m Cradle
+findCradleNoLog progs =
+    fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
 
-findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
-findCradle' dir = run $
-    msum [ stackCradle dir
-         , cabalCradle dir
+findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
+findCradle' Programs { stackProgram, cabalProgram } dir = run $
+    msum [ stackCradle stackProgram 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 dir = do
-    let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]
+findSpecCradle ::
+    (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
+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 wdir = do
-    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
+cabalCradle ::
+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
+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 wdir = do
+stackCradle ::
+    (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 wdir = do
-  crdl <- stackCradle wdir
+stackCradleSpec ::
+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
+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
-         , "Project:   " ++ show cradleProject
+         [ "cabal-install Version: "    ++ cabalInstVersion
+         , "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 = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
+rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
+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
-   $$ pprFamInsts famInsts
+   $$ vcat (map pprInstance' insts)
+   $$ 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
-                                        (char '\t' <> ptext (sLit "--") <+> loc)
-                         where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
+    pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
+#if __GLASGOW_HASKELL__ >= 710
+    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
-                                    (char '\t' <> ptext (sLit "--") <+> loc)
-                               where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
+    pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
 #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 = withGhcModEnv' withCradle
+withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
+withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
  where
-   withCradle dir =
-       gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
+   withCradle dir' =
+       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

@@ -0,0 +1,48 @@
+-- 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/>.
+
+module Language.Haskell.GhcMod.Options.DocUtils (
+  ($$),
+  ($$$),
+  (<=>),
+  (<$$>),
+  (<||>)
+) where
+
+import Options.Applicative
+import Data.Monoid
+import Prelude
+
+infixl 6 <||>
+infixr 7 <$$>
+infixr 7 $$
+infixr 8 <=>
+infixr 9 $$$
+
+($$) :: (a -> b) -> a -> b
+($$) = ($)
+
+($$$) :: (a -> b) -> a -> b
+($$$) = ($)
+
+(<||>) :: Alternative a => a b -> a b -> a b
+(<||>) = (<|>)
+
+(<=>) :: Monoid m => m -> m -> m
+(<=>) = (<>)
+
+(<$$>) :: Functor f => (a -> b) -> f a -> f b
+(<$$>) = (<$>)

Language/Haskell/GhcMod/Options/Help.hs

@@ -0,0 +1,79 @@
+-- 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, FlexibleInstances, GeneralizedNewtypeDeriving #-}
+
+module Language.Haskell.GhcMod.Options.Help where
+
+import Options.Applicative
+import Options.Applicative.Help.Pretty (Doc)
+import qualified Options.Applicative.Help.Pretty as PP
+import Control.Monad.State
+import GHC.Exts( IsString(..) )
+import Data.Maybe
+import Data.Monoid
+import Prelude
+
+newtype MyDocM s a = MyDoc {unwrapState :: State s a}
+  deriving (Monad, Functor, Applicative, MonadState s)
+type MyDoc = MyDocM (Maybe Doc) ()
+
+instance IsString (MyDocM (Maybe Doc) a) where
+    fromString = append . para
+
+instance Monoid (MyDocM (Maybe Doc) ()) where
+  mappend a b = append $ doc a <> doc b
+  mempty = append PP.empty
+
+para :: String -> Doc
+para = PP.fillSep . map PP.text . words
+
+append :: Doc -> MyDocM (Maybe Doc) a
+append s = modify m >> return undefined
+  where
+    m :: Maybe Doc -> Maybe Doc
+    m Nothing = Just s
+    m (Just old) = Just $ old PP..$. s
+
+infixr 7 \\
+(\\) :: MyDoc -> MyDoc -> MyDoc
+(\\) a b = append $ doc a PP.<+> doc b
+
+doc :: MyDoc -> Doc
+doc = fromMaybe PP.empty . flip execState Nothing . unwrapState
+
+help' :: MyDoc -> Mod f a
+help' = helpDoc . Just . doc
+
+desc :: MyDoc -> InfoMod a
+desc = footerDoc . Just . doc . indent 2
+
+code :: MyDoc -> MyDoc
+code x = do
+  _ <- " "
+  indent 4 x
+  " "
+
+progDesc' :: MyDoc -> InfoMod a
+progDesc' = progDescDoc . Just . doc
+
+indent :: Int -> MyDoc -> MyDoc
+indent n = append . PP.indent n . doc
+
+int' :: Int -> MyDoc
+int' = append . PP.int
+
+para' :: String -> MyDoc
+para' = append . para

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