hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge remote-tracking branch 'sergv/master'

Browse Source
This commit is contained in:
Daniel Gröber 2015-06-02 12:30:15 +02:00
commit 6dd1195b7f
15 changed files with 339 additions and 351 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Language/Haskell/GhcMod.hs
View File

@ -17,7 +17,7 @@ module Language.Haskell.GhcMod (
, gmLog
-- * Types
, ModuleString
, Expression
, Expression(..)
, GhcPkgDb
, Symbol
, SymbolDb

5
Language/Haskell/GhcMod/Boot.hs
View File

@ -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 = [

11
Language/Haskell/GhcMod/Browse.hs
View File

@ -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 | _

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

@ -64,6 +64,10 @@ instance ToString [String] where
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
-- |
--
-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]

65
Language/Haskell/GhcMod/FillSig.hs
View File

@ -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])
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,8 +336,9 @@ 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
refine file lineNo colNo (Expression expr) =
ghandle handler $
runGmlT' [Left file] deferErrors $ do
opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
@ -355,32 +355,39 @@ refine file lineNo colNo expr =
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
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
in return $ Just (s, name, t, b)
else return Nothing
_ -> 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"

86
Language/Haskell/GhcMod/Find.hs
View File

@ -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,7 +62,7 @@ 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
---------------------------------------------------------------
@ -83,14 +73,14 @@ loadSymbolDb = do
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
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,33 +92,36 @@ 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
isOlderThan :: FilePath -> FilePath -> IO Bool
isOlderThan cache file = do
-- | 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
if not exist
then return True
else do
tCache <- getModificationTime cache
tFile <- getModificationTime file
return $ tCache <= tFile -- including equal just in case
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
@ -138,14 +131,15 @@ getGlobalSymbolTable = do
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
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)

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

@ -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

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

@ -30,21 +30,22 @@ info :: IOish m
-> Expression -- ^ A Haskell expression.
-> GhcModT m String
info file expr =
ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $
ghandle handler $
runGmlT' [Left file] deferErrors $
withContext $
convert <$> options <*> body
where
handler (SomeException ex) = do
gmLog GmException "info" $
text "" $$ nest 4 (showDoc ex)
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
----------------------------------------------------------------
-- | Obtaining type of a target expression. (GHCi's type:)
@ -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
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
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
where
handler (SomeException ex) = do

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

@ -83,7 +83,6 @@ data Options = Options {
, hlintOpts :: [String]
} deriving (Show)
-- | A default 'Options'.
defaultOptions :: Options
defaultOptions = Options {
@ -93,7 +92,7 @@ defaultOptions = Options {
, ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal"
, ghcUserOptions= []
, ghcUserOptions = []
, operators = False
, detailed = False
, qualified = False
@ -140,30 +139,30 @@ type PackageId = String
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
data GmLogLevel =
GmSilent
| GmPanic
| GmException
| GmError
@ -180,28 +179,25 @@ data GmModuleGraph = GmModuleGraph {
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize GmModuleGraph where
put GmModuleGraph {..} = let
put GmModuleGraph {..} = put (mpim, graph)
where
mpim :: Map ModulePath Integer
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
graph :: Map Integer (Set Integer)
mpim = Map.fromList $
(Map.keys gmgGraph) `zip` [0..]
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
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
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
@ -211,15 +207,15 @@ instance Monoid GmModuleGraph where
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]
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)
@ -236,11 +232,15 @@ instance Show ModuleName where
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

43
Language/Haskell/GhcMod/Utils.hs
View File

@ -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,32 +44,23 @@ 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)
gbracket
(liftIO getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
uniqTempDirName :: FilePath -> FilePath
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
$ map escapeDriveChar *** map escapePathChar
$ splitDrive dir
uniqTempDirName dir =
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
where
(drive, path) = splitDrive dir
escapeDriveChar :: Char -> Char
escapeDriveChar c
| isAlphaNum c = c
| otherwise = '-'
escapePathChar :: Char -> Char
escapePathChar c
| c `elem` pathSeparators = '-'
| otherwise = c
@ -131,10 +122,8 @@ 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

10
src/GHCMod.hs
View File

@ -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)

2
src/Misc.hs
View File

@ -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.

2
test/FindSpec.hs
View File

@ -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"]

6
test/InfoSpec.hs
View File

@ -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

11
test/UtilsSpec.hs
View File

@ -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\")]"