Improve style
This commit is contained in:
Sergey Vinokurov
parent
a23f1f3b75
commit
4a9d578681
|
|
@ -9,8 +9,9 @@ import Language.Haskell.GhcMod.Modules
|
||||||
|
|
||||||
-- | Printing necessary information for front-end booting.
|
-- | Printing necessary information for front-end booting.
|
||||||
boot :: IOish m => GhcModT m String
|
boot :: IOish m => GhcModT m String
|
||||||
boot = concat <$> sequence [modules, languages, flags,
|
boot = concat <$> sequence ms
|
||||||
concat <$> mapM browse preBrowsedModules]
|
where
|
||||||
|
ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
|
||||||
|
|
||||||
preBrowsedModules :: [String]
|
preBrowsedModules :: [String]
|
||||||
preBrowsedModules = [
|
preBrowsedModules = [
|
||||||
|
|
|
||||||
|
|
@ -48,7 +48,7 @@ browse pkgmdl = do
|
||||||
|
|
||||||
tryModuleInfo m = fromJust <$> G.getModuleInfo m
|
tryModuleInfo m = fromJust <$> G.getModuleInfo m
|
||||||
|
|
||||||
(mpkg,mdl) = splitPkgMdl pkgmdl
|
(mpkg, mdl) = splitPkgMdl pkgmdl
|
||||||
mdlname = G.mkModuleName mdl
|
mdlname = G.mkModuleName mdl
|
||||||
mpkgid = mkFastString <$> mpkg
|
mpkgid = mkFastString <$> mpkg
|
||||||
|
|
||||||
|
|
@ -59,9 +59,10 @@ browse pkgmdl = do
|
||||||
-- >>> splitPkgMdl "Prelude"
|
-- >>> splitPkgMdl "Prelude"
|
||||||
-- (Nothing,"Prelude")
|
-- (Nothing,"Prelude")
|
||||||
splitPkgMdl :: String -> (Maybe String,String)
|
splitPkgMdl :: String -> (Maybe String,String)
|
||||||
splitPkgMdl pkgmdl = case break (==':') pkgmdl of
|
splitPkgMdl pkgmdl =
|
||||||
(mdl,"") -> (Nothing,mdl)
|
case break (==':') pkgmdl of
|
||||||
(pkg,_:mdl) -> (Just pkg,mdl)
|
(mdl, "") -> (Nothing, mdl)
|
||||||
|
(pkg, _:mdl) -> (Just pkg, mdl)
|
||||||
|
|
||||||
-- Haskell 2010:
|
-- Haskell 2010:
|
||||||
-- small -> ascSmall | uniSmall | _
|
-- small -> ascSmall | uniSmall | _
|
||||||
|
|
|
||||||
|
|
@ -27,7 +27,7 @@ convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
|
||||||
convert' x = flip convert x <$> options
|
convert' x = flip convert x <$> options
|
||||||
|
|
||||||
convert :: ToString a => Options -> a -> String
|
convert :: ToString a => Options -> a -> String
|
||||||
convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n"
|
convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n"
|
||||||
convert opt@Options { outputStyle = PlainStyle } x
|
convert opt@Options { outputStyle = PlainStyle } x
|
||||||
| str == "\n" = ""
|
| str == "\n" = ""
|
||||||
| otherwise = str
|
| otherwise = str
|
||||||
|
|
@ -35,8 +35,8 @@ convert opt@Options { outputStyle = PlainStyle } x
|
||||||
str = toPlain opt x "\n"
|
str = toPlain opt x "\n"
|
||||||
|
|
||||||
class ToString a where
|
class ToString a where
|
||||||
toLisp :: Options -> a -> Builder
|
toLisp :: Options -> a -> Builder
|
||||||
toPlain :: Options -> a -> Builder
|
toPlain :: Options -> a -> Builder
|
||||||
|
|
||||||
lineSep :: Options -> String
|
lineSep :: Options -> String
|
||||||
lineSep opt = interpret lsep
|
lineSep opt = interpret lsep
|
||||||
|
|
@ -51,8 +51,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 opt = quote opt
|
||||||
toPlain opt = replace '\n' (lineSep opt)
|
toPlain opt = replace '\n' (lineSep opt)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
|
|
@ -61,8 +61,8 @@ 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 opt = toSexp1 opt
|
||||||
toPlain opt = inter '\n' . map (toPlain opt)
|
toPlain opt = inter '\n' . map (toPlain opt)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
|
|
@ -72,23 +72,23 @@ instance ToString [String] 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 opt = toSexp2 . map toS
|
||||||
where
|
where
|
||||||
toS x = ('(' :) . tupToString opt x . (')' :)
|
toS x = ('(' :) . tupToString opt x . (')' :)
|
||||||
toPlain opt = inter '\n' . map (tupToString opt)
|
toPlain opt = inter '\n' . map (tupToString opt)
|
||||||
|
|
||||||
instance ToString ((Int,Int,Int,Int),String) where
|
instance ToString ((Int,Int,Int,Int),String) where
|
||||||
toLisp opt x = ('(' :) . tupToString opt x . (')' :)
|
toLisp opt x = ('(' :) . tupToString opt x . (')' :)
|
||||||
toPlain opt x = tupToString opt x
|
toPlain opt x = tupToString opt 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 opt (x,s) = ('(' :) . fourIntsToString opt x .
|
||||||
(' ' :) . toLisp opt s . (')' :)
|
(' ' :) . toLisp opt s . (')' :)
|
||||||
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
|
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt 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 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]
|
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
|
||||||
|
|
||||||
toSexp1 :: Options -> [String] -> Builder
|
toSexp1 :: Options -> [String] -> Builder
|
||||||
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
||||||
|
|
|
||||||
|
|
@ -79,17 +79,14 @@ sig file lineNo colNo =
|
||||||
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)
|
||||||
|
|
||||||
InstanceDecl loc cls -> let
|
InstanceDecl loc cls ->
|
||||||
body x = initialBody dflag style (G.idType x) x
|
let body x = initialBody dflag style (G.idType x) x
|
||||||
in
|
in ("instance", fourInts loc, body `map` Ty.classMethods cls)
|
||||||
("instance", fourInts loc, body `map` Ty.classMethods cls)
|
|
||||||
|
|
||||||
TyFamDecl loc name flavour vars ->
|
TyFamDecl loc name flavour vars ->
|
||||||
let (rTy, initial) = initialTyFamString flavour
|
let (rTy, initial) = initialTyFamString flavour
|
||||||
body = initialFamBody dflag style name vars
|
body = initialFamBody dflag style name vars
|
||||||
in (rTy, fourInts loc, [initial ++ body])
|
in (rTy, fourInts loc, [initial ++ body])
|
||||||
|
|
||||||
|
|
||||||
where
|
where
|
||||||
fallback (SomeException _) = do
|
fallback (SomeException _) = do
|
||||||
opt <- options
|
opt <- options
|
||||||
|
|
@ -244,9 +241,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String
|
||||||
initialHead1 fname args elts =
|
initialHead1 fname args elts =
|
||||||
case initialBodyArgs1 args elts of
|
case initialBodyArgs1 args elts of
|
||||||
[] -> fname
|
[] -> fname
|
||||||
arglist -> if isSymbolName fname
|
arglist
|
||||||
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
| isSymbolName fname ->
|
||||||
else fname ++ " " ++ unwords arglist
|
head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||||
|
| otherwise ->
|
||||||
|
fname ++ " " ++ unwords arglist
|
||||||
|
|
||||||
initialBodyArgs1 :: [FnArg] -> [String] -> [String]
|
initialBodyArgs1 :: [FnArg] -> [String] -> [String]
|
||||||
initialBodyArgs1 args elts = take (length args) elts
|
initialBodyArgs1 args elts = take (length args) elts
|
||||||
|
|
@ -338,39 +337,45 @@ refine :: IOish m
|
||||||
-> Expression -- ^ A Haskell expression.
|
-> Expression -- ^ A Haskell expression.
|
||||||
-> GhcModT m String
|
-> GhcModT m String
|
||||||
refine file lineNo colNo expr =
|
refine file lineNo colNo expr =
|
||||||
ghandle handler $ runGmlT' [Left file] deferErrors $ do
|
ghandle handler $
|
||||||
opt <- options
|
runGmlT' [Left file] deferErrors $ do
|
||||||
style <- getStyle
|
opt <- options
|
||||||
dflag <- G.getSessionDynFlags
|
style <- getStyle
|
||||||
modSum <- Gap.fileModSummary file
|
dflag <- G.getSessionDynFlags
|
||||||
p <- G.parseModule modSum
|
modSum <- Gap.fileModSummary file
|
||||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
p <- G.parseModule modSum
|
||||||
ety <- G.exprType expr
|
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||||
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
|
ety <- G.exprType expr
|
||||||
\(loc, name, rty, paren) ->
|
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
|
||||||
let eArgs = getFnArgs ety
|
\(loc, name, rty, paren) ->
|
||||||
rArgs = getFnArgs rty
|
let eArgs = getFnArgs ety
|
||||||
diffArgs' = length eArgs - length rArgs
|
rArgs = getFnArgs rty
|
||||||
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
|
diffArgs' = length eArgs - length rArgs
|
||||||
iArgs = take diffArgs eArgs
|
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
|
||||||
text = initialHead1 expr iArgs (infinitePrefixSupply name)
|
iArgs = take diffArgs eArgs
|
||||||
in (fourInts loc, doParen paren text)
|
text = initialHead1 expr iArgs (infinitePrefixSupply name)
|
||||||
|
in (fourInts loc, doParen paren text)
|
||||||
where
|
where
|
||||||
handler (SomeException _) = emptyResult =<< options
|
handler (SomeException _) = emptyResult =<< options
|
||||||
|
|
||||||
-- Look for the variable in the specified position
|
-- Look for the variable in the specified position
|
||||||
findVar :: GhcMonad m => DynFlags -> PprStyle
|
findVar
|
||||||
-> G.TypecheckedModule -> G.TypecheckedSource
|
:: GhcMonad m
|
||||||
-> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
|
=> DynFlags
|
||||||
|
-> PprStyle
|
||||||
|
-> G.TypecheckedModule
|
||||||
|
-> G.TypecheckedSource
|
||||||
|
-> Int
|
||||||
|
-> Int
|
||||||
|
-> m (Maybe (SrcSpan, String, Type, Bool))
|
||||||
findVar dflag style tcm tcs lineNo colNo =
|
findVar dflag style tcm tcs lineNo colNo =
|
||||||
case lst of
|
case lst of
|
||||||
e@(L _ (G.HsVar i)):others -> do
|
e@(L _ (G.HsVar i)):others -> do
|
||||||
tyInfo <- Gap.getType tcm e
|
tyInfo <- Gap.getType tcm e
|
||||||
case tyInfo of
|
case tyInfo of
|
||||||
Just (span, typ)
|
Just (s, typ)
|
||||||
| name == "undefined" || head name == '_' ->
|
| name == "undefined" || head name == '_' ->
|
||||||
return $ Just (span, name, typ, b)
|
return $ Just (s, name, typ, b)
|
||||||
where
|
where
|
||||||
name = getFnName dflag style i
|
name = getFnName dflag style i
|
||||||
-- If inside an App, we need parenthesis
|
-- If inside an App, we need parenthesis
|
||||||
|
|
|
||||||
|
|
@ -2,8 +2,7 @@
|
||||||
|
|
||||||
module Language.Haskell.GhcMod.Find
|
module Language.Haskell.GhcMod.Find
|
||||||
#ifndef SPEC
|
#ifndef SPEC
|
||||||
(
|
( Symbol
|
||||||
Symbol
|
|
||||||
, SymbolDb
|
, SymbolDb
|
||||||
, loadSymbolDb
|
, loadSymbolDb
|
||||||
, lookupSymbol
|
, lookupSymbol
|
||||||
|
|
@ -33,17 +32,8 @@ import System.Directory (doesFileExist, getModificationTime)
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
import System.IO
|
import System.IO
|
||||||
|
|
||||||
#ifndef MIN_VERSION_containers
|
|
||||||
#define MIN_VERSION_containers(x,y,z) 1
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#if MIN_VERSION_containers(0,5,0)
|
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
#else
|
|
||||||
import Data.Map (Map)
|
|
||||||
import qualified Data.Map as M
|
|
||||||
#endif
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
|
|
@ -79,16 +69,16 @@ lookupSym sym db = M.findWithDefault [] sym $ table db
|
||||||
-- | Loading a file and creates 'SymbolDb'.
|
-- | Loading a file and creates 'SymbolDb'.
|
||||||
loadSymbolDb :: IOish m => GhcModT m SymbolDb
|
loadSymbolDb :: IOish m => GhcModT m SymbolDb
|
||||||
loadSymbolDb = do
|
loadSymbolDb = do
|
||||||
ghcMod <- liftIO ghcModExecutable
|
ghcMod <- liftIO ghcModExecutable
|
||||||
tmpdir <- cradleTempDir <$> cradle
|
tmpdir <- cradleTempDir <$> cradle
|
||||||
file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
|
file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
|
||||||
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||||
return $ SymbolDb
|
return $ SymbolDb
|
||||||
{ table = db
|
{ table = db
|
||||||
, symbolDbCachePath = file
|
, symbolDbCachePath = file
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
conv :: String -> (Symbol,[ModuleString])
|
conv :: String -> (Symbol, [ModuleString])
|
||||||
conv = read
|
conv = read
|
||||||
chop :: String -> String
|
chop :: String -> String
|
||||||
chop "" = ""
|
chop "" = ""
|
||||||
|
|
@ -113,11 +103,11 @@ dumpSymbol dir = do
|
||||||
cache = dir </> symbolCacheFile
|
cache = dir </> symbolCacheFile
|
||||||
|
|
||||||
writeSymbolCache :: FilePath
|
writeSymbolCache :: FilePath
|
||||||
-> [(Symbol,[ModuleString])]
|
-> [(Symbol, [ModuleString])]
|
||||||
-> IO ()
|
-> IO ()
|
||||||
writeSymbolCache cache sm =
|
writeSymbolCache cache sm =
|
||||||
void . withFile cache WriteMode $ \hdl ->
|
void . withFile cache WriteMode $ \hdl ->
|
||||||
mapM (hPrint hdl) sm
|
mapM (hPrint hdl) sm
|
||||||
|
|
||||||
-- | Check whether given file is older than any file from the given set.
|
-- | Check whether given file is older than any file from the given set.
|
||||||
-- Returns True if given file does not exist.
|
-- Returns True if given file does not exist.
|
||||||
|
|
@ -131,24 +121,24 @@ isOlderThan cache files = do
|
||||||
return $ any (tCache <=) $ map tfTime files -- including equal just in case
|
return $ any (tCache <=) $ map tfTime files -- including equal just in case
|
||||||
|
|
||||||
-- | Browsing all functions in all system modules.
|
-- | Browsing all functions in all system modules.
|
||||||
getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])]
|
getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
|
||||||
getGlobalSymbolTable = do
|
getGlobalSymbolTable = do
|
||||||
df <- G.getSessionDynFlags
|
df <- G.getSessionDynFlags
|
||||||
let mods = listVisibleModules df
|
let mods = listVisibleModules df
|
||||||
moduleInfos <- mapM G.getModuleInfo mods
|
moduleInfos <- mapM G.getModuleInfo mods
|
||||||
return $ collectModules
|
return $ collectModules
|
||||||
$ extractBindings `concatMap` (moduleInfos `zip` mods)
|
$ extractBindings `concatMap` (moduleInfos `zip` mods)
|
||||||
|
|
||||||
extractBindings :: (Maybe G.ModuleInfo, G.Module)
|
extractBindings :: (Maybe G.ModuleInfo, G.Module)
|
||||||
-> [(Symbol, ModuleString)]
|
-> [(Symbol, ModuleString)]
|
||||||
extractBindings (Nothing,_) = []
|
extractBindings (Nothing, _) = []
|
||||||
extractBindings (Just inf,mdl) =
|
extractBindings (Just inf, mdl) =
|
||||||
map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names
|
map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names
|
||||||
where
|
where
|
||||||
names = G.modInfoExports inf
|
names = G.modInfoExports inf
|
||||||
|
|
||||||
collectModules :: [(Symbol,ModuleString)]
|
collectModules :: [(Symbol, ModuleString)]
|
||||||
-> [(Symbol,[ModuleString])]
|
-> [(Symbol, [ModuleString])]
|
||||||
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
||||||
where
|
where
|
||||||
tieup x = (head (map fst x), map snd x)
|
tieup x = (head (map fst x), map snd x)
|
||||||
|
|
|
||||||
|
|
@ -30,20 +30,21 @@ info :: IOish m
|
||||||
-> Expression -- ^ A Haskell expression.
|
-> Expression -- ^ A Haskell expression.
|
||||||
-> GhcModT m String
|
-> GhcModT m String
|
||||||
info file expr =
|
info file expr =
|
||||||
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $
|
ghandle handler $
|
||||||
convert <$> options <*> body
|
runGmlT' [Left file] deferErrors $
|
||||||
|
withContext $
|
||||||
|
convert <$> options <*> body
|
||||||
where
|
where
|
||||||
handler (SomeException ex) = do
|
handler (SomeException ex) = do
|
||||||
gmLog GmException "info" $
|
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
|
||||||
text "" $$ nest 4 (showDoc ex)
|
convert' "Cannot show info"
|
||||||
convert' "Cannot show info"
|
|
||||||
|
|
||||||
|
body :: GhcMonad m => m String
|
||||||
body = do
|
body = do
|
||||||
sdoc <- Gap.infoThing expr
|
sdoc <- Gap.infoThing expr
|
||||||
st <- getStyle
|
st <- getStyle
|
||||||
dflag <- G.getSessionDynFlags
|
dflag <- G.getSessionDynFlags
|
||||||
return $ showPage dflag st sdoc
|
return $ showPage dflag st sdoc
|
||||||
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
|
|
@ -54,14 +55,14 @@ types :: IOish m
|
||||||
-> Int -- ^ Column number.
|
-> Int -- ^ Column number.
|
||||||
-> GhcModT m String
|
-> GhcModT m String
|
||||||
types file lineNo colNo =
|
types file lineNo colNo =
|
||||||
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ do
|
ghandle handler $
|
||||||
crdl <- cradle
|
runGmlT' [Left file] deferErrors $
|
||||||
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
|
withContext $ do
|
||||||
|
crdl <- cradle
|
||||||
|
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
|
||||||
srcSpanTypes <- getSrcSpanType modSum lineNo colNo
|
srcSpanTypes <- getSrcSpanType modSum lineNo colNo
|
||||||
|
dflag <- G.getSessionDynFlags
|
||||||
dflag <- G.getSessionDynFlags
|
st <- getStyle
|
||||||
st <- getStyle
|
|
||||||
|
|
||||||
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
|
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
|
||||||
where
|
where
|
||||||
handler (SomeException ex) = do
|
handler (SomeException ex) = do
|
||||||
|
|
@ -70,12 +71,12 @@ types file lineNo colNo =
|
||||||
|
|
||||||
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
|
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
|
||||||
getSrcSpanType modSum lineNo colNo = do
|
getSrcSpanType modSum lineNo colNo = do
|
||||||
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
|
||||||
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
|
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
|
||||||
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
|
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
|
||||||
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
|
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
|
||||||
bts <- mapM (getType tcm) bs
|
bts <- mapM (getType tcm) bs
|
||||||
ets <- mapM (getType tcm) es
|
ets <- mapM (getType tcm) es
|
||||||
pts <- mapM (getType tcm) ps
|
pts <- mapM (getType tcm) ps
|
||||||
return $ catMaybes $ concat [ets, bts, pts]
|
return $ catMaybes $ concat [ets, bts, pts]
|
||||||
|
|
|
||||||
|
|
@ -50,7 +50,7 @@ type MonadIOC m = (MTL.MonadIO m)
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
class MonadIOC m => MonadIO m where
|
class MonadIOC m => MonadIO m where
|
||||||
liftIO :: IO a -> m a
|
liftIO :: IO a -> m a
|
||||||
|
|
||||||
-- | Output style.
|
-- | Output style.
|
||||||
data OutputStyle = LispStyle -- ^ S expression style.
|
data OutputStyle = LispStyle -- ^ S expression style.
|
||||||
|
|
@ -83,21 +83,20 @@ data Options = Options {
|
||||||
, hlintOpts :: [String]
|
, hlintOpts :: [String]
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
|
|
||||||
-- | A default 'Options'.
|
-- | A default 'Options'.
|
||||||
defaultOptions :: Options
|
defaultOptions :: Options
|
||||||
defaultOptions = Options {
|
defaultOptions = Options {
|
||||||
outputStyle = PlainStyle
|
outputStyle = PlainStyle
|
||||||
, lineSeparator = LineSeparator "\0"
|
, lineSeparator = LineSeparator "\0"
|
||||||
, logLevel = GmWarning
|
, logLevel = GmWarning
|
||||||
, ghcProgram = "ghc"
|
, ghcProgram = "ghc"
|
||||||
, ghcPkgProgram = "ghc-pkg"
|
, ghcPkgProgram = "ghc-pkg"
|
||||||
, cabalProgram = "cabal"
|
, cabalProgram = "cabal"
|
||||||
, ghcUserOptions= []
|
, ghcUserOptions = []
|
||||||
, operators = False
|
, operators = False
|
||||||
, detailed = False
|
, detailed = False
|
||||||
, qualified = False
|
, qualified = False
|
||||||
, hlintOpts = []
|
, hlintOpts = []
|
||||||
}
|
}
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
@ -113,7 +112,7 @@ data Cradle = Cradle {
|
||||||
-- | The file name of the found cabal file.
|
-- | The file name of the found cabal file.
|
||||||
, cradleCabalFile :: Maybe FilePath
|
, cradleCabalFile :: Maybe FilePath
|
||||||
-- | Package database stack
|
-- | Package database stack
|
||||||
, cradlePkgDbStack :: [GhcPkgDb]
|
, cradlePkgDbStack :: [GhcPkgDb]
|
||||||
} deriving (Eq, Show)
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
@ -122,7 +121,7 @@ data Cradle = Cradle {
|
||||||
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
|
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
|
||||||
|
|
||||||
-- | A single GHC command line option.
|
-- | A single GHC command line option.
|
||||||
type GHCOption = String
|
type GHCOption = String
|
||||||
|
|
||||||
-- | An include directory for modules.
|
-- | An include directory for modules.
|
||||||
type IncludeDir = FilePath
|
type IncludeDir = FilePath
|
||||||
|
|
@ -131,28 +130,28 @@ type IncludeDir = FilePath
|
||||||
type PackageBaseName = String
|
type PackageBaseName = String
|
||||||
|
|
||||||
-- | A package version.
|
-- | A package version.
|
||||||
type PackageVersion = String
|
type PackageVersion = String
|
||||||
|
|
||||||
-- | A package id.
|
-- | A package id.
|
||||||
type PackageId = String
|
type PackageId = String
|
||||||
|
|
||||||
-- | A package's name, verson and id.
|
-- | A package's name, verson and id.
|
||||||
type Package = (PackageBaseName, PackageVersion, PackageId)
|
type Package = (PackageBaseName, PackageVersion, PackageId)
|
||||||
|
|
||||||
pkgName :: Package -> PackageBaseName
|
pkgName :: Package -> PackageBaseName
|
||||||
pkgName (n,_,_) = n
|
pkgName (n, _, _) = n
|
||||||
|
|
||||||
pkgVer :: Package -> PackageVersion
|
pkgVer :: Package -> PackageVersion
|
||||||
pkgVer (_,v,_) = v
|
pkgVer (_, v, _) = v
|
||||||
|
|
||||||
pkgId :: Package -> PackageId
|
pkgId :: Package -> PackageId
|
||||||
pkgId (_,_,i) = i
|
pkgId (_, _, i) = i
|
||||||
|
|
||||||
showPkg :: Package -> String
|
showPkg :: Package -> String
|
||||||
showPkg (n,v,_) = intercalate "-" [n,v]
|
showPkg (n, v, _) = intercalate "-" [n, v]
|
||||||
|
|
||||||
showPkgId :: Package -> String
|
showPkgId :: Package -> String
|
||||||
showPkgId (n,v,i) = intercalate "-" [n,v,i]
|
showPkgId (n, v, i) = intercalate "-" [n, v, i]
|
||||||
|
|
||||||
-- | Haskell expression.
|
-- | Haskell expression.
|
||||||
type Expression = String
|
type Expression = String
|
||||||
|
|
@ -163,131 +162,133 @@ type ModuleString = String
|
||||||
-- | A Module
|
-- | A Module
|
||||||
type Module = [String]
|
type Module = [String]
|
||||||
|
|
||||||
data GmLogLevel = GmSilent
|
data GmLogLevel =
|
||||||
| GmPanic
|
GmSilent
|
||||||
| GmException
|
| GmPanic
|
||||||
| GmError
|
| GmException
|
||||||
| GmWarning
|
| GmError
|
||||||
| GmInfo
|
| GmWarning
|
||||||
| GmDebug
|
| GmInfo
|
||||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
| GmDebug
|
||||||
|
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||||
|
|
||||||
-- | Collection of packages
|
-- | Collection of packages
|
||||||
type PkgDb = (Map Package PackageConfig)
|
type PkgDb = (Map Package PackageConfig)
|
||||||
|
|
||||||
data GmModuleGraph = GmModuleGraph {
|
data GmModuleGraph = GmModuleGraph {
|
||||||
gmgGraph :: Map ModulePath (Set ModulePath)
|
gmgGraph :: Map ModulePath (Set ModulePath)
|
||||||
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||||
|
|
||||||
instance Serialize GmModuleGraph where
|
instance Serialize GmModuleGraph where
|
||||||
put GmModuleGraph {..} = let
|
put GmModuleGraph {..} = put (mpim, graph)
|
||||||
mpim :: Map ModulePath Integer
|
where
|
||||||
graph :: Map Integer (Set Integer)
|
mpim :: Map ModulePath Integer
|
||||||
|
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
|
||||||
|
graph :: Map Integer (Set Integer)
|
||||||
|
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
|
||||||
|
mpToInt :: ModulePath -> Integer
|
||||||
|
mpToInt mp = fromJust $ Map.lookup mp mpim
|
||||||
|
|
||||||
mpim = Map.fromList $
|
get = do
|
||||||
(Map.keys gmgGraph) `zip` [0..]
|
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
|
||||||
mpToInt :: ModulePath -> Integer
|
let impm = swapMap mpim
|
||||||
mpToInt mp = fromJust $ Map.lookup mp mpim
|
intToMp i = fromJust $ Map.lookup i impm
|
||||||
|
mpGraph :: Map ModulePath (Set ModulePath)
|
||||||
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
|
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
|
||||||
in put (mpim, graph)
|
return $ GmModuleGraph mpGraph
|
||||||
|
where
|
||||||
get = do
|
swapMap :: (Ord k, Ord v) => Map k v -> Map v k
|
||||||
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
|
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
|
||||||
let
|
|
||||||
swapMap = Map.fromList . map swap . Map.toList
|
|
||||||
swap (a,b) = (b,a)
|
|
||||||
impm = swapMap mpim
|
|
||||||
intToMp i = fromJust $ Map.lookup i impm
|
|
||||||
mpGraph :: Map ModulePath (Set ModulePath)
|
|
||||||
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
|
|
||||||
return $ GmModuleGraph mpGraph
|
|
||||||
|
|
||||||
instance Monoid GmModuleGraph where
|
instance Monoid GmModuleGraph where
|
||||||
mempty = GmModuleGraph mempty
|
mempty = GmModuleGraph mempty
|
||||||
mappend (GmModuleGraph a) (GmModuleGraph a') =
|
mappend (GmModuleGraph a) (GmModuleGraph a') =
|
||||||
GmModuleGraph (Map.unionWith Set.union a a')
|
GmModuleGraph (Map.unionWith Set.union a a')
|
||||||
|
|
||||||
data GmComponentType = GMCRaw
|
data GmComponentType = GMCRaw
|
||||||
| GMCResolved
|
| GMCResolved
|
||||||
data GmComponent (t :: GmComponentType) eps = GmComponent {
|
data GmComponent (t :: GmComponentType) eps = GmComponent {
|
||||||
gmcHomeModuleGraph :: GmModuleGraph,
|
gmcHomeModuleGraph :: GmModuleGraph
|
||||||
gmcName :: ChComponentName,
|
, gmcName :: ChComponentName
|
||||||
gmcGhcOpts :: [GHCOption],
|
, gmcGhcOpts :: [GHCOption]
|
||||||
gmcGhcPkgOpts :: [GHCOption],
|
, gmcGhcPkgOpts :: [GHCOption]
|
||||||
gmcGhcSrcOpts :: [GHCOption],
|
, gmcGhcSrcOpts :: [GHCOption]
|
||||||
gmcGhcLangOpts :: [GHCOption],
|
, gmcGhcLangOpts :: [GHCOption]
|
||||||
gmcRawEntrypoints :: ChEntrypoint,
|
, gmcRawEntrypoints :: ChEntrypoint
|
||||||
gmcEntrypoints :: eps,
|
, gmcEntrypoints :: eps
|
||||||
gmcSourceDirs :: [FilePath]
|
, gmcSourceDirs :: [FilePath]
|
||||||
} deriving (Eq, Ord, Show, Read, Generic, Functor)
|
} deriving (Eq, Ord, Show, Read, Generic, Functor)
|
||||||
|
|
||||||
instance Serialize eps => Serialize (GmComponent t eps)
|
instance Serialize eps => Serialize (GmComponent t eps)
|
||||||
|
|
||||||
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
|
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
|
||||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||||
instance Serialize ModulePath
|
instance Serialize ModulePath
|
||||||
|
|
||||||
instance Serialize ModuleName where
|
instance Serialize ModuleName where
|
||||||
get = mkModuleName <$> get
|
get = mkModuleName <$> get
|
||||||
put mn = put (moduleNameString mn)
|
put mn = put (moduleNameString mn)
|
||||||
|
|
||||||
instance Show ModuleName where
|
instance Show ModuleName where
|
||||||
show mn = "ModuleName " ++ show (moduleNameString mn)
|
show mn = "ModuleName " ++ show (moduleNameString mn)
|
||||||
|
|
||||||
instance Read ModuleName where
|
instance Read ModuleName where
|
||||||
readsPrec d r = readParen (d > app_prec)
|
readsPrec d =
|
||||||
(\r' -> [(mkModuleName m,t) |
|
readParen
|
||||||
("ModuleName",s) <- lex r',
|
(d > app_prec)
|
||||||
(m,t) <- readsPrec (app_prec+1) s]) r
|
(\r' -> [ (mkModuleName m, t)
|
||||||
where app_prec = 10
|
| ("ModuleName", s) <- lex r'
|
||||||
|
, (m, t) <- readsPrec (app_prec + 1) s
|
||||||
|
])
|
||||||
|
where
|
||||||
|
app_prec = 10
|
||||||
|
|
||||||
data GhcModError
|
data GhcModError
|
||||||
= GMENoMsg
|
= GMENoMsg
|
||||||
-- ^ Unknown error
|
-- ^ Unknown error
|
||||||
|
|
||||||
| GMEString String
|
| GMEString String
|
||||||
-- ^ Some Error with a message. These are produced mostly by
|
-- ^ Some Error with a message. These are produced mostly by
|
||||||
-- 'fail' calls on GhcModT.
|
-- 'fail' calls on GhcModT.
|
||||||
|
|
||||||
| GMECabalConfigure GhcModError
|
| GMECabalConfigure GhcModError
|
||||||
-- ^ Configuring a cabal project failed.
|
-- ^ Configuring a cabal project failed.
|
||||||
|
|
||||||
| GMECabalFlags GhcModError
|
| GMECabalFlags GhcModError
|
||||||
-- ^ Retrieval of the cabal configuration flags failed.
|
-- ^ Retrieval of the cabal configuration flags failed.
|
||||||
|
|
||||||
| GMECabalComponent ChComponentName
|
| GMECabalComponent ChComponentName
|
||||||
-- ^ Cabal component could not be found
|
-- ^ Cabal component could not be found
|
||||||
|
|
||||||
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
||||||
-- ^ Could not find a consistent component assignment for modules
|
-- ^ Could not find a consistent component assignment for modules
|
||||||
|
|
||||||
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
||||||
-- ^ Launching an operating system process failed. Fields in
|
-- ^ Launching an operating system process failed. Fields in
|
||||||
-- order: command, arguments, (stdout, stderr, exitcode)
|
-- order: command, arguments, (stdout, stderr, exitcode)
|
||||||
|
|
||||||
| GMENoCabalFile
|
| GMENoCabalFile
|
||||||
-- ^ No cabal file found.
|
-- ^ No cabal file found.
|
||||||
|
|
||||||
| GMETooManyCabalFiles [FilePath]
|
| GMETooManyCabalFiles [FilePath]
|
||||||
-- ^ Too many cabal files found.
|
-- ^ Too many cabal files found.
|
||||||
|
|
||||||
| GMECabalStateFile GMConfigStateFileError
|
| GMECabalStateFile GMConfigStateFileError
|
||||||
-- ^ Reading Cabal's state configuration file falied somehow.
|
-- ^ Reading Cabal's state configuration file falied somehow.
|
||||||
deriving (Eq,Show,Typeable)
|
deriving (Eq,Show,Typeable)
|
||||||
|
|
||||||
instance Error GhcModError where
|
instance Error GhcModError where
|
||||||
noMsg = GMENoMsg
|
noMsg = GMENoMsg
|
||||||
strMsg = GMEString
|
strMsg = GMEString
|
||||||
|
|
||||||
instance Exception GhcModError
|
instance Exception GhcModError
|
||||||
|
|
||||||
data GMConfigStateFileError
|
data GMConfigStateFileError
|
||||||
= GMConfigStateFileNoHeader
|
= GMConfigStateFileNoHeader
|
||||||
| GMConfigStateFileBadHeader
|
| GMConfigStateFileBadHeader
|
||||||
| GMConfigStateFileNoParse
|
| GMConfigStateFileNoParse
|
||||||
| GMConfigStateFileMissing
|
| GMConfigStateFileMissing
|
||||||
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
||||||
deriving (Eq, Show, Read, Typeable)
|
deriving (Eq, Show, Read, Typeable)
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -15,26 +15,26 @@
|
||||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DoAndIfThenElse #-}
|
||||||
|
|
||||||
module Language.Haskell.GhcMod.Utils (
|
module Language.Haskell.GhcMod.Utils (
|
||||||
module Language.Haskell.GhcMod.Utils
|
module Language.Haskell.GhcMod.Utils
|
||||||
, module Utils
|
, module Utils
|
||||||
, readProcess
|
, readProcess
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Arrow
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
import Exception
|
||||||
import Language.Haskell.GhcMod.Error
|
import Language.Haskell.GhcMod.Error
|
||||||
import Language.Haskell.GhcMod.Monad.Types
|
import Language.Haskell.GhcMod.Monad.Types
|
||||||
import Exception
|
|
||||||
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
|
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
|
||||||
getTemporaryDirectory, canonicalizePath, doesFileExist)
|
getTemporaryDirectory, canonicalizePath)
|
||||||
import System.Process (readProcess)
|
import System.Environment
|
||||||
import System.Directory ()
|
|
||||||
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
|
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
|
||||||
(</>))
|
(</>))
|
||||||
import System.IO.Temp (createTempDirectory)
|
import System.IO.Temp (createTempDirectory)
|
||||||
import System.Environment
|
import System.Process (readProcess)
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
|
|
||||||
import Paths_ghc_mod (getLibexecDir)
|
import Paths_ghc_mod (getLibexecDir)
|
||||||
|
|
@ -46,25 +46,28 @@ dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
|
||||||
|
|
||||||
withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
|
withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
|
||||||
withDirectory_ dir action =
|
withDirectory_ dir action =
|
||||||
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
|
gbracket
|
||||||
(\_ -> liftIO (setCurrentDirectory dir) >> action)
|
(liftIO getCurrentDirectory)
|
||||||
|
(liftIO . setCurrentDirectory)
|
||||||
|
(\_ -> liftIO (setCurrentDirectory dir) >> action)
|
||||||
|
|
||||||
uniqTempDirName :: FilePath -> FilePath
|
uniqTempDirName :: FilePath -> FilePath
|
||||||
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
|
uniqTempDirName dir =
|
||||||
$ map escapeDriveChar *** map escapePathChar
|
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
|
||||||
$ splitDrive dir
|
where
|
||||||
where
|
(drive, path) = splitDrive dir
|
||||||
|
escapeDriveChar :: Char -> Char
|
||||||
escapeDriveChar c
|
escapeDriveChar c
|
||||||
| isAlphaNum c = c
|
| isAlphaNum c = c
|
||||||
| otherwise = '-'
|
| otherwise = '-'
|
||||||
|
escapePathChar :: Char -> Char
|
||||||
escapePathChar c
|
escapePathChar c
|
||||||
| c `elem` pathSeparators = '-'
|
| c `elem` pathSeparators = '-'
|
||||||
| otherwise = c
|
| otherwise = c
|
||||||
|
|
||||||
newTempDir :: FilePath -> IO FilePath
|
newTempDir :: FilePath -> IO FilePath
|
||||||
newTempDir dir =
|
newTempDir dir =
|
||||||
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
|
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
|
||||||
|
|
||||||
whenM :: IO Bool -> IO () -> IO ()
|
whenM :: IO Bool -> IO () -> IO ()
|
||||||
whenM mb ma = mb >>= flip when ma
|
whenM mb ma = mb >>= flip when ma
|
||||||
|
|
@ -82,21 +85,21 @@ ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
|
||||||
|
|
||||||
findLibexecExe :: String -> IO FilePath
|
findLibexecExe :: String -> IO FilePath
|
||||||
findLibexecExe "cabal-helper-wrapper" = do
|
findLibexecExe "cabal-helper-wrapper" = do
|
||||||
libexecdir <- getLibexecDir
|
libexecdir <- getLibexecDir
|
||||||
let exeName = "cabal-helper-wrapper"
|
let exeName = "cabal-helper-wrapper"
|
||||||
exe = libexecdir </> exeName
|
exe = libexecdir </> exeName
|
||||||
|
|
||||||
exists <- doesFileExist exe
|
exists <- doesFileExist exe
|
||||||
|
|
||||||
if exists
|
if exists
|
||||||
then return exe
|
then return exe
|
||||||
else do
|
else do
|
||||||
mdir <- tryFindGhcModTreeDataDir
|
mdir <- tryFindGhcModTreeDataDir
|
||||||
case mdir of
|
case mdir of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
error $ libexecNotExitsError exeName libexecdir
|
error $ libexecNotExitsError exeName libexecdir
|
||||||
Just dir ->
|
Just dir ->
|
||||||
return $ dir </> "dist" </> "build" </> exeName </> exeName
|
return $ dir </> "dist" </> "build" </> exeName </> exeName
|
||||||
findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
|
findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
|
||||||
|
|
||||||
libexecNotExitsError :: String -> FilePath -> String
|
libexecNotExitsError :: String -> FilePath -> String
|
||||||
|
|
@ -119,22 +122,20 @@ tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
|
||||||
tryFindGhcModTreeLibexecDir = do
|
tryFindGhcModTreeLibexecDir = do
|
||||||
exe <- getExecutablePath'
|
exe <- getExecutablePath'
|
||||||
dir <- case takeFileName exe of
|
dir <- case takeFileName exe of
|
||||||
"ghc" -> do -- we're probably in ghci; try CWD
|
"ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD
|
||||||
getCurrentDirectory
|
_ -> return $ (!!4) $ iterate takeDirectory exe
|
||||||
_ ->
|
|
||||||
return $ (!!4) $ iterate takeDirectory exe
|
|
||||||
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
||||||
return $ if exists
|
return $ if exists
|
||||||
then Just dir
|
then Just dir
|
||||||
else Nothing
|
else Nothing
|
||||||
|
|
||||||
tryFindGhcModTreeDataDir :: IO (Maybe FilePath)
|
tryFindGhcModTreeDataDir :: IO (Maybe FilePath)
|
||||||
tryFindGhcModTreeDataDir = do
|
tryFindGhcModTreeDataDir = do
|
||||||
dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'
|
dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'
|
||||||
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
||||||
return $ if exists
|
return $ if exists
|
||||||
then Just dir
|
then Just dir
|
||||||
else Nothing
|
else Nothing
|
||||||
|
|
||||||
readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
|
readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
|
||||||
=> String -> [String] -> m String
|
=> String -> [String] -> m String
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue