Merge remote-tracking branch 'sergv/master'
This commit is contained in:
Daniel Gröber
commit
6dd1195b7f
|
|
@ -17,7 +17,7 @@ module Language.Haskell.GhcMod (
|
|||
, gmLog
|
||||
-- * Types
|
||||
, ModuleString
|
||||
, Expression
|
||||
, Expression(..)
|
||||
, GhcPkgDb
|
||||
, Symbol
|
||||
, SymbolDb
|
||||
|
|
|
|||
|
|
@ -9,8 +9,9 @@ import Language.Haskell.GhcMod.Modules
|
|||
|
||||
-- | Printing necessary information for front-end booting.
|
||||
boot :: IOish m => GhcModT m String
|
||||
boot = concat <$> sequence [modules, languages, flags,
|
||||
concat <$> mapM browse preBrowsedModules]
|
||||
boot = concat <$> sequence ms
|
||||
where
|
||||
ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
|
||||
|
||||
preBrowsedModules :: [String]
|
||||
preBrowsedModules = [
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ import Exception (ExceptionMonad, ghandle)
|
|||
-- If 'detailed' is 'True', their types are also obtained.
|
||||
-- If 'operators' is 'True', operators are also returned.
|
||||
browse :: forall m. IOish m
|
||||
=> ModuleString -- ^ A module name. (e.g. \"Data.List\")
|
||||
=> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
|
||||
-> GhcModT m String
|
||||
browse pkgmdl = do
|
||||
convert' . sort =<< go
|
||||
|
|
@ -48,7 +48,7 @@ browse pkgmdl = do
|
|||
|
||||
tryModuleInfo m = fromJust <$> G.getModuleInfo m
|
||||
|
||||
(mpkg,mdl) = splitPkgMdl pkgmdl
|
||||
(mpkg, mdl) = splitPkgMdl pkgmdl
|
||||
mdlname = G.mkModuleName mdl
|
||||
mpkgid = mkFastString <$> mpkg
|
||||
|
||||
|
|
@ -59,9 +59,10 @@ browse pkgmdl = do
|
|||
-- >>> splitPkgMdl "Prelude"
|
||||
-- (Nothing,"Prelude")
|
||||
splitPkgMdl :: String -> (Maybe String,String)
|
||||
splitPkgMdl pkgmdl = case break (==':') pkgmdl of
|
||||
(mdl,"") -> (Nothing,mdl)
|
||||
(pkg,_:mdl) -> (Just pkg,mdl)
|
||||
splitPkgMdl pkgmdl =
|
||||
case break (==':') pkgmdl of
|
||||
(mdl, "") -> (Nothing, mdl)
|
||||
(pkg, _:mdl) -> (Just pkg, mdl)
|
||||
|
||||
-- Haskell 2010:
|
||||
-- small -> ascSmall | uniSmall | _
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
|
|||
convert' x = flip convert x <$> options
|
||||
|
||||
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
|
||||
| str == "\n" = ""
|
||||
| otherwise = str
|
||||
|
|
@ -35,8 +35,8 @@ convert opt@Options { outputStyle = PlainStyle } x
|
|||
str = toPlain opt x "\n"
|
||||
|
||||
class ToString a where
|
||||
toLisp :: Options -> a -> Builder
|
||||
toPlain :: Options -> a -> Builder
|
||||
toLisp :: Options -> a -> Builder
|
||||
toPlain :: Options -> a -> Builder
|
||||
|
||||
lineSep :: Options -> String
|
||||
lineSep opt = interpret lsep
|
||||
|
|
@ -51,8 +51,8 @@ lineSep opt = interpret lsep
|
|||
-- >>> toPlain defaultOptions "foo" ""
|
||||
-- "foo"
|
||||
instance ToString String where
|
||||
toLisp opt = quote opt
|
||||
toPlain opt = replace '\n' (lineSep opt)
|
||||
toLisp opt = quote opt
|
||||
toPlain opt = replace '\n' (lineSep opt)
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -61,8 +61,12 @@ instance ToString String where
|
|||
-- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
|
||||
-- "foo\nbar\nbaz"
|
||||
instance ToString [String] where
|
||||
toLisp opt = toSexp1 opt
|
||||
toPlain opt = inter '\n' . map (toPlain opt)
|
||||
toLisp opt = toSexp1 opt
|
||||
toPlain opt = inter '\n' . map (toPlain opt)
|
||||
|
||||
instance ToString [ModuleString] where
|
||||
toLisp opt = toLisp opt . map getModuleString
|
||||
toPlain opt = toPlain opt . map getModuleString
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -72,23 +76,23 @@ instance ToString [String] where
|
|||
-- >>> toPlain defaultOptions inp ""
|
||||
-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
|
||||
instance ToString [((Int,Int,Int,Int),String)] where
|
||||
toLisp opt = toSexp2 . map toS
|
||||
where
|
||||
toS x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt = inter '\n' . map (tupToString opt)
|
||||
toLisp opt = toSexp2 . map toS
|
||||
where
|
||||
toS x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt = inter '\n' . map (tupToString opt)
|
||||
|
||||
instance ToString ((Int,Int,Int,Int),String) where
|
||||
toLisp opt x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt x = tupToString opt x
|
||||
toLisp opt x = ('(' :) . tupToString opt x . (')' :)
|
||||
toPlain opt x = tupToString opt x
|
||||
|
||||
instance ToString ((Int,Int,Int,Int),[String]) where
|
||||
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x .
|
||||
(' ' :) . toLisp opt s . (')' :)
|
||||
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
|
||||
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x .
|
||||
(' ' :) . toLisp opt s . (')' :)
|
||||
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
|
||||
|
||||
instance ToString (String, (Int,Int,Int,Int),[String]) where
|
||||
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
|
||||
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
|
||||
toLisp 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]
|
||||
|
||||
toSexp1 :: Options -> [String] -> Builder
|
||||
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import Data.Char (isSymbol)
|
|||
import Data.Function (on)
|
||||
import Data.List (find, nub, sortBy)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (isJust, catMaybes)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Exception (ghandle, SomeException(..))
|
||||
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
|
||||
SrcSpan, Type, GenLocated(L))
|
||||
|
|
@ -79,17 +79,14 @@ sig file lineNo colNo =
|
|||
Signature loc names ty ->
|
||||
("function", fourInts loc, map (initialBody dflag style ty) names)
|
||||
|
||||
InstanceDecl loc cls -> let
|
||||
body x = initialBody dflag style (G.idType x) x
|
||||
in
|
||||
("instance", fourInts loc, body `map` Ty.classMethods cls)
|
||||
InstanceDecl loc cls ->
|
||||
let body x = initialBody dflag style (G.idType x) x
|
||||
in ("instance", fourInts loc, body `map` Ty.classMethods cls)
|
||||
|
||||
TyFamDecl loc name flavour vars ->
|
||||
let (rTy, initial) = initialTyFamString flavour
|
||||
body = initialFamBody dflag style name vars
|
||||
in (rTy, fourInts loc, [initial ++ body])
|
||||
|
||||
|
||||
in (rTy, fourInts loc, [initial ++ body])
|
||||
where
|
||||
fallback (SomeException _) = do
|
||||
opt <- options
|
||||
|
|
@ -244,9 +241,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String
|
|||
initialHead1 fname args elts =
|
||||
case initialBodyArgs1 args elts of
|
||||
[] -> fname
|
||||
arglist -> if isSymbolName fname
|
||||
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||
else fname ++ " " ++ unwords arglist
|
||||
arglist
|
||||
| isSymbolName fname ->
|
||||
head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||
| otherwise ->
|
||||
fname ++ " " ++ unwords arglist
|
||||
|
||||
initialBodyArgs1 :: [FnArg] -> [String] -> [String]
|
||||
initialBodyArgs1 args elts = take (length args) elts
|
||||
|
|
@ -337,50 +336,58 @@ refine :: IOish m
|
|||
-> Int -- ^ Column number.
|
||||
-> Expression -- ^ A Haskell expression.
|
||||
-> GhcModT m String
|
||||
refine file lineNo colNo expr =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ do
|
||||
opt <- options
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- Gap.fileModSummary file
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||
ety <- G.exprType expr
|
||||
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
|
||||
\(loc, name, rty, paren) ->
|
||||
let eArgs = getFnArgs ety
|
||||
rArgs = getFnArgs rty
|
||||
diffArgs' = length eArgs - length rArgs
|
||||
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
|
||||
iArgs = take diffArgs eArgs
|
||||
text = initialHead1 expr iArgs (infinitePrefixSupply name)
|
||||
in (fourInts loc, doParen paren text)
|
||||
|
||||
where
|
||||
handler (SomeException _) = emptyResult =<< options
|
||||
refine file lineNo colNo (Expression expr) =
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $ do
|
||||
opt <- options
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- Gap.fileModSummary file
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||
ety <- G.exprType expr
|
||||
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
|
||||
\(loc, name, rty, paren) ->
|
||||
let eArgs = getFnArgs ety
|
||||
rArgs = getFnArgs rty
|
||||
diffArgs' = length eArgs - length rArgs
|
||||
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
|
||||
iArgs = take diffArgs eArgs
|
||||
text = initialHead1 expr iArgs (infinitePrefixSupply name)
|
||||
in (fourInts loc, doParen paren text)
|
||||
where
|
||||
handler (SomeException _) = emptyResult =<< options
|
||||
|
||||
-- Look for the variable in the specified position
|
||||
findVar :: GhcMonad m => DynFlags -> PprStyle
|
||||
-> G.TypecheckedModule -> G.TypecheckedSource
|
||||
-> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
|
||||
findVar
|
||||
:: GhcMonad m
|
||||
=> DynFlags
|
||||
-> PprStyle
|
||||
-> G.TypecheckedModule
|
||||
-> G.TypecheckedSource
|
||||
-> Int
|
||||
-> Int
|
||||
-> m (Maybe (SrcSpan, String, Type, Bool))
|
||||
findVar dflag style tcm tcs lineNo colNo =
|
||||
let lst = sortBy (cmp `on` G.getLoc) $
|
||||
listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
|
||||
in case lst of
|
||||
e@(L _ (G.HsVar i)):others ->
|
||||
do tyInfo <- Gap.getType tcm e
|
||||
let name = getFnName dflag style i
|
||||
if (name == "undefined" || head name == '_') && isJust tyInfo
|
||||
then let Just (s,t) = tyInfo
|
||||
b = case others of -- If inside an App, we need
|
||||
-- parenthesis
|
||||
[] -> False
|
||||
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
|
||||
isSearchedVar i a1 || isSearchedVar i a2
|
||||
_ -> False
|
||||
in return $ Just (s, name, t, b)
|
||||
else return Nothing
|
||||
_ -> return Nothing
|
||||
case lst of
|
||||
e@(L _ (G.HsVar i)):others -> do
|
||||
tyInfo <- Gap.getType tcm e
|
||||
case tyInfo of
|
||||
Just (s, typ)
|
||||
| name == "undefined" || head name == '_' ->
|
||||
return $ Just (s, name, typ, b)
|
||||
where
|
||||
name = getFnName dflag style i
|
||||
-- If inside an App, we need parenthesis
|
||||
b = case others of
|
||||
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
|
||||
isSearchedVar i a1 || isSearchedVar i a2
|
||||
_ -> False
|
||||
_ -> return Nothing
|
||||
_ -> return Nothing
|
||||
where
|
||||
lst :: [G.LHsExpr Id]
|
||||
lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
|
||||
|
||||
infinitePrefixSupply :: String -> [String]
|
||||
infinitePrefixSupply "undefined" = repeat "undefined"
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
{-# LANGUAGE CPP, BangPatterns #-}
|
||||
{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Find
|
||||
#ifndef SPEC
|
||||
(
|
||||
Symbol
|
||||
( Symbol
|
||||
, SymbolDb
|
||||
, loadSymbolDb
|
||||
, lookupSymbol
|
||||
|
|
@ -16,48 +15,39 @@ module Language.Haskell.GhcMod.Find
|
|||
where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad (when, void)
|
||||
import Control.Monad (when, void, (<=<))
|
||||
import Data.Function (on)
|
||||
import Data.List (groupBy, sort)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Gap (listVisibleModules)
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.Gap (listVisibleModules)
|
||||
import Language.Haskell.GhcMod.World (timedPackageCaches)
|
||||
import Name (getOccString)
|
||||
import Module (moduleName)
|
||||
import System.Directory (doesFileExist, getModificationTime)
|
||||
import System.FilePath ((</>), takeDirectory)
|
||||
import System.FilePath ((</>))
|
||||
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 qualified Data.Map as M
|
||||
#else
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Type of function and operation names.
|
||||
type Symbol = String
|
||||
-- | Database from 'Symbol' to \['ModuleString'\].
|
||||
data SymbolDb = SymbolDb {
|
||||
table :: Map Symbol [ModuleString]
|
||||
, packageCachePath :: FilePath
|
||||
data SymbolDb = SymbolDb
|
||||
{ table :: Map Symbol [ModuleString]
|
||||
, symbolDbCachePath :: FilePath
|
||||
} deriving (Show)
|
||||
|
||||
isOutdated :: SymbolDb -> IO Bool
|
||||
isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
|
||||
isOutdated :: (GmEnv m, IOish m) => SymbolDb -> m Bool
|
||||
isOutdated db =
|
||||
liftIO . (isOlderThan (symbolDbCachePath db) <=< timedPackageCaches) =<< cradle
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
|
@ -72,25 +62,25 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
|
|||
lookupSymbol sym db = convert' $ lookupSym sym db
|
||||
|
||||
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
|
||||
lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
|
||||
lookupSym sym db = M.findWithDefault [] sym $ table db
|
||||
|
||||
---------------------------------------------------------------
|
||||
|
||||
-- | Loading a file and creates 'SymbolDb'.
|
||||
loadSymbolDb :: IOish m => GhcModT m SymbolDb
|
||||
loadSymbolDb = do
|
||||
ghcMod <- liftIO ghcModExecutable
|
||||
tmpdir <- cradleTempDir <$> cradle
|
||||
file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
|
||||
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||
return $ SymbolDb {
|
||||
table = db
|
||||
, packageCachePath = takeDirectory file </> packageCache
|
||||
, symbolDbCachePath = file
|
||||
}
|
||||
ghcMod <- liftIO ghcModExecutable
|
||||
tmpdir <- cradleTempDir <$> cradle
|
||||
file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
|
||||
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||
return $ SymbolDb
|
||||
{ table = db
|
||||
, symbolDbCachePath = file
|
||||
}
|
||||
where
|
||||
conv :: String -> (Symbol,[ModuleString])
|
||||
conv :: String -> (Symbol, [ModuleString])
|
||||
conv = read
|
||||
chop :: String -> String
|
||||
chop "" = ""
|
||||
chop xs = init xs
|
||||
|
||||
|
|
@ -102,50 +92,54 @@ loadSymbolDb = do
|
|||
-- The file name is printed.
|
||||
|
||||
dumpSymbol :: IOish m => FilePath -> GhcModT m String
|
||||
dumpSymbol dir = runGmPkgGhc $ do
|
||||
let cache = dir </> symbolCacheFile
|
||||
pkgdb = dir </> packageCache
|
||||
|
||||
create <- liftIO $ cache `isOlderThan` pkgdb
|
||||
when create $ (liftIO . writeSymbolCache cache) =<< getGlobalSymbolTable
|
||||
dumpSymbol dir = do
|
||||
crdl <- cradle
|
||||
runGmPkgGhc $ do
|
||||
create <- liftIO $ isOlderThan cache =<< timedPackageCaches crdl
|
||||
when create $
|
||||
liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
|
||||
return $ unlines [cache]
|
||||
where
|
||||
cache = dir </> symbolCacheFile
|
||||
|
||||
writeSymbolCache :: FilePath
|
||||
-> [(Symbol,[ModuleString])]
|
||||
-> [(Symbol, [ModuleString])]
|
||||
-> IO ()
|
||||
writeSymbolCache cache sm =
|
||||
void . withFile cache WriteMode $ \hdl ->
|
||||
mapM (hPrint hdl) sm
|
||||
mapM (hPrint hdl) sm
|
||||
|
||||
isOlderThan :: FilePath -> FilePath -> IO Bool
|
||||
isOlderThan cache file = do
|
||||
exist <- doesFileExist cache
|
||||
if not exist then
|
||||
return True
|
||||
else do
|
||||
tCache <- getModificationTime cache
|
||||
tFile <- getModificationTime file
|
||||
return $ tCache <= tFile -- including equal just in case
|
||||
-- | Check whether given file is older than any file from the given set.
|
||||
-- Returns True if given file does not exist.
|
||||
isOlderThan :: FilePath -> [TimedFile] -> IO Bool
|
||||
isOlderThan cache files = do
|
||||
exist <- doesFileExist cache
|
||||
if not exist
|
||||
then return True
|
||||
else do
|
||||
tCache <- getModificationTime cache
|
||||
return $ any (tCache <=) $ map tfTime files -- including equal just in case
|
||||
|
||||
-- | Browsing all functions in all system modules.
|
||||
getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])]
|
||||
getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
|
||||
getGlobalSymbolTable = do
|
||||
df <- G.getSessionDynFlags
|
||||
let mods = listVisibleModules df
|
||||
moduleInfos <- mapM G.getModuleInfo mods
|
||||
return $ collectModules
|
||||
$ extractBindings `concatMap` (moduleInfos `zip` mods)
|
||||
df <- G.getSessionDynFlags
|
||||
let mods = listVisibleModules df
|
||||
moduleInfos <- mapM G.getModuleInfo mods
|
||||
return $ collectModules
|
||||
$ extractBindings `concatMap` (moduleInfos `zip` mods)
|
||||
|
||||
extractBindings :: (Maybe G.ModuleInfo, G.Module)
|
||||
-> [(Symbol, ModuleString)]
|
||||
extractBindings (Nothing,_) = []
|
||||
extractBindings (Just inf,mdl) =
|
||||
map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names
|
||||
extractBindings (Nothing, _) = []
|
||||
extractBindings (Just inf, mdl) =
|
||||
map (\name -> (getOccString name, modStr)) names
|
||||
where
|
||||
names = G.modInfoExports inf
|
||||
names = G.modInfoExports inf
|
||||
modStr = ModuleString $ moduleNameString $ moduleName mdl
|
||||
|
||||
collectModules :: [(Symbol,ModuleString)]
|
||||
-> [(Symbol,[ModuleString])]
|
||||
collectModules :: [(Symbol, ModuleString)]
|
||||
-> [(Symbol, [ModuleString])]
|
||||
collectModules = map tieup . groupBy ((==) `on` fst) . sort
|
||||
where
|
||||
tieup x = (head (map fst x), map snd x)
|
||||
|
|
|
|||
|
|
@ -103,6 +103,8 @@ import Parser
|
|||
import SrcLoc
|
||||
import Packages
|
||||
|
||||
import Language.Haskell.GhcMod.Types (Expression(..))
|
||||
|
||||
----------------------------------------------------------------
|
||||
----------------------------------------------------------------
|
||||
--
|
||||
|
|
@ -325,8 +327,8 @@ filterOutChildren get_thing xs
|
|||
where
|
||||
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
|
||||
|
||||
infoThing :: GhcMonad m => String -> m SDoc
|
||||
infoThing str = do
|
||||
infoThing :: GhcMonad m => Expression -> m SDoc
|
||||
infoThing (Expression str) = do
|
||||
names <- parseName str
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
mb_stuffs <- mapM (getInfo False) names
|
||||
|
|
|
|||
|
|
@ -30,20 +30,21 @@ info :: IOish m
|
|||
-> Expression -- ^ A Haskell expression.
|
||||
-> GhcModT m String
|
||||
info file expr =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $
|
||||
convert <$> options <*> body
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $
|
||||
withContext $
|
||||
convert <$> options <*> body
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "info" $
|
||||
text "" $$ nest 4 (showDoc ex)
|
||||
convert' "Cannot show info"
|
||||
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
|
||||
convert' "Cannot show info"
|
||||
|
||||
body :: GhcMonad m => m String
|
||||
body = do
|
||||
sdoc <- Gap.infoThing expr
|
||||
st <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
return $ showPage dflag st sdoc
|
||||
|
||||
sdoc <- Gap.infoThing expr
|
||||
st <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
return $ showPage dflag st sdoc
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
|
@ -54,14 +55,14 @@ types :: IOish m
|
|||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
types file lineNo colNo =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ do
|
||||
crdl <- cradle
|
||||
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $
|
||||
withContext $ do
|
||||
crdl <- cradle
|
||||
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
|
||||
srcSpanTypes <- getSrcSpanType modSum lineNo colNo
|
||||
|
||||
dflag <- G.getSessionDynFlags
|
||||
st <- getStyle
|
||||
|
||||
dflag <- G.getSessionDynFlags
|
||||
st <- getStyle
|
||||
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
|
|
@ -70,12 +71,12 @@ types file lineNo colNo =
|
|||
|
||||
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
|
||||
getSrcSpanType modSum lineNo colNo = do
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
|
||||
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
|
||||
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
|
||||
bts <- mapM (getType tcm) bs
|
||||
ets <- mapM (getType tcm) es
|
||||
pts <- mapM (getType tcm) ps
|
||||
return $ catMaybes $ concat [ets, bts, pts]
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
|
||||
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
|
||||
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
|
||||
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
|
||||
bts <- mapM (getType tcm) bs
|
||||
ets <- mapM (getType tcm) es
|
||||
pts <- mapM (getType tcm) ps
|
||||
return $ catMaybes $ concat [ets, bts, pts]
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ type MonadIOC m = (MTL.MonadIO m)
|
|||
#endif
|
||||
|
||||
class MonadIOC m => MonadIO m where
|
||||
liftIO :: IO a -> m a
|
||||
liftIO :: IO a -> m a
|
||||
|
||||
-- | Output style.
|
||||
data OutputStyle = LispStyle -- ^ S expression style.
|
||||
|
|
@ -83,21 +83,20 @@ data Options = Options {
|
|||
, hlintOpts :: [String]
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
-- | A default 'Options'.
|
||||
defaultOptions :: Options
|
||||
defaultOptions = Options {
|
||||
outputStyle = PlainStyle
|
||||
, lineSeparator = LineSeparator "\0"
|
||||
, logLevel = GmWarning
|
||||
, ghcProgram = "ghc"
|
||||
, ghcPkgProgram = "ghc-pkg"
|
||||
, cabalProgram = "cabal"
|
||||
, ghcUserOptions= []
|
||||
, operators = False
|
||||
, detailed = False
|
||||
, qualified = False
|
||||
, hlintOpts = []
|
||||
outputStyle = PlainStyle
|
||||
, lineSeparator = LineSeparator "\0"
|
||||
, logLevel = GmWarning
|
||||
, ghcProgram = "ghc"
|
||||
, ghcPkgProgram = "ghc-pkg"
|
||||
, cabalProgram = "cabal"
|
||||
, ghcUserOptions = []
|
||||
, operators = False
|
||||
, detailed = False
|
||||
, qualified = False
|
||||
, hlintOpts = []
|
||||
}
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
|
@ -113,7 +112,7 @@ data Cradle = Cradle {
|
|||
-- | The file name of the found cabal file.
|
||||
, cradleCabalFile :: Maybe FilePath
|
||||
-- | Package database stack
|
||||
, cradlePkgDbStack :: [GhcPkgDb]
|
||||
, cradlePkgDbStack :: [GhcPkgDb]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
|
@ -122,7 +121,7 @@ data Cradle = Cradle {
|
|||
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
|
||||
|
||||
-- | A single GHC command line option.
|
||||
type GHCOption = String
|
||||
type GHCOption = String
|
||||
|
||||
-- | An include directory for modules.
|
||||
type IncludeDir = FilePath
|
||||
|
|
@ -131,163 +130,164 @@ type IncludeDir = FilePath
|
|||
type PackageBaseName = String
|
||||
|
||||
-- | A package version.
|
||||
type PackageVersion = String
|
||||
type PackageVersion = String
|
||||
|
||||
-- | A package id.
|
||||
type PackageId = String
|
||||
type PackageId = String
|
||||
|
||||
-- | A package's name, verson and id.
|
||||
type Package = (PackageBaseName, PackageVersion, PackageId)
|
||||
type Package = (PackageBaseName, PackageVersion, PackageId)
|
||||
|
||||
pkgName :: Package -> PackageBaseName
|
||||
pkgName (n,_,_) = n
|
||||
pkgName (n, _, _) = n
|
||||
|
||||
pkgVer :: Package -> PackageVersion
|
||||
pkgVer (_,v,_) = v
|
||||
pkgVer (_, v, _) = v
|
||||
|
||||
pkgId :: Package -> PackageId
|
||||
pkgId (_,_,i) = i
|
||||
pkgId (_, _, i) = i
|
||||
|
||||
showPkg :: Package -> String
|
||||
showPkg (n,v,_) = intercalate "-" [n,v]
|
||||
showPkg (n, v, _) = intercalate "-" [n, v]
|
||||
|
||||
showPkgId :: Package -> String
|
||||
showPkgId (n,v,i) = intercalate "-" [n,v,i]
|
||||
showPkgId (n, v, i) = intercalate "-" [n, v, i]
|
||||
|
||||
-- | Haskell expression.
|
||||
type Expression = String
|
||||
newtype Expression = Expression { getExpression :: String }
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | Module name.
|
||||
type ModuleString = String
|
||||
newtype ModuleString = ModuleString { getModuleString :: String }
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
|
||||
-- | A Module
|
||||
type Module = [String]
|
||||
|
||||
data GmLogLevel = GmSilent
|
||||
| GmPanic
|
||||
| GmException
|
||||
| GmError
|
||||
| GmWarning
|
||||
| GmInfo
|
||||
| GmDebug
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
data GmLogLevel =
|
||||
GmSilent
|
||||
| GmPanic
|
||||
| GmException
|
||||
| GmError
|
||||
| GmWarning
|
||||
| GmInfo
|
||||
| GmDebug
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
-- | Collection of packages
|
||||
type PkgDb = (Map Package PackageConfig)
|
||||
|
||||
data GmModuleGraph = GmModuleGraph {
|
||||
gmgGraph :: Map ModulePath (Set ModulePath)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
gmgGraph :: Map ModulePath (Set ModulePath)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
instance Serialize GmModuleGraph where
|
||||
put GmModuleGraph {..} = let
|
||||
mpim :: Map ModulePath Integer
|
||||
graph :: Map Integer (Set Integer)
|
||||
put GmModuleGraph {..} = put (mpim, graph)
|
||||
where
|
||||
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 $
|
||||
(Map.keys gmgGraph) `zip` [0..]
|
||||
mpToInt :: ModulePath -> Integer
|
||||
mpToInt mp = fromJust $ Map.lookup mp mpim
|
||||
|
||||
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
|
||||
in put (mpim, graph)
|
||||
|
||||
get = do
|
||||
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
|
||||
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
|
||||
get = do
|
||||
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
|
||||
let 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
|
||||
where
|
||||
swapMap :: (Ord k, Ord v) => Map k v -> Map v k
|
||||
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
|
||||
|
||||
instance Monoid GmModuleGraph where
|
||||
mempty = GmModuleGraph mempty
|
||||
mappend (GmModuleGraph a) (GmModuleGraph a') =
|
||||
GmModuleGraph (Map.unionWith Set.union a a')
|
||||
mempty = GmModuleGraph mempty
|
||||
mappend (GmModuleGraph a) (GmModuleGraph a') =
|
||||
GmModuleGraph (Map.unionWith Set.union a a')
|
||||
|
||||
data GmComponentType = GMCRaw
|
||||
| GMCResolved
|
||||
data GmComponent (t :: GmComponentType) eps = GmComponent {
|
||||
gmcHomeModuleGraph :: GmModuleGraph,
|
||||
gmcName :: ChComponentName,
|
||||
gmcGhcOpts :: [GHCOption],
|
||||
gmcGhcPkgOpts :: [GHCOption],
|
||||
gmcGhcSrcOpts :: [GHCOption],
|
||||
gmcGhcLangOpts :: [GHCOption],
|
||||
gmcRawEntrypoints :: ChEntrypoint,
|
||||
gmcEntrypoints :: eps,
|
||||
gmcSourceDirs :: [FilePath]
|
||||
} deriving (Eq, Ord, Show, Read, Generic, Functor)
|
||||
gmcHomeModuleGraph :: GmModuleGraph
|
||||
, gmcName :: ChComponentName
|
||||
, gmcGhcOpts :: [GHCOption]
|
||||
, gmcGhcPkgOpts :: [GHCOption]
|
||||
, gmcGhcSrcOpts :: [GHCOption]
|
||||
, gmcGhcLangOpts :: [GHCOption]
|
||||
, gmcRawEntrypoints :: ChEntrypoint
|
||||
, gmcEntrypoints :: eps
|
||||
, gmcSourceDirs :: [FilePath]
|
||||
} deriving (Eq, Ord, Show, Read, Generic, Functor)
|
||||
|
||||
instance Serialize eps => Serialize (GmComponent t eps)
|
||||
|
||||
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 ModuleName where
|
||||
get = mkModuleName <$> get
|
||||
put mn = put (moduleNameString mn)
|
||||
get = mkModuleName <$> get
|
||||
put mn = put (moduleNameString mn)
|
||||
|
||||
instance Show ModuleName where
|
||||
show mn = "ModuleName " ++ show (moduleNameString mn)
|
||||
show mn = "ModuleName " ++ show (moduleNameString mn)
|
||||
|
||||
instance Read ModuleName where
|
||||
readsPrec d r = readParen (d > app_prec)
|
||||
(\r' -> [(mkModuleName m,t) |
|
||||
("ModuleName",s) <- lex r',
|
||||
(m,t) <- readsPrec (app_prec+1) s]) r
|
||||
where app_prec = 10
|
||||
readsPrec d =
|
||||
readParen
|
||||
(d > app_prec)
|
||||
(\r' -> [ (mkModuleName m, t)
|
||||
| ("ModuleName", s) <- lex r'
|
||||
, (m, t) <- readsPrec (app_prec + 1) s
|
||||
])
|
||||
where
|
||||
app_prec = 10
|
||||
|
||||
data GhcModError
|
||||
= GMENoMsg
|
||||
-- ^ Unknown error
|
||||
= GMENoMsg
|
||||
-- ^ Unknown error
|
||||
|
||||
| GMEString String
|
||||
-- ^ Some Error with a message. These are produced mostly by
|
||||
-- 'fail' calls on GhcModT.
|
||||
| GMEString String
|
||||
-- ^ Some Error with a message. These are produced mostly by
|
||||
-- 'fail' calls on GhcModT.
|
||||
|
||||
| GMECabalConfigure GhcModError
|
||||
-- ^ Configuring a cabal project failed.
|
||||
| GMECabalConfigure GhcModError
|
||||
-- ^ Configuring a cabal project failed.
|
||||
|
||||
| GMECabalFlags GhcModError
|
||||
-- ^ Retrieval of the cabal configuration flags failed.
|
||||
| GMECabalFlags GhcModError
|
||||
-- ^ Retrieval of the cabal configuration flags failed.
|
||||
|
||||
| GMECabalComponent ChComponentName
|
||||
-- ^ Cabal component could not be found
|
||||
| GMECabalComponent ChComponentName
|
||||
-- ^ Cabal component could not be found
|
||||
|
||||
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
||||
-- ^ Could not find a consistent component assignment for modules
|
||||
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
||||
-- ^ Could not find a consistent component assignment for modules
|
||||
|
||||
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
||||
-- ^ Launching an operating system process failed. Fields in
|
||||
-- order: command, arguments, (stdout, stderr, exitcode)
|
||||
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
||||
-- ^ Launching an operating system process failed. Fields in
|
||||
-- order: command, arguments, (stdout, stderr, exitcode)
|
||||
|
||||
| GMENoCabalFile
|
||||
-- ^ No cabal file found.
|
||||
| GMENoCabalFile
|
||||
-- ^ No cabal file found.
|
||||
|
||||
| GMETooManyCabalFiles [FilePath]
|
||||
-- ^ Too many cabal files found.
|
||||
| GMETooManyCabalFiles [FilePath]
|
||||
-- ^ Too many cabal files found.
|
||||
|
||||
| GMECabalStateFile GMConfigStateFileError
|
||||
-- ^ Reading Cabal's state configuration file falied somehow.
|
||||
deriving (Eq,Show,Typeable)
|
||||
| GMECabalStateFile GMConfigStateFileError
|
||||
-- ^ Reading Cabal's state configuration file falied somehow.
|
||||
deriving (Eq,Show,Typeable)
|
||||
|
||||
instance Error GhcModError where
|
||||
noMsg = GMENoMsg
|
||||
strMsg = GMEString
|
||||
noMsg = GMENoMsg
|
||||
strMsg = GMEString
|
||||
|
||||
instance Exception GhcModError
|
||||
|
||||
data GMConfigStateFileError
|
||||
= GMConfigStateFileNoHeader
|
||||
| GMConfigStateFileBadHeader
|
||||
| GMConfigStateFileNoParse
|
||||
| GMConfigStateFileMissing
|
||||
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
||||
= GMConfigStateFileNoHeader
|
||||
| GMConfigStateFileBadHeader
|
||||
| GMConfigStateFileNoParse
|
||||
| GMConfigStateFileMissing
|
||||
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
||||
deriving (Eq, Show, Read, Typeable)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -15,26 +15,26 @@
|
|||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DoAndIfThenElse #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Utils (
|
||||
module Language.Haskell.GhcMod.Utils
|
||||
, module Utils
|
||||
, readProcess
|
||||
) where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
import Exception
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Exception
|
||||
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
|
||||
getTemporaryDirectory, canonicalizePath, doesFileExist)
|
||||
import System.Process (readProcess)
|
||||
import System.Directory ()
|
||||
getTemporaryDirectory, canonicalizePath)
|
||||
import System.Environment
|
||||
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
|
||||
(</>))
|
||||
import System.IO.Temp (createTempDirectory)
|
||||
import System.Environment
|
||||
import System.Process (readProcess)
|
||||
import Text.Printf
|
||||
|
||||
import Paths_ghc_mod (getLibexecDir)
|
||||
|
|
@ -44,39 +44,30 @@ import Utils
|
|||
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
|
||||
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
|
||||
|
||||
extractParens :: String -> String
|
||||
extractParens str = extractParens' str 0
|
||||
where
|
||||
extractParens' :: String -> Int -> String
|
||||
extractParens' [] _ = []
|
||||
extractParens' (s:ss) level
|
||||
| s `elem` "([{" = s : extractParens' ss (level+1)
|
||||
| level == 0 = extractParens' ss 0
|
||||
| s `elem` "}])" && level == 1 = [s]
|
||||
| s `elem` "}])" = s : extractParens' ss (level-1)
|
||||
| otherwise = s : extractParens' ss level
|
||||
|
||||
withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
|
||||
withDirectory_ dir action =
|
||||
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
|
||||
(\_ -> liftIO (setCurrentDirectory dir) >> action)
|
||||
gbracket
|
||||
(liftIO getCurrentDirectory)
|
||||
(liftIO . setCurrentDirectory)
|
||||
(\_ -> liftIO (setCurrentDirectory dir) >> action)
|
||||
|
||||
uniqTempDirName :: FilePath -> FilePath
|
||||
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
|
||||
$ map escapeDriveChar *** map escapePathChar
|
||||
$ splitDrive dir
|
||||
where
|
||||
uniqTempDirName dir =
|
||||
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
|
||||
where
|
||||
(drive, path) = splitDrive dir
|
||||
escapeDriveChar :: Char -> Char
|
||||
escapeDriveChar c
|
||||
| isAlphaNum c = c
|
||||
| otherwise = '-'
|
||||
|
||||
| isAlphaNum c = c
|
||||
| otherwise = '-'
|
||||
escapePathChar :: Char -> Char
|
||||
escapePathChar c
|
||||
| c `elem` pathSeparators = '-'
|
||||
| otherwise = c
|
||||
| c `elem` pathSeparators = '-'
|
||||
| otherwise = c
|
||||
|
||||
newTempDir :: FilePath -> IO FilePath
|
||||
newTempDir dir =
|
||||
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
|
||||
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
|
||||
|
||||
whenM :: IO Bool -> IO () -> IO ()
|
||||
whenM mb ma = mb >>= flip when ma
|
||||
|
|
@ -94,21 +85,21 @@ ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
|
|||
|
||||
findLibexecExe :: String -> IO FilePath
|
||||
findLibexecExe "cabal-helper-wrapper" = do
|
||||
libexecdir <- getLibexecDir
|
||||
let exeName = "cabal-helper-wrapper"
|
||||
exe = libexecdir </> exeName
|
||||
libexecdir <- getLibexecDir
|
||||
let exeName = "cabal-helper-wrapper"
|
||||
exe = libexecdir </> exeName
|
||||
|
||||
exists <- doesFileExist exe
|
||||
exists <- doesFileExist exe
|
||||
|
||||
if exists
|
||||
then return exe
|
||||
else do
|
||||
mdir <- tryFindGhcModTreeDataDir
|
||||
case mdir of
|
||||
Nothing ->
|
||||
error $ libexecNotExitsError exeName libexecdir
|
||||
Just dir ->
|
||||
return $ dir </> "dist" </> "build" </> exeName </> exeName
|
||||
if exists
|
||||
then return exe
|
||||
else do
|
||||
mdir <- tryFindGhcModTreeDataDir
|
||||
case mdir of
|
||||
Nothing ->
|
||||
error $ libexecNotExitsError exeName libexecdir
|
||||
Just dir ->
|
||||
return $ dir </> "dist" </> "build" </> exeName </> exeName
|
||||
findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
|
||||
|
||||
libexecNotExitsError :: String -> FilePath -> String
|
||||
|
|
@ -131,22 +122,20 @@ tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
|
|||
tryFindGhcModTreeLibexecDir = do
|
||||
exe <- getExecutablePath'
|
||||
dir <- case takeFileName exe of
|
||||
"ghc" -> do -- we're probably in ghci; try CWD
|
||||
getCurrentDirectory
|
||||
_ ->
|
||||
return $ (!!4) $ iterate takeDirectory exe
|
||||
"ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD
|
||||
_ -> return $ (!!4) $ iterate takeDirectory exe
|
||||
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
||||
return $ if exists
|
||||
then Just dir
|
||||
else Nothing
|
||||
then Just dir
|
||||
else Nothing
|
||||
|
||||
tryFindGhcModTreeDataDir :: IO (Maybe FilePath)
|
||||
tryFindGhcModTreeDataDir = do
|
||||
dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'
|
||||
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
||||
return $ if exists
|
||||
then Just dir
|
||||
else Nothing
|
||||
then Just dir
|
||||
else Nothing
|
||||
|
||||
readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
|
||||
=> String -> [String] -> m String
|
||||
|
|
|
|||
|
|
@ -513,8 +513,8 @@ autoCmd = withParseCmd [] $ locAction "auto" auto
|
|||
refineCmd = withParseCmd [] $ locAction' "refine" refine
|
||||
|
||||
infoCmd = withParseCmd [] $ action
|
||||
where action [file,_,expr] = info file expr
|
||||
action [file,expr] = info file expr
|
||||
where action [file,_,expr] = info file $ Expression expr
|
||||
action [file,expr] = info file $ Expression expr
|
||||
action _ = throw $ InvalidCommandLine (Left "info")
|
||||
|
||||
legacyInteractiveCmd = withParseCmd [] $ \[] -> legacyInteractive >> return ""
|
||||
|
|
@ -528,9 +528,9 @@ locAction _ action [file,_,line,col] = action file (read line) (read col)
|
|||
locAction _ action [file, line,col] = action file (read line) (read col)
|
||||
locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)
|
||||
|
||||
locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a
|
||||
locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr
|
||||
locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr
|
||||
locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a
|
||||
locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr)
|
||||
locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expression expr)
|
||||
locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ getDb (SymDbReq ref _) = do
|
|||
|
||||
checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
|
||||
checkDb (SymDbReq ref act) db = do
|
||||
outdated <- liftIO $ isOutdated db
|
||||
outdated <- isOutdated db
|
||||
if outdated then do
|
||||
-- async and wait here is unnecessary because this is essentially
|
||||
-- synchronous. But Async can be used a cache.
|
||||
|
|
|
|||
|
|
@ -9,4 +9,4 @@ spec = do
|
|||
describe "db <- loadSymbolDb" $ do
|
||||
it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do
|
||||
db <- runD loadSymbolDb
|
||||
lookupSym "head" db `shouldContain` ["Data.List"]
|
||||
lookupSym "head" db `shouldContain` [ModuleString "Data.List"]
|
||||
|
|
|
|||
|
|
@ -34,17 +34,17 @@ spec = do
|
|||
describe "info" $ do
|
||||
it "works for non exported functions" $ do
|
||||
let tdir = "test/data/non-exported"
|
||||
res <- runD' tdir $ info "Fib.hs" "fib"
|
||||
res <- runD' tdir $ info "Fib.hs" $ Expression "fib"
|
||||
res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
|
||||
|
||||
it "works with a module using TemplateHaskell" $ do
|
||||
let tdir = "test/data/template-haskell"
|
||||
res <- runD' tdir $ info "Bar.hs" "foo"
|
||||
res <- runD' tdir $ info "Bar.hs" $ Expression "foo"
|
||||
res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
|
||||
|
||||
it "works with a module that imports another module using TemplateHaskell" $ do
|
||||
let tdir = "test/data/template-haskell"
|
||||
res <- runD' tdir $ info "ImportsTH.hs" "bar"
|
||||
res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar"
|
||||
res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
|
||||
|
||||
getDistDir :: IO FilePath
|
||||
|
|
|
|||
|
|
@ -1,11 +0,0 @@
|
|||
module UtilsSpec where
|
||||
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "extractParens" $ do
|
||||
it "extracts the part of a string surrounded by parentheses" $ do
|
||||
extractParens "asdasdasd ( hello [ world ] )()() kljlkjlkjlk" `shouldBe` "( hello [ world ] )"
|
||||
extractParens "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")][][]" `shouldBe` "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")]"
|
||||
Loading…
Reference in New Issue