diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs
index 10f9d12..a327dd4 100644
--- a/Language/Haskell/GhcMod/CaseSplit.hs
+++ b/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
diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs
index fe2b179..05f6b31 100644
--- a/Language/Haskell/GhcMod/Cradle.hs
+++ b/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
diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs
index 2fd7bb0..9811e72 100644
--- a/Language/Haskell/GhcMod/Debug.hs
+++ b/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"
diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs
index 5f00138..bd51749 100644
--- a/Language/Haskell/GhcMod/Find.hs
+++ b/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
diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs
index 83355d6..3e74c67 100644
--- a/Language/Haskell/GhcMod/Gap.hs
+++ b/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)
diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs
index 5d90aee..96d55e5 100644
--- a/Language/Haskell/GhcMod/Monad.hs
+++ b/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
diff --git a/src/GHCMod/Options/DocUtils.hs b/Language/Haskell/GhcMod/Options/DocUtils.hs
similarity index 96%
rename from src/GHCMod/Options/DocUtils.hs
rename to Language/Haskell/GhcMod/Options/DocUtils.hs
index 95fad26..c81dec8 100644
--- a/src/GHCMod/Options/DocUtils.hs
+++ b/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 .
-module GHCMod.Options.DocUtils (
+module Language.Haskell.GhcMod.Options.DocUtils (
($$),
($$$),
(<=>),
diff --git a/src/GHCMod/Options/Help.hs b/Language/Haskell/GhcMod/Options/Help.hs
similarity index 97%
rename from src/GHCMod/Options/Help.hs
rename to Language/Haskell/GhcMod/Options/Help.hs
index 9e33194..d43b6fb 100644
--- a/src/GHCMod/Options/Help.hs
+++ b/Language/Haskell/GhcMod/Options/Help.hs
@@ -15,7 +15,7 @@
-- along with this program. If not, see .
{-# 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)
diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs
new file mode 100644
index 0000000..7d4aa3a
--- /dev/null
+++ b/Language/Haskell/GhcMod/Options/Options.hs
@@ -0,0 +1,173 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015 Nikolay Yakimov
+--
+-- 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 .
+{-# 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)
diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs
index 43ed020..6c0a68e 100644
--- a/Language/Haskell/GhcMod/PathsAndFiles.hs
+++ b/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"
diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs
index 1df6948..b2d9e7d 100644
--- a/Language/Haskell/GhcMod/Pretty.hs
+++ b/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
diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs
index 11cfe3d..853f1cc 100644
--- a/Language/Haskell/GhcMod/Target.hs
+++ b/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")
diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs
index 42dac13..2281ba9 100644
--- a/Language/Haskell/GhcMod/Types.hs
+++ b/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)
diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs
index 89596b8..74ed5a2 100644
--- a/Language/Haskell/GhcMod/World.hs
+++ b/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
diff --git a/ghc-mod.cabal b/ghc-mod.cabal
index 01b9ea1..82b2261 100644
--- a/ghc-mod.cabal
+++ b/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
diff --git a/src/GHCMod.hs b/src/GHCMod.hs
index 531f7de..713d567 100644
--- a/src/GHCMod.hs
+++ b/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 ""
diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs
index e654c7e..c3cf263 100644
--- a/src/GHCMod/Options.hs
+++ b/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 GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.DocUtils
+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)
diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs
index 2e1f60a..a2ab3c0 100644
--- a/src/GHCMod/Options/Commands.hs
+++ b/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 GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Help
type Symbol = String
type Expr = String
diff --git a/stack.yaml b/stack.yaml
index fdcb756..1e26270 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,6 +1,5 @@
flags: {}
packages:
- '.'
-extra-deps:
-- cabal-helper-0.6.2.0
-resolver: lts-3.20
+extra-deps: []
+resolver: lts-5.3
diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs
index 6396437..c62a589 100644
--- a/test/CradleSpec.hs
+++ b/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"
diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs
index b2ac6e6..d3611f1 100644
--- a/test/PathsAndFilesSpec.hs
+++ b/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
diff --git a/test/TestUtils.hs b/test/TestUtils.hs
index 9ce67b5..af5367b 100644
--- a/test/TestUtils.hs
+++ b/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