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"] "" localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] ""
return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb] return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb]
patchStackPrograms :: IOish m => Cradle -> Programs -> m Programs patchStackPrograms :: IOish m => OutputOpts -> Cradle -> Programs -> m Programs
patchStackPrograms crdl progs patchStackPrograms _oopts crdl progs
| cradleProjectType crdl /= StackProject = return progs | cradleProjectType crdl /= StackProject = return progs
patchStackPrograms crdl progs = do patchStackPrograms oopts crdl progs = do
let projdir = cradleRootDir crdl let projdir = cradleRootDir crdl
Just ghc <- liftIO $ getStackGhcPath projdir Just ghc <- liftIO $ getStackGhcPath oopts projdir
Just ghcPkg <- liftIO $ getStackGhcPkgPath projdir Just ghcPkg <- liftIO $ getStackGhcPkgPath oopts projdir
return $ progs { return $ progs {
ghcProgram = ghc ghcProgram = ghc
, ghcPkgProgram = ghcPkg , ghcPkgProgram = ghcPkg
@ -288,10 +288,12 @@ chCached c = do
-- we don't need to include the disdir in the cache input because when it -- we don't need to include the disdir in the cache input because when it
-- changes the cache files will be gone anyways ;) -- changes the cache files will be gone anyways ;)
cacheInputData root = do cacheInputData root = do
opt <- options opts <- options
let oopts = outputOpts opts
progs = programs opts
crdl <- cradle crdl <- cradle
progs <- patchStackPrograms crdl (programs opt) progs' <- patchStackPrograms oopts crdl progs
return $ ( helperProgs progs return $ ( helperProgs progs'
, root , root
, (gmVer, chVer) , (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.List (find, intercalate)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Functor
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T (readFile) import qualified Data.Text.IO as T (readFile)
import System.FilePath import System.FilePath
import Prelude
import qualified DataCon as Ty import qualified DataCon as Ty
import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
@ -48,12 +50,12 @@ splits :: IOish m
-> GhcModT m String -> GhcModT m String
splits file lineNo colNo = splits file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do ghandle handler $ runGmlT' [Left file] deferErrors $ do
opt <- options oopts <- outputOpts <$> options
crdl <- cradle crdl <- cradle
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file) 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 (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
let varName' = showName dflag style varName -- Convert name to string let varName' = showName dflag style varName -- Convert name to string
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
@ -68,7 +70,7 @@ splits file lineNo colNo =
handler (SomeException ex) = do handler (SomeException ex) = do
gmLog GmException "splits" $ gmLog GmException "splits" $
text "" $$ nest 4 (showDoc ex) text "" $$ nest 4 (showDoc ex)
emptyResult =<< options emptyResult =<< outputOpts <$> options
---------------------------------------------------------------- ----------------------------------------------------------------
-- a. Code for getting the information of the variable -- a. Code for getting the information of the variable

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

@ -25,25 +25,25 @@ inter _ [] = id
inter c bs = foldr1 (\x y -> x . (c:) . y) bs inter c bs = foldr1 (\x y -> x . (c:) . y) bs
convert' :: (ToString a, IOish m, GmEnv m) => a -> m String 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 :: ToString a => OutputOpts -> a -> String
convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" convert opt@OutputOpts { outputStyle = LispStyle } x = toLisp opt x "\n"
convert opt@Options { outputStyle = PlainStyle } x convert opt@OutputOpts { outputStyle = PlainStyle } x
| str == "\n" = "" | str == "\n" = ""
| otherwise = str | otherwise = str
where where
str = toPlain opt x "\n" str = toPlain opt x "\n"
class ToString a where class ToString a where
toLisp :: Options -> a -> Builder toLisp :: OutputOpts -> a -> Builder
toPlain :: Options -> a -> Builder toPlain :: OutputOpts -> a -> Builder
lineSep :: Options -> String lineSep :: OutputOpts -> String
lineSep opt = interpret lsep lineSep oopts = interpret lsep
where where
interpret s = read $ "\"" ++ s ++ "\"" interpret s = read $ "\"" ++ s ++ "\""
LineSeparator lsep = lineSeparator opt LineSeparator lsep = lineSeparator oopts
-- | -- |
-- --
@ -52,8 +52,8 @@ lineSep opt = interpret lsep
-- >>> toPlain defaultOptions "foo" "" -- >>> toPlain defaultOptions "foo" ""
-- "foo" -- "foo"
instance ToString String where instance ToString String where
toLisp opt = quote opt toLisp oopts = quote oopts
toPlain opt = replace '\n' (lineSep opt) toPlain oopts = replace '\n' (lineSep oopts)
-- | -- |
-- --
@ -62,12 +62,12 @@ instance ToString String where
-- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
-- "foo\nbar\nbaz" -- "foo\nbar\nbaz"
instance ToString [String] where instance ToString [String] where
toLisp opt = toSexp1 opt toLisp oopts = toSexp1 oopts
toPlain opt = inter '\n' . map (toPlain opt) toPlain oopts = inter '\n' . map (toPlain oopts)
instance ToString [ModuleString] where instance ToString [ModuleString] where
toLisp opt = toLisp opt . map getModuleString toLisp oopts = toLisp oopts . map getModuleString
toPlain opt = toPlain opt . map getModuleString toPlain oopts = toPlain oopts . map getModuleString
-- | -- |
-- --
@ -77,47 +77,47 @@ instance ToString [ModuleString] where
-- >>> toPlain defaultOptions inp "" -- >>> toPlain defaultOptions inp ""
-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
instance ToString [((Int,Int,Int,Int),String)] where instance ToString [((Int,Int,Int,Int),String)] where
toLisp opt = toSexp2 . map toS toLisp oopts = toSexp2 . map toS
where where
toS x = ('(' :) . tupToString opt x . (')' :) toS x = ('(' :) . tupToString oopts x . (')' :)
toPlain opt = inter '\n' . map (tupToString opt) toPlain oopts = inter '\n' . map (tupToString oopts)
instance ToString ((Int,Int,Int,Int),String) where instance ToString ((Int,Int,Int,Int),String) where
toLisp opt x = ('(' :) . tupToString opt x . (')' :) toLisp oopts x = ('(' :) . tupToString oopts x . (')' :)
toPlain opt x = tupToString opt x toPlain oopts x = tupToString oopts x
instance ToString ((Int,Int,Int,Int),[String]) where instance ToString ((Int,Int,Int,Int),[String]) where
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . toLisp oopts (x,s) = ('(' :) . fourIntsToString x .
(' ' :) . toLisp opt s . (')' :) (' ' :) . toLisp oopts s . (')' :)
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s
instance ToString (String, (Int,Int,Int,Int),[String]) where instance ToString (String, (Int,Int,Int,Int),[String]) where
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] toLisp oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y]
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y]
toSexp1 :: Options -> [String] -> Builder toSexp1 :: OutputOpts -> [String] -> Builder
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)
toSexp2 :: [Builder] -> Builder toSexp2 :: [Builder] -> Builder
toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)
fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder fourIntsToString :: (Int,Int,Int,Int) -> Builder
fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :) fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)
. (show b ++) . (' ' :) . (show b ++) . (' ' :)
. (show c ++) . (' ' :) . (show c ++) . (' ' :)
. (show d ++) . (show d ++)
tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder
tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :) tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)
. (show b ++) . (' ' :) . (show b ++) . (' ' :)
. (show c ++) . (' ' :) . (show c ++) . (' ' :)
. (show d ++) . (' ' :) . (show d ++) . (' ' :)
. quote opt s -- fixme: quote is not necessary . quote oopts s -- fixme: quote is not necessary
quote :: Options -> String -> Builder quote :: OutputOpts -> String -> Builder
quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) quote oopts str = ("\"" ++) . (quote' str ++) . ("\"" ++)
where where
lsep = lineSep opt lsep = lineSep oopts
quote' [] = [] quote' [] = []
quote' (x:xs) quote' (x:xs)
| x == '\n' = lsep ++ quote' 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 -- Empty result to be returned when no info can be gathered
emptyResult :: Monad m => Options -> m String emptyResult :: Monad m => OutputOpts -> m String
emptyResult opt = return $ convert opt ([] :: [String]) emptyResult oopts = return $ convert oopts ([] :: [String])
-- Return an emptyResult when Nothing -- Return an emptyResult when Nothing
whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String
whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from
-- Return an emptyResult when Nothing, inside a monad -- Return an emptyResult when Nothing, inside a monad
whenFound' :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> m b) -> m String whenFound' :: (Monad m, ToString b) => OutputOpts -> 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' 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 cabal file by tracing ancestor directories.
-- Find a sandbox according to a cabal sandbox config -- Find a sandbox according to a cabal sandbox config
-- in a cabal directory. -- in a cabal directory.
findCradle :: IO Cradle findCradle :: OutputOpts -> IO Cradle
findCradle = findCradle' =<< getCurrentDirectory findCradle oopts = findCradle' oopts =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle findCradle' :: OutputOpts -> FilePath -> IO Cradle
findCradle' dir = run $ do findCradle' oopts dir = run $ do
(stackCradle dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir) (stackCradle oopts dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir)
where run a = fillTempDir =<< (fromJust <$> runMaybeT a) where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
findSpecCradle :: FilePath -> IO Cradle findSpecCradle :: FilePath -> IO Cradle
@ -73,8 +73,8 @@ cabalCradle wdir = do
, cradleDistDir = "dist" , cradleDistDir = "dist"
} }
stackCradle :: FilePath -> MaybeT IO Cradle stackCradle :: OutputOpts -> FilePath -> MaybeT IO Cradle
stackCradle wdir = do stackCradle oopts wdir = do
cabalFile <- MaybeT $ findCabalFile wdir cabalFile <- MaybeT $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile let cabalDir = takeDirectory cabalFile
@ -85,7 +85,7 @@ stackCradle wdir = do
-- rather than stack, or maybe that's just me ;) -- rather than stack, or maybe that's just me ;)
whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero
distDir <- MaybeT $ getStackDistDir cabalDir distDir <- MaybeT $ getStackDistDir oopts cabalDir
return Cradle { return Cradle {
cradleProjectType = StackProject cradleProjectType = StackProject

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

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

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

@ -36,7 +36,7 @@ info file expr =
ghandle handler $ ghandle handler $
runGmlT' [Left file] deferErrors $ runGmlT' [Left file] deferErrors $
withInteractiveContext $ withInteractiveContext $
convert <$> options <*> body convert . outputOpts <$> options <*> body
where where
handler (SomeException ex) = do handler (SomeException ex) = do
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex) 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.Monad.Types
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc) import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
import Language.Haskell.GhcMod.Types
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Prelude import Prelude
@ -81,8 +82,8 @@ withLogger :: (GmGhc m, GmEnv m, GmState m)
-> m (Either String (String, a)) -> m (Either String (String, a))
withLogger f action = do withLogger f action = do
env <- G.getSession env <- G.getSession
opts <- options oopts <- outputOpts <$> options
let conv = convert opts let conv = convert oopts
eres <- withLogger' env $ \setDf -> eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action withDynFlags (f . setDf) action
return $ either (Left . conv) (Right . first conv) eres 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 System.Directory
import Prelude import Prelude
withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a withCradle :: IOish m => OutputOpts -> FilePath -> (Cradle -> m a) -> m a
withCradle cradledir f = withCradle oopts cradledir f =
gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f gbracket (liftIO $ findCradle' oopts cradledir) (liftIO . cleanupCradle) f
withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a 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' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a
withGhcModEnv' opt f crdl = do withGhcModEnv' opts f crdl = do
olddir <- liftIO getCurrentDirectory olddir <- liftIO getCurrentDirectory
c <- liftIO newChan c <- liftIO newChan
let outp = case linePrefix opt of let outp = case linePrefix $ outputOpts opts of
Just _ -> GmOutputChan c Just _ -> GmOutputChan c
Nothing -> GmOutputStdio Nothing -> GmOutputStdio
gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp) gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opts crdl outp)
where where
setup c = liftIO $ do setup c = liftIO $ do
setCurrentDirectory $ cradleRootDir crdl setCurrentDirectory $ cradleRootDir crdl
@ -94,7 +95,7 @@ runGhcModT' :: IOish m
runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
withGhcModEnv dir' opt $ \env -> withGhcModEnv dir' opt $ \env ->
first (fst <$>) <$> runGhcModT'' env defaultGhcModState 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 -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
-- computation. Note that if the computation that returned @result@ modified the -- 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 , gmErrStr
, gmPutStrLn , gmPutStrLn
, gmErrStrLn , gmErrStrLn
, gmReadProcess
, gmUnsafePutStrLn , gmUnsafePutStrLn
, gmUnsafeErrStrLn , gmUnsafeErrStrLn
, gmReadProcess , gmUnsafeReadProcess
, stdoutGateway , stdoutGateway
) where ) where
@ -36,6 +37,7 @@ import Control.Monad
import Control.DeepSeq import Control.DeepSeq
import Control.Exception import Control.Exception
import Control.Concurrent import Control.Concurrent
import Prelude
import Language.Haskell.GhcMod.Types hiding (LineSeparator) import Language.Haskell.GhcMod.Types hiding (LineSeparator)
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
@ -65,16 +67,16 @@ toGmLines s = GmLines GmPartial s
outputFns :: (GmEnv m, MonadIO m') outputFns :: (GmEnv m, MonadIO m')
=> m (GmLines String -> m' (), GmLines String -> m' ()) => m (GmLines String -> m' (), GmLines String -> m' ())
outputFns = do outputFns = do
opts <- options oopts <- outputOpts `liftM` options
env <- gmeAsk env <- gmeAsk
return $ outputFns' opts (gmOutput env) return $ outputFns' oopts (gmOutput env)
outputFns' :: MonadIO m' outputFns' :: MonadIO m'
=> Options => OutputOpts
-> GmOutput -> GmOutput
-> (GmLines String -> m' (), GmLines String -> m' ()) -> (GmLines String -> m' (), GmLines String -> m' ())
outputFns' opts output = let outputFns' opts output = let
Options {..} = opts OutputOpts {..} = opts
pfx f = withLines f 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 -- | Only use these when you're sure there are no other writers on stdout
gmUnsafePutStrLn, gmUnsafeErrStrLn gmUnsafePutStrLn, gmUnsafeErrStrLn
:: MonadIO m => Options -> String -> m () :: MonadIO m => OutputOpts -> String -> m ()
gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines gmUnsafePutStrLn oopts = (fst $ outputFns' oopts GmOutputStdio) . toGmLines
gmUnsafeErrStrLn opts = (snd $ outputFns' opts 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 :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess = do gmReadProcess = do
@ -146,8 +153,13 @@ stdoutGateway chan = go ("", "")
readProcessStderrChan :: readProcessStderrChan ::
GmEnv m => m (FilePath -> [String] -> String -> IO String) GmEnv m => m (FilePath -> [String] -> String -> IO String)
readProcessStderrChan = do readProcessStderrChan = do
(_, e) <- outputFns (_, e :: GmLines String -> IO ()) <- outputFns
return $ go e return $ readProcessStderrChan' e
readProcessStderrChan' ::
(GmLines String -> IO ())
-> FilePath -> [String] -> String -> IO String
readProcessStderrChan' pute = go pute
where where
go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String
go putErr exe args input = do 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.FilePath
import System.Process import System.Process
import System.Info.Extra import System.Info.Extra
import System.Exit
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Caching import Language.Haskell.GhcMod.Caching
import Language.Haskell.GhcMod.Output
import qualified Language.Haskell.GhcMod.Utils as U import qualified Language.Haskell.GhcMod.Utils as U
import Utils (mightExist) import Utils (mightExist)
import Prelude import Prelude
@ -77,21 +77,21 @@ findCabalFile dir = do
findStackConfigFile :: FilePath -> IO (Maybe FilePath) findStackConfigFile :: FilePath -> IO (Maybe FilePath)
findStackConfigFile dir = mightExist (dir </> "stack.yaml") findStackConfigFile dir = mightExist (dir </> "stack.yaml")
getStackDistDir :: FilePath -> IO (Maybe FilePath) getStackDistDir :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do getStackDistDir oopts projdir = U.withDirectory_ projdir $ runMaybeT $ do
takeWhile (/='\n') <$> readStack ["path", "--dist-dir"] takeWhile (/='\n') <$> readStack oopts ["path", "--dist-dir"]
getStackGhcPath :: FilePath -> IO (Maybe FilePath) getStackGhcPath :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackGhcPath = findExecutablesInStackBinPath "ghc" getStackGhcPath oopts = findExecutablesInStackBinPath oopts "ghc"
getStackGhcPkgPath :: FilePath -> IO (Maybe FilePath) getStackGhcPkgPath :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg" getStackGhcPkgPath oopts = findExecutablesInStackBinPath oopts "ghc-pkg"
findExecutablesInStackBinPath :: String -> FilePath -> IO (Maybe FilePath) findExecutablesInStackBinPath :: OutputOpts -> String -> FilePath -> IO (Maybe FilePath)
findExecutablesInStackBinPath exe projdir = findExecutablesInStackBinPath oopts exe projdir =
U.withDirectory_ projdir $ runMaybeT $ do U.withDirectory_ projdir $ runMaybeT $ do
path <- splitSearchPath . takeWhile (/='\n') path <- splitSearchPath . takeWhile (/='\n')
<$> readStack ["path", "--bin-path"] <$> readStack oopts ["path", "--bin-path"]
MaybeT $ listToMaybe <$> findExecutablesInDirectories' path exe MaybeT $ listToMaybe <$> findExecutablesInDirectories' path exe
findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
@ -103,13 +103,11 @@ findExecutablesInDirectories' path binary =
exeExtension = if isWindows then "exe" else "" exeExtension = if isWindows then "exe" else ""
readStack :: [String] -> MaybeT IO String readStack :: OutputOpts -> [String] -> MaybeT IO String
readStack args = do readStack oopts args = do
stack <- MaybeT $ findExecutable "stack" stack <- MaybeT $ findExecutable "stack"
(e, out, err) <- liftIO $ readProcessWithExitCode stack args "" liftIO $ flip catch (\(e :: IOError) -> throw $ GMEStackBootrap $ show e) $ do
case e of evaluate =<< gmUnsafeReadProcess oopts stack args ""
ExitSuccess -> return out
(ExitFailure rv) -> throw $ GMEStackBootrap rv err
-- | Get path to sandbox config file -- | Get path to sandbox config file
getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb) getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)

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

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

