From 0b65487e508cf972c9fa763cc2210496cb6c0569 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 31 Aug 2015 07:33:36 +0200 Subject: [PATCH] Stderr output pre-GhcModT for stack cradle --- Language/Haskell/GhcMod/CabalHelper.hs | 18 +++-- Language/Haskell/GhcMod/CaseSplit.hs | 8 +- Language/Haskell/GhcMod/Convert.hs | 94 ++++++++++++------------ Language/Haskell/GhcMod/Cradle.hs | 16 ++-- Language/Haskell/GhcMod/Error.hs | 6 +- Language/Haskell/GhcMod/FillSig.hs | 40 +++++----- Language/Haskell/GhcMod/Info.hs | 2 +- Language/Haskell/GhcMod/Logger.hs | 5 +- Language/Haskell/GhcMod/Monad.hs | 17 +++-- Language/Haskell/GhcMod/Output.hs | 32 +++++--- Language/Haskell/GhcMod/PathsAndFiles.hs | 32 ++++---- Language/Haskell/GhcMod/Types.hs | 25 ++++--- src/GHCMod.hs | 55 +++++++------- 13 files changed, 189 insertions(+), 161 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 9603805..b339a12 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -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) ) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 1db05d7..3283e30 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 2715696..a17abd0 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index b348b89..7a64d26 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 3a3c786..2bb3f4e 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -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 _) = diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index ed1a769..f3c03a5 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -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] diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index e952838..b3f1c52 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -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) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 2cb3247..ef5b556 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index adc7114..172b296 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index 6e3f36c..6115707 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/Language/Haskell/GhcMod/Output.hs @@ -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 diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 1b75940..c0fd19b 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -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) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index ff893fb..135e157 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index f27fc03..4d2af4c 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -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