Stderr output pre-GhcModT for stack cradle
This commit is contained in:
Daniel Gröber
parent
2a0414f368
commit
0b65487e50
@ -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)
|
||||
)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ++) . (' ' :)
|
||||
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 ++) . (' ' :)
|
||||
tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder
|
||||
tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)
|
||||
. (show b ++) . (' ' :)
|
||||
. (show c ++) . (' ' :)
|
||||
. (show d ++) . (' ' :)
|
||||
. quote opt s -- fixme: quote is not necessary
|
||||
. 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 _) =
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,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)
|
||||
|
||||
@ -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 {
|
||||
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
|
||||
|
||||
@ -249,24 +249,25 @@ 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) }
|
||||
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 $
|
||||
@ -331,10 +332,10 @@ Exposed functions:
|
||||
|
||||
, option "" ["help"] "print this help message" $
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user