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 , gmLog
-- * Types -- * Types
, ModuleString , ModuleString
, Expression , Expression(..)
, GhcPkgDb , GhcPkgDb
, Symbol , Symbol
, SymbolDb , 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. -- | 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 = [

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 'detailed' is 'True', their types are also obtained.
-- If 'operators' is 'True', operators are also returned. -- If 'operators' is 'True', operators are also returned.
browse :: forall m. IOish m 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 -> GhcModT m String
browse pkgmdl = do browse pkgmdl = do
convert' . sort =<< go convert' . sort =<< go
@ -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 | _

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

@ -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,12 @@ instance ToString String where
-- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
-- "foo\nbar\nbaz" -- "foo\nbar\nbaz"
instance ToString [String] where instance ToString [String] where
toLisp opt = toSexp1 opt toLisp opt = toSexp1 opt
toPlain opt = inter '\n' . map (toPlain 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 "" -- >>> 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) . (')' :)

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

@ -11,7 +11,7 @@ import Data.Char (isSymbol)
import Data.Function (on) import Data.Function (on)
import Data.List (find, nub, sortBy) import Data.List (find, nub, sortBy)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (isJust, catMaybes) import Data.Maybe (catMaybes)
import Exception (ghandle, SomeException(..)) import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
SrcSpan, Type, GenLocated(L)) SrcSpan, Type, GenLocated(L))
@ -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
@ -337,50 +336,58 @@ refine :: IOish m
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> Expression -- ^ A Haskell expression. -> Expression -- ^ A Haskell expression.
-> GhcModT m String -> GhcModT m String
refine file lineNo colNo expr = refine file lineNo colNo (Expression 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 =
let lst = sortBy (cmp `on` G.getLoc) $ case lst of
listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id] e@(L _ (G.HsVar i)):others -> do
in case lst of tyInfo <- Gap.getType tcm e
e@(L _ (G.HsVar i)):others -> case tyInfo of
do tyInfo <- Gap.getType tcm e Just (s, typ)
let name = getFnName dflag style i | name == "undefined" || head name == '_' ->
if (name == "undefined" || head name == '_') && isJust tyInfo return $ Just (s, name, typ, b)
then let Just (s,t) = tyInfo where
b = case others of -- If inside an App, we need name = getFnName dflag style i
-- parenthesis -- If inside an App, we need parenthesis
[] -> False b = case others of
L _ (G.HsApp (L _ a1) (L _ a2)):_ -> L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
isSearchedVar i a1 || isSearchedVar i a2 isSearchedVar i a1 || isSearchedVar i a2
_ -> False _ -> False
in return $ Just (s, name, t, b) _ -> return Nothing
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 :: String -> [String]
infinitePrefixSupply "undefined" = repeat "undefined" infinitePrefixSupply "undefined" = repeat "undefined"

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

@ -1,9 +1,8 @@
{-# LANGUAGE CPP, BangPatterns #-} {-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
module Language.Haskell.GhcMod.Find module Language.Haskell.GhcMod.Find
#ifndef SPEC #ifndef SPEC
( ( Symbol
Symbol
, SymbolDb , SymbolDb
, loadSymbolDb , loadSymbolDb
, lookupSymbol , lookupSymbol
@ -16,48 +15,39 @@ module Language.Haskell.GhcMod.Find
where where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (when, void) import Control.Monad (when, void, (<=<))
import Data.Function (on) import Data.Function (on)
import Data.List (groupBy, sort) import Data.List (groupBy, sort)
import Data.Maybe (fromMaybe)
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap (listVisibleModules)
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.World (timedPackageCaches)
import Language.Haskell.GhcMod.Gap (listVisibleModules)
import Name (getOccString) import Name (getOccString)
import Module (moduleName) import Module (moduleName)
import System.Directory (doesFileExist, getModificationTime) import System.Directory (doesFileExist, getModificationTime)
import System.FilePath ((</>), takeDirectory) 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
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Type of function and operation names. -- | Type of function and operation names.
type Symbol = String type Symbol = String
-- | Database from 'Symbol' to \['ModuleString'\]. -- | Database from 'Symbol' to \['ModuleString'\].
data SymbolDb = SymbolDb { data SymbolDb = SymbolDb
table :: Map Symbol [ModuleString] { table :: Map Symbol [ModuleString]
, packageCachePath :: FilePath
, symbolDbCachePath :: FilePath , symbolDbCachePath :: FilePath
} deriving (Show) } deriving (Show)
isOutdated :: SymbolDb -> IO Bool isOutdated :: (GmEnv m, IOish m) => SymbolDb -> m Bool
isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db 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 lookupSymbol sym db = convert' $ lookupSym sym db
lookupSym :: Symbol -> SymbolDb -> [ModuleString] 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'. -- | 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
, packageCachePath = takeDirectory file </> packageCache , symbolDbCachePath = file
, symbolDbCachePath = file }
}
where where
conv :: String -> (Symbol,[ModuleString]) conv :: String -> (Symbol, [ModuleString])
conv = read conv = read
chop :: String -> String
chop "" = "" chop "" = ""
chop xs = init xs chop xs = init xs
@ -102,50 +92,54 @@ loadSymbolDb = do
-- The file name is printed. -- The file name is printed.
dumpSymbol :: IOish m => FilePath -> GhcModT m String dumpSymbol :: IOish m => FilePath -> GhcModT m String
dumpSymbol dir = runGmPkgGhc $ do dumpSymbol dir = do
let cache = dir </> symbolCacheFile crdl <- cradle
pkgdb = dir </> packageCache runGmPkgGhc $ do
create <- liftIO $ isOlderThan cache =<< timedPackageCaches crdl
create <- liftIO $ cache `isOlderThan` pkgdb when create $
when create $ (liftIO . writeSymbolCache cache) =<< getGlobalSymbolTable liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
return $ unlines [cache] return $ unlines [cache]
where
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
isOlderThan :: FilePath -> FilePath -> IO Bool -- | Check whether given file is older than any file from the given set.
isOlderThan cache file = do -- Returns True if given file does not exist.
exist <- doesFileExist cache isOlderThan :: FilePath -> [TimedFile] -> IO Bool
if not exist then isOlderThan cache files = do
return True exist <- doesFileExist cache
else do if not exist
tCache <- getModificationTime cache then return True
tFile <- getModificationTime file else do
return $ tCache <= tFile -- including equal just in case tCache <- getModificationTime cache
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, modStr)) names
where where
names = G.modInfoExports inf names = G.modInfoExports inf
modStr = ModuleString $ moduleNameString $ moduleName mdl
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)

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

