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

5
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
@ -59,7 +59,8 @@ 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 =
case break (==':') pkgmdl of
(mdl, "") -> (Nothing, mdl) (mdl, "") -> (Nothing, mdl)
(pkg, _:mdl) -> (Just pkg, mdl) (pkg, _:mdl) -> (Just pkg, mdl)

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

@ -64,6 +64,10 @@ 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
-- | -- |
-- --
-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] -- >>> 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.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,8 +336,9 @@ 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 $
runGmlT' [Left file] deferErrors $ do
opt <- options opt <- options
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
@ -355,32 +355,39 @@ refine file lineNo colNo expr =
iArgs = take diffArgs eArgs iArgs = take diffArgs eArgs
text = initialHead1 expr iArgs (infinitePrefixSupply name) text = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren text) 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)
else return Nothing
_ -> 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"

72
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,7 +62,7 @@ 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
--------------------------------------------------------------- ---------------------------------------------------------------
@ -83,14 +73,14 @@ loadSymbolDb = do
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,13 +92,15 @@ 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])]
@ -117,15 +109,16 @@ 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.
isOlderThan :: FilePath -> [TimedFile] -> IO Bool
isOlderThan cache files = do
exist <- doesFileExist cache exist <- doesFileExist cache
if not exist then if not exist
return True then return True
else do else do
tCache <- getModificationTime cache tCache <- getModificationTime cache
tFile <- getModificationTime file return $ any (tCache <=) $ map tfTime files -- including equal just in case
return $ tCache <= tFile -- 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])]
@ -140,9 +133,10 @@ 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])]

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

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

@ -30,21 +30,22 @@ 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 $
runGmlT' [Left file] deferErrors $
withContext $
convert <$> options <*> body 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
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Obtaining type of a target expression. (GHCi's type:) -- | Obtaining type of a target expression. (GHCi's type:)
@ -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 $
runGmlT' [Left file] deferErrors $
withContext $ do
crdl <- cradle crdl <- cradle
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file) 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

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

@ -83,7 +83,6 @@ 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 {
@ -155,15 +154,15 @@ 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
data GmLogLevel = GmSilent
| GmPanic | GmPanic
| GmException | GmException
| GmError | GmError
@ -180,28 +179,25 @@ data GmModuleGraph = GmModuleGraph {
} 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)
where
mpim :: Map ModulePath Integer mpim :: Map ModulePath Integer
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
graph :: Map Integer (Set Integer) graph :: Map Integer (Set Integer)
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
mpim = Map.fromList $
(Map.keys gmgGraph) `zip` [0..]
mpToInt :: ModulePath -> Integer mpToInt :: ModulePath -> Integer
mpToInt mp = fromJust $ Map.lookup mp mpim mpToInt mp = fromJust $ Map.lookup mp mpim
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
in put (mpim, graph)
get = do get = do
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
let let impm = swapMap mpim
swapMap = Map.fromList . map swap . Map.toList
swap (a,b) = (b,a)
impm = swapMap mpim
intToMp i = fromJust $ Map.lookup i impm intToMp i = fromJust $ Map.lookup i impm
mpGraph :: Map ModulePath (Set ModulePath) mpGraph :: Map ModulePath (Set ModulePath)
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
return $ GmModuleGraph mpGraph 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 instance Monoid GmModuleGraph where
mempty = GmModuleGraph mempty mempty = GmModuleGraph mempty
@ -211,15 +207,15 @@ instance Monoid GmModuleGraph where
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)
@ -236,11 +232,15 @@ 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

43
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,32 +44,23 @@ 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 getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action) (\_ -> 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
@ -131,10 +122,8 @@ 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

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