hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Stderr output pre-GhcModT for stack cradle

Browse Source
This commit is contained in:
Daniel Gröber 2015-08-31 07:33:36 +02:00
parent 2a0414f368
commit 0b65487e50
13 changed files with 189 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Language/Haskell/GhcMod/CabalHelper.hs
View File

@ -147,13 +147,13 @@ getStackPackageDbStack = do
localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] ""
return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb]
patchStackPrograms :: IOish m => Cradle -> Programs -> m Programs
patchStackPrograms crdl progs
patchStackPrograms :: IOish m => OutputOpts -> Cradle -> Programs -> m Programs
patchStackPrograms _oopts crdl progs
| cradleProjectType crdl /= StackProject = return progs
patchStackPrograms crdl progs = do
patchStackPrograms oopts crdl progs = do
let projdir = cradleRootDir crdl
Just ghc <- liftIO $ getStackGhcPath projdir
Just ghcPkg <- liftIO $ getStackGhcPkgPath projdir
Just ghc <- liftIO $ getStackGhcPath oopts projdir
Just ghcPkg <- liftIO $ getStackGhcPkgPath oopts projdir
return $ progs {
ghcProgram = ghc
, ghcPkgProgram = ghcPkg
@ -288,10 +288,12 @@ chCached c = do
-- we don't need to include the disdir in the cache input because when it
-- changes the cache files will be gone anyways ;)
cacheInputData root = do
opt <- options
opts <- options
let oopts = outputOpts opts
progs = programs opts
crdl <- cradle
progs <- patchStackPrograms crdl (programs opt)
return $ ( helperProgs progs
progs' <- patchStackPrograms oopts crdl progs
return $ ( helperProgs progs'
, root
, (gmVer, chVer)
)

8
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -6,9 +6,11 @@ module Language.Haskell.GhcMod.CaseSplit (
import Data.List (find, intercalate)
import Data.Maybe (isJust)
import Data.Functor
import qualified Data.Text as T
import qualified Data.Text.IO as T (readFile)
import System.FilePath
import Prelude
import qualified DataCon as Ty
import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
@ -48,12 +50,12 @@ splits :: IOish m
-> GhcModT m String
splits file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do
opt <- options
oopts <- outputOpts <$> options
crdl <- cradle
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
(SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
let varName' = showName dflag style varName -- Convert name to string
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
@ -68,7 +70,7 @@ splits file lineNo colNo =
handler (SomeException ex) = do
gmLog GmException "splits" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
emptyResult =<< outputOpts <$> options
----------------------------------------------------------------
-- a. Code for getting the information of the variable

94
Language/Haskell/GhcMod/Convert.hs
View File

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

16
Language/Haskell/GhcMod/Cradle.hs
View File

@ -29,12 +29,12 @@ import Prelude
-- Find a cabal file by tracing ancestor directories.
-- Find a sandbox according to a cabal sandbox config
-- in a cabal directory.
findCradle :: IO Cradle
findCradle = findCradle' =<< getCurrentDirectory
findCradle :: OutputOpts -> IO Cradle
findCradle oopts = findCradle' oopts =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle
findCradle' dir = run $ do
(stackCradle dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir)
findCradle' :: OutputOpts -> FilePath -> IO Cradle
findCradle' oopts dir = run $ do
(stackCradle oopts dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir)
where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
findSpecCradle :: FilePath -> IO Cradle
@ -73,8 +73,8 @@ cabalCradle wdir = do
, cradleDistDir = "dist"
}
stackCradle :: FilePath -> MaybeT IO Cradle
stackCradle wdir = do
stackCradle :: OutputOpts -> FilePath -> MaybeT IO Cradle
stackCradle oopts wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
@ -85,7 +85,7 @@ stackCradle wdir = do
-- rather than stack, or maybe that's just me ;)
whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero
distDir <- MaybeT $ getStackDistDir cabalDir
distDir <- MaybeT $ getStackDistDir oopts cabalDir
return Cradle {
cradleProjectType = StackProject

6
Language/Haskell/GhcMod/Error.hs
View File

@ -140,9 +140,9 @@ gmeDoc e = case e of
++ intercalate "\", \"" cfs ++"\"."
GMECabalStateFile csfe ->
gmCsfeDoc csfe
GMEStackBootrap rv stderr ->
(text $ "Boostrapping stack project failed (exited with "++show rv++")")
<+>: text stderr
GMEStackBootrap msg ->
(text $ "Boostrapping stack project failed")
<+>: text msg
ghcExceptionDoc :: GhcException -> Doc
ghcExceptionDoc e@(CmdLineError _) =

40
Language/Haskell/GhcMod/FillSig.hs
View File

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

2
Language/Haskell/GhcMod/Info.hs
View File

@ -36,7 +36,7 @@ info file expr =
ghandle handler $
runGmlT' [Left file] deferErrors $
withInteractiveContext $
convert <$> options <*> body
convert . outputOpts <$> options <*> body
where
handler (SomeException ex) = do
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)

5
Language/Haskell/GhcMod/Logger.hs
View File

@ -30,6 +30,7 @@ import Language.Haskell.GhcMod.DynFlags (withDynFlags)
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
import Language.Haskell.GhcMod.Types
import qualified Language.Haskell.GhcMod.Gap as Gap
import Prelude
@ -81,8 +82,8 @@ withLogger :: (GmGhc m, GmEnv m, GmState m)
-> m (Either String (String, a))
withLogger f action = do
env <- G.getSession
opts <- options
let conv = convert opts
oopts <- outputOpts <$> options
let conv = convert oopts
eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action
return $ either (Left . conv) (Right . first conv) eres

17
Language/Haskell/GhcMod/Monad.hs
View File

@ -51,21 +51,22 @@ import Exception (ExceptionMonad(..))
import System.Directory
import Prelude
withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
withCradle cradledir f =
gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f
withCradle :: IOish m => OutputOpts -> FilePath -> (Cradle -> m a) -> m a
withCradle oopts cradledir f =
gbracket (liftIO $ findCradle' oopts cradledir) (liftIO . cleanupCradle) f
withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f)
withGhcModEnv dir opts f =
withCradle (outputOpts opts) dir (withGhcModEnv' opts f)
withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a
withGhcModEnv' opt f crdl = do
withGhcModEnv' opts f crdl = do
olddir <- liftIO getCurrentDirectory
c <- liftIO newChan
let outp = case linePrefix opt of
let outp = case linePrefix $ outputOpts opts of
Just _ -> GmOutputChan c
Nothing -> GmOutputStdio
gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp)
gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opts crdl outp)
where
setup c = liftIO $ do
setCurrentDirectory $ cradleRootDir crdl
@ -94,7 +95,7 @@ runGhcModT' :: IOish m
runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
withGhcModEnv dir' opt $ \env ->
first (fst <$>) <$> runGhcModT'' env defaultGhcModState
(gmSetLogLevel (logLevel opt) >> action)
(gmSetLogLevel (logLevel $ outputOpts opt) >> action)
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
-- computation. Note that if the computation that returned @result@ modified the

32
Language/Haskell/GhcMod/Output.hs
View File

@ -22,9 +22,10 @@ module Language.Haskell.GhcMod.Output (
, gmErrStr
, gmPutStrLn
, gmErrStrLn
, gmReadProcess
, gmUnsafePutStrLn
, gmUnsafeErrStrLn
, gmReadProcess
, gmUnsafeReadProcess
, stdoutGateway
) where
@ -36,6 +37,7 @@ import Control.Monad
import Control.DeepSeq
import Control.Exception
import Control.Concurrent
import Prelude
import Language.Haskell.GhcMod.Types hiding (LineSeparator)
import Language.Haskell.GhcMod.Monad.Types
@ -65,16 +67,16 @@ toGmLines s = GmLines GmPartial s
outputFns :: (GmEnv m, MonadIO m')
=> m (GmLines String -> m' (), GmLines String -> m' ())
outputFns = do
opts <- options
oopts <- outputOpts `liftM` options
env <- gmeAsk
return $ outputFns' opts (gmOutput env)
return $ outputFns' oopts (gmOutput env)
outputFns' :: MonadIO m'
=> Options
=> OutputOpts
-> GmOutput
-> (GmLines String -> m' (), GmLines String -> m' ())
outputFns' opts output = let
Options {..} = opts
OutputOpts {..} = opts
pfx f = withLines f
@ -108,9 +110,14 @@ gmErrStr str = do
-- | Only use these when you're sure there are no other writers on stdout
gmUnsafePutStrLn, gmUnsafeErrStrLn
:: MonadIO m => Options -> String -> m ()
gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines
gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines
:: MonadIO m => OutputOpts -> String -> m ()
gmUnsafePutStrLn oopts = (fst $ outputFns' oopts GmOutputStdio) . toGmLines
gmUnsafeErrStrLn oopts = (snd $ outputFns' oopts GmOutputStdio) . toGmLines
gmUnsafeReadProcess :: OutputOpts -> FilePath -> [String] -> String -> IO String
gmUnsafeReadProcess oopts =
readProcessStderrChan' (snd $ outputFns' oopts GmOutputStdio)
gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess = do
@ -146,8 +153,13 @@ stdoutGateway chan = go ("", "")
readProcessStderrChan ::
GmEnv m => m (FilePath -> [String] -> String -> IO String)
readProcessStderrChan = do
(_, e) <- outputFns
return $ go e
(_, e :: GmLines String -> IO ()) <- outputFns
return $ readProcessStderrChan' e
readProcessStderrChan' ::
(GmLines String -> IO ())
-> FilePath -> [String] -> String -> IO String
readProcessStderrChan' pute = go pute
where
go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String
go putErr exe args input = do

32
Language/Haskell/GhcMod/PathsAndFiles.hs
View File

@ -32,11 +32,11 @@ import System.Directory
import System.FilePath
import System.Process
import System.Info.Extra
import System.Exit
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Caching
import Language.Haskell.GhcMod.Output
import qualified Language.Haskell.GhcMod.Utils as U
import Utils (mightExist)
import Prelude
@ -77,21 +77,21 @@ findCabalFile dir = do
findStackConfigFile :: FilePath -> IO (Maybe FilePath)
findStackConfigFile dir = mightExist (dir </> "stack.yaml")
getStackDistDir :: FilePath -> IO (Maybe FilePath)
getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do
takeWhile (/='\n') <$> readStack ["path", "--dist-dir"]
getStackDistDir :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackDistDir oopts projdir = U.withDirectory_ projdir $ runMaybeT $ do
takeWhile (/='\n') <$> readStack oopts ["path", "--dist-dir"]
getStackGhcPath :: FilePath -> IO (Maybe FilePath)
getStackGhcPath = findExecutablesInStackBinPath "ghc"
getStackGhcPath :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackGhcPath oopts = findExecutablesInStackBinPath oopts "ghc"
getStackGhcPkgPath :: FilePath -> IO (Maybe FilePath)
getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg"
getStackGhcPkgPath :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackGhcPkgPath oopts = findExecutablesInStackBinPath oopts "ghc-pkg"
findExecutablesInStackBinPath :: String -> FilePath -> IO (Maybe FilePath)
findExecutablesInStackBinPath exe projdir =
findExecutablesInStackBinPath :: OutputOpts -> String -> FilePath -> IO (Maybe FilePath)
findExecutablesInStackBinPath oopts exe projdir =
U.withDirectory_ projdir $ runMaybeT $ do
path <- splitSearchPath . takeWhile (/='\n')
<$> readStack ["path", "--bin-path"]
<$> readStack oopts ["path", "--bin-path"]
MaybeT $ listToMaybe <$> findExecutablesInDirectories' path exe
findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
@ -103,13 +103,11 @@ findExecutablesInDirectories' path binary =
exeExtension = if isWindows then "exe" else ""
readStack :: [String] -> MaybeT IO String
readStack args = do
readStack :: OutputOpts -> [String] -> MaybeT IO String
readStack oopts args = do
stack <- MaybeT $ findExecutable "stack"
(e, out, err) <- liftIO $ readProcessWithExitCode stack args ""
case e of
ExitSuccess -> return out
(ExitFailure rv) -> throw $ GMEStackBootrap rv err
liftIO $ flip catch (\(e :: IOError) -> throw $ GMEStackBootrap $ show e) $ do
evaluate =<< gmUnsafeReadProcess oopts stack args ""
-- | Get path to sandbox config file
getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)

25
Language/Haskell/GhcMod/Types.hs
View File

@ -88,15 +88,19 @@ data Programs = Programs {
, stackProgram :: FilePath
} deriving (Show)
data Options = Options {
outputStyle :: OutputStyle
data OutputOpts = OutputOpts {
-- | Verbosity
logLevel :: GmLogLevel
, outputStyle :: OutputStyle
-- | Line separator string.
, lineSeparator :: LineSeparator
-- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
-- @snd@ is stderr prefix.
, linePrefix :: Maybe (String, String)
-- | Verbosity
, logLevel :: GmLogLevel
} deriving (Show)
data Options = Options {
outputOpts :: OutputOpts
, programs :: Programs
-- | GHC command line options set on the @ghc-mod@ command line
, ghcUserOptions:: [GHCOption]
@ -113,10 +117,12 @@ data Options = Options {
-- | A default 'Options'.
defaultOptions :: Options
defaultOptions = Options {
outputStyle = PlainStyle
, lineSeparator = LineSeparator "\0"
, linePrefix = Nothing
, logLevel = GmWarning
outputOpts = OutputOpts {
outputStyle = PlainStyle
, lineSeparator = LineSeparator "\0"
, linePrefix = Nothing
, logLevel = GmWarning
}
, programs = Programs {
ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg"
@ -379,7 +385,7 @@ data GhcModError
| GMECabalStateFile GMConfigStateFileError
-- ^ Reading Cabal's state configuration file falied somehow.
| GMEStackBootrap Int String
| GMEStackBootrap String
-- ^ Bootstrapping @stack@ environment failed (process exited with failure)
deriving (Eq,Show,Typeable)
@ -409,4 +415,5 @@ instance Serialize ChEntrypoint
mkLabel ''GhcModCaches
mkLabel ''GhcModState
mkLabel ''Options
mkLabel ''OutputOpts
mkLabel ''Programs

55
src/GHCMod.hs
View File

@ -249,28 +249,29 @@ intToLogLevel = toEnum
globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
globalArgSpec =
[ option "v" ["verbose"] "Increase or set log level. (0-7)" $
optArg "LEVEL" $ \ml o -> Right $ o {
logLevel = case ml of
Nothing -> increaseLogLevel (logLevel o)
Just l -> toEnum $ min 7 $ read l
}
optArg "LEVEL" $ \ml o -> Right $ case ml of
Nothing ->
modify (lLogLevel . lOutputOpts) increaseLogLevel o
Just l ->
set (lLogLevel . lOutputOpts) (toEnum $ min 7 $ read l) o
, option "s" [] "Be silent, set log level to 0" $
NoArg $ \o -> Right $ o { logLevel = toEnum 0 }
NoArg $ \o -> Right $ set (lLogLevel . lOutputOpts) (toEnum 0) o
, option "l" ["tolisp"] "Format output as an S-Expression" $
NoArg $ \o -> Right $ o { outputStyle = LispStyle }
NoArg $ \o -> Right $ set (lOutputStyle . lOutputOpts) LispStyle o
, option "b" ["boundary", "line-seperator"] "Output line separator"$
reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s }
reqArg "SEP" $ \s o -> Right $ set (lLineSeparator . lOutputOpts) (LineSeparator s) o
, option "" ["line-prefix"] "Output line separator"$
reqArg "OUT,ERR" $ \s o -> let
[out, err] = splitOn "," s
in Right $ o { linePrefix = Just (out, err) }
reqArg "OUT,ERR" $ \s o -> let
[out, err] = splitOn "," s
in Right $ set (lLinePrefix . lOutputOpts) (Just (out, err)) o
, option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
reqArg "OPT" $ \g o -> Right $
o { ghcUserOptions = g : ghcUserOptions o }
reqArg "OPT" $ \g o -> Right $
o { ghcUserOptions = g : ghcUserOptions o }
{-
File map docs:
@ -307,34 +308,34 @@ Exposed functions:
mapped. Works exactly the same as `unmap-file` interactive command
-}
, option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $
reqArg "OPT" $ \g o ->
let m = case second (drop 1) $ span (/='=') g of
(s,"") -> (s, Nothing)
(f,t) -> (f, Just t)
in
Right $ o { fileMappings = m : fileMappings o }
reqArg "OPT" $ \g o ->
let m = case second (drop 1) $ span (/='=') g of
(s,"") -> (s, Nothing)
(f,t) -> (f, Just t)
in
Right $ o { fileMappings = m : fileMappings o }
, option "" ["with-ghc"] "GHC executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lPrograms) p o
reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lPrograms) p o
, option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lPrograms) p o
reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lPrograms) p o
, option "" ["with-cabal"] "cabal-install executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lPrograms) p o
reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lPrograms) p o
, option "" ["with-stack"] "stack executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lPrograms) p o
reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lPrograms) p o
, option "" ["version"] "print version information" $
NoArg $ \_ -> Left ["version"]
NoArg $ \_ -> Left ["version"]
, option "" ["help"] "print this help message" $
NoArg $ \_ -> Left ["help"]
NoArg $ \_ -> Left ["help"]
]
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv
= case O.getOpt' RequireOrder globalArgSpec argv of
@ -555,7 +556,7 @@ exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a
exitError' opts msg =
gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
gmUnsafeErrStrLn (outputOpts opts) (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s