Stderr output pre-GhcModT for stack cradle
This commit is contained in:
parent
2a0414f368
commit
0b65487e50
@ -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)
|
||||||
)
|
)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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 _) =
|
||||||
|
@ -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]
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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,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)
|
||||||
|
@ -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 {
|
||||||
outputStyle = PlainStyle
|
outputOpts = OutputOpts {
|
||||||
, lineSeparator = LineSeparator "\0"
|
outputStyle = PlainStyle
|
||||||
, linePrefix = Nothing
|
, lineSeparator = LineSeparator "\0"
|
||||||
, logLevel = GmWarning
|
, linePrefix = Nothing
|
||||||
|
, 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
|
||||||
|
@ -249,28 +249,29 @@ 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 $
|
||||||
o { ghcUserOptions = g : ghcUserOptions o }
|
o { ghcUserOptions = g : ghcUserOptions o }
|
||||||
|
|
||||||
{-
|
{-
|
||||||
File map docs:
|
File map docs:
|
||||||
@ -307,34 +308,34 @@ Exposed functions:
|
|||||||
mapped. Works exactly the same as `unmap-file` interactive command
|
mapped. Works exactly the same as `unmap-file` interactive command
|
||||||
-}
|
-}
|
||||||
, option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $
|
, option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $
|
||||||
reqArg "OPT" $ \g o ->
|
reqArg "OPT" $ \g o ->
|
||||||
let m = case second (drop 1) $ span (/='=') g of
|
let m = case second (drop 1) $ span (/='=') g of
|
||||||
(s,"") -> (s, Nothing)
|
(s,"") -> (s, Nothing)
|
||||||
(f,t) -> (f, Just t)
|
(f,t) -> (f, Just t)
|
||||||
in
|
in
|
||||||
Right $ o { fileMappings = m : fileMappings o }
|
Right $ o { fileMappings = m : fileMappings o }
|
||||||
|
|
||||||
, option "" ["with-ghc"] "GHC executable to use" $
|
, 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)" $
|
, 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" $
|
, 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" $
|
, 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" $
|
, option "" ["version"] "print version information" $
|
||||||
NoArg $ \_ -> Left ["version"]
|
NoArg $ \_ -> Left ["version"]
|
||||||
|
|
||||||
, 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
|
||||||
|
Loading…
Reference in New Issue
Block a user