@ -103,6 +103,8 @@ import Parser
import SrcLoc import SrcLoc
import Packages import Packages
import Language.Haskell.GhcMod.Types (Expression(..))
---------------------------------------------------------------- ----------------------------------------------------------------
---------------------------------------------------------------- ----------------------------------------------------------------
-- --
@ -325,8 +327,8 @@ filterOutChildren get_thing xs
where where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
infoThing :: GhcMonad m => String -> m SDoc infoThing :: GhcMonad m => Expression -> m SDoc
infoThing str = do infoThing (Expression str) = do
names <- parseName str names <- parseName str
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
mb_stuffs <- mapM (getInfo False) names mb_stuffs <- mapM (getInfo False) names

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

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

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

@ -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,163 +130,164 @@ 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 newtype Expression = Expression { getExpression :: String }
deriving (Show, Eq, Ord)
-- | Module name. -- | Module name.
type ModuleString = String newtype ModuleString = ModuleString { getModuleString :: String }
deriving (Show, Read, Eq, Ord)
-- | A Module data GmLogLevel =
type Module = [String] GmSilent
| GmPanic
data GmLogLevel = 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)

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

@ -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)
@ -44,39 +44,30 @@ import Utils
dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] 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_ :: (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
@ -94,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
@ -131,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

10
src/GHCMod.hs
View File

@ -513,8 +513,8 @@ autoCmd = withParseCmd [] $ locAction "auto" auto
refineCmd = withParseCmd [] $ locAction' "refine" refine refineCmd = withParseCmd [] $ locAction' "refine" refine
infoCmd = withParseCmd [] $ action infoCmd = withParseCmd [] $ action
where action [file,_,expr] = info file expr where action [file,_,expr] = info file $ Expression expr
action [file,expr] = info file expr action [file,expr] = info file $ Expression expr
action _ = throw $ InvalidCommandLine (Left "info") action _ = throw $ InvalidCommandLine (Left "info")
legacyInteractiveCmd = withParseCmd [] $ \[] -> legacyInteractive >> return "" 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 _ action [file, line,col] = action file (read line) (read col)
locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd) locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)
locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a locAction' :: String -> (String -> Int -> Int -> Expression -> 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) (Expression expr)
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) (Expression expr)
locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd) 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 :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
checkDb (SymDbReq ref act) db = do checkDb (SymDbReq ref act) db = do
outdated <- liftIO $ isOutdated db outdated <- isOutdated db
if outdated then do if outdated then do
-- async and wait here is unnecessary because this is essentially -- async and wait here is unnecessary because this is essentially
-- synchronous. But Async can be used a cache. -- synchronous. But Async can be used a cache.

2
test/FindSpec.hs
View File

@ -9,4 +9,4 @@ spec = do
describe "db <- loadSymbolDb" $ do describe "db <- loadSymbolDb" $ do
it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do
db <- runD loadSymbolDb 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 describe "info" $ do
it "works for non exported functions" $ do it "works for non exported functions" $ do
let tdir = "test/data/non-exported" 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`) res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
it "works with a module using TemplateHaskell" $ do it "works with a module using TemplateHaskell" $ do
let tdir = "test/data/template-haskell" 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`) res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
it "works with a module that imports another module using TemplateHaskell" $ do it "works with a module that imports another module using TemplateHaskell" $ do
let tdir = "test/data/template-haskell" 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`) res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
getDistDir :: IO FilePath 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\")]"