23
src/GHCMod.hs
View File

@ -249,24 +249,25 @@ intToLogLevel = toEnum
globalArgSpec :: [OptDescr (Options -> Either [String] Options)] globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
globalArgSpec = globalArgSpec =
[ option "v" ["verbose"] "Increase or set log level. (0-7)" $ [ option "v" ["verbose"] "Increase or set log level. (0-7)" $
optArg "LEVEL" $ \ml o -> Right $ o { optArg "LEVEL" $ \ml o -> Right $ case ml of
logLevel = case ml of Nothing ->
Nothing -> increaseLogLevel (logLevel o) modify (lLogLevel . lOutputOpts) increaseLogLevel o
Just l -> toEnum $ min 7 $ read l Just l ->
} set (lLogLevel . lOutputOpts) (toEnum $ min 7 $ read l) o
, option "s" [] "Be silent, set log level to 0" $ , 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" $ , 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"$ , 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"$ , option "" ["line-prefix"] "Output line separator"$
reqArg "OUT,ERR" $ \s o -> let reqArg "OUT,ERR" $ \s o -> let
[out, err] = splitOn "," s [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" $ , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
reqArg "OPT" $ \g o -> Right $ reqArg "OPT" $ \g o -> Right $
@ -331,10 +332,10 @@ Exposed functions:
, option "" ["help"] "print this help message" $ , option "" ["help"] "print this help message" $
NoArg $ \_ -> Left ["help"] NoArg $ \_ -> Left ["help"]
] ]
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String]) parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv parseGlobalArgs argv
= case O.getOpt' RequireOrder globalArgSpec argv of = 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' :: Options -> String -> IO a
exitError' opts msg = exitError' opts msg =
gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure gmUnsafeErrStrLn (outputOpts opts) (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
fatalError :: String -> a fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s fatalError s = throw $ FatalError $ "ghc-mod: " ++ s