From 57e2c112dc8f52ee031062a44a1ade6ac2c27c22 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 15:59:38 +0300 Subject: [PATCH 1/6] Use package dbs defined by current cradle when dealing with SymbolDBs --- Language/Haskell/GhcMod/Find.hs | 67 +++++++++++++++++---------------- src/Misc.hs | 2 +- 2 files changed, 36 insertions(+), 33 deletions(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 87fe3c6..039e83b 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} module Language.Haskell.GhcMod.Find #ifndef SPEC @@ -16,21 +16,21 @@ 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 @@ -50,14 +50,14 @@ import qualified Data.Map as M -- | 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 +72,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 --------------------------------------------------------------- @@ -81,16 +81,16 @@ loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do ghcMod <- liftIO ghcModExecutable tmpdir <- cradleTempDir <$> cradle - file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" - !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) - return $ SymbolDb { - table = db - , packageCachePath = takeDirectory file packageCache + file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" + !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) + return $ SymbolDb + { table = db , symbolDbCachePath = file } where conv :: String -> (Symbol,[ModuleString]) conv = read + chop :: String -> String chop "" = "" chop xs = init xs @@ -102,13 +102,15 @@ 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])] @@ -117,15 +119,16 @@ writeSymbolCache cache sm = void . withFile cache WriteMode $ \hdl -> mapM (hPrint hdl) sm -isOlderThan :: FilePath -> FilePath -> IO Bool -isOlderThan cache file = do - exist <- doesFileExist cache - if not exist then - return True - else do - tCache <- getModificationTime cache - tFile <- getModificationTime file - return $ tCache <= tFile -- including equal just in case +-- | Check whether given file is older than any file from the given set. +-- Returns True if given file does not exist. +isOlderThan :: FilePath -> [TimedFile] -> IO Bool +isOlderThan cache files = do + exist <- doesFileExist cache + if not exist + then return True + else do + tCache <- getModificationTime cache + return $ any (tCache <=) $ map tfTime files -- including equal just in case -- | Browsing all functions in all system modules. getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])] diff --git a/src/Misc.hs b/src/Misc.hs index f7f622e..2c646c6 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -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. From 73b98573f47cc0f21c1948875171644f30b8eb5a Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 16:31:17 +0300 Subject: [PATCH 2/6] Remove unused extractParens function and its tests --- Language/Haskell/GhcMod/Utils.hs | 12 ------------ test/UtilsSpec.hs | 11 ----------- 2 files changed, 23 deletions(-) delete mode 100644 test/UtilsSpec.hs diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 91331b5..d562290 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -44,18 +44,6 @@ 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) diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs deleted file mode 100644 index 75f61cc..0000000 --- a/test/UtilsSpec.hs +++ /dev/null @@ -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\")]" From a23f1f3b753ee5facbd321afc6c68b53a9a216fb Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 17:53:56 +0300 Subject: [PATCH 3/6] Improve findVar function --- Language/Haskell/GhcMod/FillSig.hs | 38 ++++++++++++++++-------------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 94f324c..f84675e 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -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)) @@ -364,23 +364,25 @@ findVar :: GhcMonad m => DynFlags -> PprStyle -> G.TypecheckedModule -> G.TypecheckedSource -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool)) findVar dflag style tcm tcs lineNo colNo = - let lst = sortBy (cmp `on` G.getLoc) $ - listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id] - in case lst of - e@(L _ (G.HsVar i)):others -> - do tyInfo <- Gap.getType tcm e - let name = getFnName dflag style i - if (name == "undefined" || head name == '_') && isJust tyInfo - then let Just (s,t) = tyInfo - b = case others of -- If inside an App, we need - -- parenthesis - [] -> False - L _ (G.HsApp (L _ a1) (L _ a2)):_ -> - isSearchedVar i a1 || isSearchedVar i a2 - _ -> False - in return $ Just (s, name, t, b) - else return Nothing - _ -> return Nothing + case lst of + e@(L _ (G.HsVar i)):others -> do + tyInfo <- Gap.getType tcm e + case tyInfo of + Just (span, typ) + | name == "undefined" || head name == '_' -> + return $ Just (span, name, typ, b) + where + name = getFnName dflag style i + -- If inside an App, we need parenthesis + b = case others of + L _ (G.HsApp (L _ a1) (L _ a2)):_ -> + isSearchedVar i a1 || isSearchedVar i a2 + _ -> False + _ -> return Nothing + _ -> return Nothing + where + lst :: [G.LHsExpr Id] + lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) infinitePrefixSupply :: String -> [String] infinitePrefixSupply "undefined" = repeat "undefined" From 4a9d5786815753ea0bf1fa1aee820272e4d9ffc6 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 17:54:50 +0300 Subject: [PATCH 4/6] Improve style --- Language/Haskell/GhcMod/Boot.hs | 5 +- Language/Haskell/GhcMod/Browse.hs | 9 +- Language/Haskell/GhcMod/Convert.hs | 36 ++--- Language/Haskell/GhcMod/FillSig.hs | 75 +++++----- Language/Haskell/GhcMod/Find.hs | 56 ++++---- Language/Haskell/GhcMod/Info.hs | 53 +++---- Language/Haskell/GhcMod/Types.hs | 213 +++++++++++++++-------------- Language/Haskell/GhcMod/Utils.hs | 79 +++++------ 8 files changed, 263 insertions(+), 263 deletions(-) diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index 7e261d5..70c77b6 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/Language/Haskell/GhcMod/Boot.hs @@ -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 = [ diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index bc45f82..f691464 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -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 | _ diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 248adde..39bb426 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -27,7 +27,7 @@ convert' :: (ToString a, IOish m, GmEnv m) => a -> m String convert' x = flip convert x <$> options convert :: ToString a => Options -> a -> String -convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" +convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" convert opt@Options { outputStyle = PlainStyle } x | str == "\n" = "" | otherwise = str @@ -35,8 +35,8 @@ convert opt@Options { outputStyle = PlainStyle } x str = toPlain opt x "\n" class ToString a where - toLisp :: Options -> a -> Builder - toPlain :: Options -> a -> Builder + toLisp :: Options -> a -> Builder + toPlain :: Options -> a -> Builder lineSep :: Options -> String lineSep opt = interpret lsep @@ -51,8 +51,8 @@ lineSep opt = interpret lsep -- >>> toPlain defaultOptions "foo" "" -- "foo" instance ToString String where - toLisp opt = quote opt - toPlain opt = replace '\n' (lineSep opt) + toLisp opt = quote opt + toPlain opt = replace '\n' (lineSep opt) -- | -- @@ -61,8 +61,8 @@ instance ToString String where -- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- "foo\nbar\nbaz" instance ToString [String] where - toLisp opt = toSexp1 opt - toPlain opt = inter '\n' . map (toPlain opt) + toLisp opt = toSexp1 opt + toPlain opt = inter '\n' . map (toPlain opt) -- | -- @@ -72,23 +72,23 @@ instance ToString [String] where -- >>> toPlain defaultOptions inp "" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" instance ToString [((Int,Int,Int,Int),String)] where - toLisp opt = toSexp2 . map toS - where - toS x = ('(' :) . tupToString opt x . (')' :) - toPlain opt = inter '\n' . map (tupToString opt) + toLisp opt = toSexp2 . map toS + where + toS x = ('(' :) . tupToString opt x . (')' :) + toPlain opt = inter '\n' . map (tupToString opt) instance ToString ((Int,Int,Int,Int),String) where - toLisp opt x = ('(' :) . tupToString opt x . (')' :) - toPlain opt x = tupToString opt x + toLisp opt x = ('(' :) . tupToString opt x . (')' :) + toPlain opt x = tupToString opt x instance ToString ((Int,Int,Int,Int),[String]) where - toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . - (' ' :) . toLisp opt s . (')' :) - toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s + toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . + (' ' :) . toLisp opt s . (')' :) + toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s instance ToString (String, (Int,Int,Int,Int),[String]) where - toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] - toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] + toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] + toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] toSexp1 :: Options -> [String] -> Builder toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index f84675e..ecfc93d 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -79,17 +79,14 @@ sig file lineNo colNo = Signature loc names ty -> ("function", fourInts loc, map (initialBody dflag style ty) names) - InstanceDecl loc cls -> let - body x = initialBody dflag style (G.idType x) x - in - ("instance", fourInts loc, body `map` Ty.classMethods cls) + InstanceDecl loc cls -> + let body x = initialBody dflag style (G.idType x) x + in ("instance", fourInts loc, body `map` Ty.classMethods cls) TyFamDecl loc name flavour vars -> let (rTy, initial) = initialTyFamString flavour body = initialFamBody dflag style name vars - in (rTy, fourInts loc, [initial ++ body]) - - + in (rTy, fourInts loc, [initial ++ body]) where fallback (SomeException _) = do opt <- options @@ -244,9 +241,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String initialHead1 fname args elts = case initialBodyArgs1 args elts of [] -> fname - arglist -> if isSymbolName fname - then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) - else fname ++ " " ++ unwords arglist + arglist + | isSymbolName fname -> + head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) + | otherwise -> + fname ++ " " ++ unwords arglist initialBodyArgs1 :: [FnArg] -> [String] -> [String] initialBodyArgs1 args elts = take (length args) elts @@ -338,39 +337,45 @@ refine :: IOish m -> Expression -- ^ A Haskell expression. -> GhcModT m String refine file lineNo colNo expr = - ghandle handler $ runGmlT' [Left file] deferErrors $ do - opt <- options - style <- getStyle - dflag <- G.getSessionDynFlags - modSum <- Gap.fileModSummary file - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - ety <- G.exprType expr - whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ - \(loc, name, rty, paren) -> - let eArgs = getFnArgs ety - rArgs = getFnArgs rty - diffArgs' = length eArgs - length rArgs - diffArgs = if diffArgs' < 0 then 0 else diffArgs' - iArgs = take diffArgs eArgs - text = initialHead1 expr iArgs (infinitePrefixSupply name) - in (fourInts loc, doParen paren text) - - where - handler (SomeException _) = emptyResult =<< options + ghandle handler $ + runGmlT' [Left file] deferErrors $ do + opt <- options + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- Gap.fileModSummary file + p <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + ety <- G.exprType expr + whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ + \(loc, name, rty, paren) -> + let eArgs = getFnArgs ety + rArgs = getFnArgs rty + diffArgs' = length eArgs - length rArgs + diffArgs = if diffArgs' < 0 then 0 else diffArgs' + iArgs = take diffArgs eArgs + text = initialHead1 expr iArgs (infinitePrefixSupply name) + in (fourInts loc, doParen paren text) + where + handler (SomeException _) = emptyResult =<< options -- Look for the variable in the specified position -findVar :: GhcMonad m => DynFlags -> PprStyle - -> G.TypecheckedModule -> G.TypecheckedSource - -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool)) +findVar + :: GhcMonad m + => DynFlags + -> PprStyle + -> G.TypecheckedModule + -> G.TypecheckedSource + -> Int + -> Int + -> m (Maybe (SrcSpan, String, Type, Bool)) findVar dflag style tcm tcs lineNo colNo = case lst of e@(L _ (G.HsVar i)):others -> do tyInfo <- Gap.getType tcm e case tyInfo of - Just (span, typ) + Just (s, typ) | name == "undefined" || head name == '_' -> - return $ Just (span, name, typ, b) + return $ Just (s, name, typ, b) where name = getFnName dflag style i -- If inside an App, we need parenthesis diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 039e83b..d361f20 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -2,8 +2,7 @@ module Language.Haskell.GhcMod.Find #ifndef SPEC - ( - Symbol + ( Symbol , SymbolDb , loadSymbolDb , lookupSymbol @@ -33,17 +32,8 @@ import System.Directory (doesFileExist, getModificationTime) 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 ---------------------------------------------------------------- @@ -79,16 +69,16 @@ lookupSym sym db = M.findWithDefault [] sym $ table db -- | Loading a file and creates 'SymbolDb'. loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do - ghcMod <- liftIO ghcModExecutable - tmpdir <- cradleTempDir <$> cradle - file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" - !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) - return $ SymbolDb - { table = db - , symbolDbCachePath = file - } + ghcMod <- liftIO ghcModExecutable + tmpdir <- cradleTempDir <$> cradle + file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" + !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) + return $ SymbolDb + { table = db + , symbolDbCachePath = file + } where - conv :: String -> (Symbol,[ModuleString]) + conv :: String -> (Symbol, [ModuleString]) conv = read chop :: String -> String chop "" = "" @@ -113,11 +103,11 @@ dumpSymbol dir = do cache = dir symbolCacheFile writeSymbolCache :: FilePath - -> [(Symbol,[ModuleString])] + -> [(Symbol, [ModuleString])] -> IO () writeSymbolCache cache sm = void . withFile cache WriteMode $ \hdl -> - mapM (hPrint hdl) sm + mapM (hPrint hdl) sm -- | Check whether given file is older than any file from the given set. -- Returns True if given file does not exist. @@ -131,24 +121,24 @@ isOlderThan cache files = do return $ any (tCache <=) $ map tfTime files -- including equal just in case -- | Browsing all functions in all system modules. -getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])] +getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])] getGlobalSymbolTable = do - df <- G.getSessionDynFlags - let mods = listVisibleModules df - moduleInfos <- mapM G.getModuleInfo mods - return $ collectModules - $ extractBindings `concatMap` (moduleInfos `zip` mods) + df <- G.getSessionDynFlags + let mods = listVisibleModules df + moduleInfos <- mapM G.getModuleInfo mods + return $ collectModules + $ extractBindings `concatMap` (moduleInfos `zip` mods) extractBindings :: (Maybe G.ModuleInfo, G.Module) -> [(Symbol, ModuleString)] -extractBindings (Nothing,_) = [] -extractBindings (Just inf,mdl) = - map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names +extractBindings (Nothing, _) = [] +extractBindings (Just inf, mdl) = + map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names where names = G.modInfoExports inf -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) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index d109f02..6344a5d 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -30,20 +30,21 @@ info :: IOish m -> Expression -- ^ A Haskell expression. -> GhcModT m String info file expr = - ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ - convert <$> options <*> body + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withContext $ + convert <$> options <*> body where handler (SomeException ex) = do - gmLog GmException "info" $ - text "" $$ nest 4 (showDoc ex) - convert' "Cannot show info" + gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex) + convert' "Cannot show info" + body :: GhcMonad m => m String body = do - sdoc <- Gap.infoThing expr - st <- getStyle - dflag <- G.getSessionDynFlags - return $ showPage dflag st sdoc - + sdoc <- Gap.infoThing expr + st <- getStyle + dflag <- G.getSessionDynFlags + return $ showPage dflag st sdoc ---------------------------------------------------------------- @@ -54,14 +55,14 @@ types :: IOish m -> Int -- ^ Column number. -> GhcModT m String types file lineNo colNo = - ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ do - crdl <- cradle - modSum <- Gap.fileModSummary (cradleCurrentDir crdl file) + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withContext $ do + crdl <- cradle + modSum <- Gap.fileModSummary (cradleCurrentDir crdl file) srcSpanTypes <- getSrcSpanType modSum lineNo colNo - - dflag <- G.getSessionDynFlags - st <- getStyle - + dflag <- G.getSessionDynFlags + st <- getStyle convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes where handler (SomeException ex) = do @@ -70,12 +71,12 @@ types file lineNo colNo = getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] - es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] - ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] - bts <- mapM (getType tcm) bs - ets <- mapM (getType tcm) es - pts <- mapM (getType tcm) ps - return $ catMaybes $ concat [ets, bts, pts] + p <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] + es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] + ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] + bts <- mapM (getType tcm) bs + ets <- mapM (getType tcm) es + pts <- mapM (getType tcm) ps + return $ catMaybes $ concat [ets, bts, pts] diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index b1be7f0..e5e0909 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -50,7 +50,7 @@ type MonadIOC m = (MTL.MonadIO m) #endif class MonadIOC m => MonadIO m where - liftIO :: IO a -> m a + liftIO :: IO a -> m a -- | Output style. data OutputStyle = LispStyle -- ^ S expression style. @@ -83,21 +83,20 @@ data Options = Options { , hlintOpts :: [String] } deriving (Show) - -- | A default 'Options'. defaultOptions :: Options defaultOptions = Options { - outputStyle = PlainStyle - , lineSeparator = LineSeparator "\0" - , logLevel = GmWarning - , ghcProgram = "ghc" - , ghcPkgProgram = "ghc-pkg" - , cabalProgram = "cabal" - , ghcUserOptions= [] - , operators = False - , detailed = False - , qualified = False - , hlintOpts = [] + outputStyle = PlainStyle + , lineSeparator = LineSeparator "\0" + , logLevel = GmWarning + , ghcProgram = "ghc" + , ghcPkgProgram = "ghc-pkg" + , cabalProgram = "cabal" + , ghcUserOptions = [] + , operators = False + , detailed = False + , qualified = False + , hlintOpts = [] } ---------------------------------------------------------------- @@ -113,7 +112,7 @@ data Cradle = Cradle { -- | The file name of the found cabal file. , cradleCabalFile :: Maybe FilePath -- | Package database stack - , cradlePkgDbStack :: [GhcPkgDb] + , cradlePkgDbStack :: [GhcPkgDb] } deriving (Eq, Show) ---------------------------------------------------------------- @@ -122,7 +121,7 @@ data Cradle = Cradle { data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) -- | A single GHC command line option. -type GHCOption = String +type GHCOption = String -- | An include directory for modules. type IncludeDir = FilePath @@ -131,28 +130,28 @@ type IncludeDir = FilePath type PackageBaseName = String -- | A package version. -type PackageVersion = String +type PackageVersion = String -- | A package id. -type PackageId = String +type PackageId = String -- | A package's name, verson and id. -type Package = (PackageBaseName, PackageVersion, PackageId) +type Package = (PackageBaseName, PackageVersion, PackageId) pkgName :: Package -> PackageBaseName -pkgName (n,_,_) = n +pkgName (n, _, _) = n pkgVer :: Package -> PackageVersion -pkgVer (_,v,_) = v +pkgVer (_, v, _) = v pkgId :: Package -> PackageId -pkgId (_,_,i) = i +pkgId (_, _, i) = i showPkg :: Package -> String -showPkg (n,v,_) = intercalate "-" [n,v] +showPkg (n, v, _) = intercalate "-" [n, v] showPkgId :: Package -> String -showPkgId (n,v,i) = intercalate "-" [n,v,i] +showPkgId (n, v, i) = intercalate "-" [n, v, i] -- | Haskell expression. type Expression = String @@ -163,131 +162,133 @@ type ModuleString = String -- | A Module type Module = [String] -data GmLogLevel = GmSilent - | GmPanic - | GmException - | GmError - | GmWarning - | GmInfo - | GmDebug - deriving (Eq, Ord, Enum, Bounded, Show, Read) +data GmLogLevel = + GmSilent + | GmPanic + | GmException + | GmError + | GmWarning + | GmInfo + | GmDebug + deriving (Eq, Ord, Enum, Bounded, Show, Read) -- | Collection of packages type PkgDb = (Map Package PackageConfig) data GmModuleGraph = GmModuleGraph { - gmgGraph :: Map ModulePath (Set ModulePath) - } deriving (Eq, Ord, Show, Read, Generic, Typeable) + gmgGraph :: Map ModulePath (Set ModulePath) + } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Serialize GmModuleGraph where - put GmModuleGraph {..} = let - mpim :: Map ModulePath Integer - graph :: Map Integer (Set Integer) + put GmModuleGraph {..} = put (mpim, graph) + where + mpim :: Map ModulePath Integer + mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..] + graph :: Map Integer (Set Integer) + graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph + mpToInt :: ModulePath -> Integer + mpToInt mp = fromJust $ Map.lookup mp mpim - mpim = Map.fromList $ - (Map.keys gmgGraph) `zip` [0..] - mpToInt :: ModulePath -> Integer - mpToInt mp = fromJust $ Map.lookup mp mpim - - graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph - in put (mpim, graph) - - get = do - (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get - let - swapMap = Map.fromList . map swap . Map.toList - swap (a,b) = (b,a) - impm = swapMap mpim - intToMp i = fromJust $ Map.lookup i impm - mpGraph :: Map ModulePath (Set ModulePath) - mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph - return $ GmModuleGraph mpGraph + get = do + (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get + let impm = swapMap mpim + intToMp i = fromJust $ Map.lookup i impm + mpGraph :: Map ModulePath (Set ModulePath) + mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph + return $ GmModuleGraph mpGraph + where + swapMap :: (Ord k, Ord v) => Map k v -> Map v k + swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList instance Monoid GmModuleGraph where - mempty = GmModuleGraph mempty - mappend (GmModuleGraph a) (GmModuleGraph a') = - GmModuleGraph (Map.unionWith Set.union a a') + mempty = GmModuleGraph mempty + mappend (GmModuleGraph a) (GmModuleGraph a') = + GmModuleGraph (Map.unionWith Set.union a a') data GmComponentType = GMCRaw | GMCResolved data GmComponent (t :: GmComponentType) eps = GmComponent { - gmcHomeModuleGraph :: GmModuleGraph, - gmcName :: ChComponentName, - gmcGhcOpts :: [GHCOption], - gmcGhcPkgOpts :: [GHCOption], - gmcGhcSrcOpts :: [GHCOption], - gmcGhcLangOpts :: [GHCOption], - gmcRawEntrypoints :: ChEntrypoint, - gmcEntrypoints :: eps, - gmcSourceDirs :: [FilePath] - } deriving (Eq, Ord, Show, Read, Generic, Functor) + gmcHomeModuleGraph :: GmModuleGraph + , gmcName :: ChComponentName + , gmcGhcOpts :: [GHCOption] + , gmcGhcPkgOpts :: [GHCOption] + , gmcGhcSrcOpts :: [GHCOption] + , gmcGhcLangOpts :: [GHCOption] + , gmcRawEntrypoints :: ChEntrypoint + , gmcEntrypoints :: eps + , gmcSourceDirs :: [FilePath] + } deriving (Eq, Ord, Show, Read, Generic, Functor) instance Serialize eps => Serialize (GmComponent t eps) data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } - deriving (Eq, Ord, Show, Read, Generic, Typeable) + deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Serialize ModulePath instance Serialize ModuleName where - get = mkModuleName <$> get - put mn = put (moduleNameString mn) + get = mkModuleName <$> get + put mn = put (moduleNameString mn) instance Show ModuleName where - show mn = "ModuleName " ++ show (moduleNameString mn) + show mn = "ModuleName " ++ show (moduleNameString mn) instance Read ModuleName where - readsPrec d r = readParen (d > app_prec) - (\r' -> [(mkModuleName m,t) | - ("ModuleName",s) <- lex r', - (m,t) <- readsPrec (app_prec+1) s]) r - where app_prec = 10 + readsPrec d = + readParen + (d > app_prec) + (\r' -> [ (mkModuleName m, t) + | ("ModuleName", s) <- lex r' + , (m, t) <- readsPrec (app_prec + 1) s + ]) + where + app_prec = 10 data GhcModError - = GMENoMsg - -- ^ Unknown error + = GMENoMsg + -- ^ Unknown error - | GMEString String - -- ^ Some Error with a message. These are produced mostly by - -- 'fail' calls on GhcModT. + | GMEString String + -- ^ Some Error with a message. These are produced mostly by + -- 'fail' calls on GhcModT. - | GMECabalConfigure GhcModError - -- ^ Configuring a cabal project failed. + | GMECabalConfigure GhcModError + -- ^ Configuring a cabal project failed. - | GMECabalFlags GhcModError - -- ^ Retrieval of the cabal configuration flags failed. + | GMECabalFlags GhcModError + -- ^ Retrieval of the cabal configuration flags failed. - | GMECabalComponent ChComponentName - -- ^ Cabal component could not be found + | GMECabalComponent ChComponentName + -- ^ Cabal component could not be found - | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] - -- ^ Could not find a consistent component assignment for modules + | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] + -- ^ Could not find a consistent component assignment for modules - | GMEProcess String [String] (Either (String, String, Int) GhcModError) - -- ^ Launching an operating system process failed. Fields in - -- order: command, arguments, (stdout, stderr, exitcode) + | GMEProcess String [String] (Either (String, String, Int) GhcModError) + -- ^ Launching an operating system process failed. Fields in + -- order: command, arguments, (stdout, stderr, exitcode) - | GMENoCabalFile - -- ^ No cabal file found. + | GMENoCabalFile + -- ^ No cabal file found. - | GMETooManyCabalFiles [FilePath] - -- ^ Too many cabal files found. + | GMETooManyCabalFiles [FilePath] + -- ^ Too many cabal files found. - | GMECabalStateFile GMConfigStateFileError - -- ^ Reading Cabal's state configuration file falied somehow. - deriving (Eq,Show,Typeable) + | GMECabalStateFile GMConfigStateFileError + -- ^ Reading Cabal's state configuration file falied somehow. + deriving (Eq,Show,Typeable) instance Error GhcModError where - noMsg = GMENoMsg - strMsg = GMEString + noMsg = GMENoMsg + strMsg = GMEString instance Exception GhcModError data GMConfigStateFileError - = GMConfigStateFileNoHeader - | GMConfigStateFileBadHeader - | GMConfigStateFileNoParse - | GMConfigStateFileMissing --- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) + = GMConfigStateFileNoHeader + | GMConfigStateFileBadHeader + | GMConfigStateFileNoParse + | GMConfigStateFileMissing +-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) deriving (Eq, Show, Read, Typeable) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index d562290..a9a092b 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -15,26 +15,26 @@ -- along with this program. If not, see . {-# 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) @@ -46,25 +46,28 @@ dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a withDirectory_ dir action = - gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) - (\_ -> liftIO (setCurrentDirectory dir) >> action) + gbracket + (liftIO getCurrentDirectory) + (liftIO . setCurrentDirectory) + (\_ -> liftIO (setCurrentDirectory dir) >> action) uniqTempDirName :: FilePath -> FilePath -uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++) - $ map escapeDriveChar *** map escapePathChar - $ splitDrive dir - where +uniqTempDirName dir = + "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path + where + (drive, path) = splitDrive dir + escapeDriveChar :: Char -> Char escapeDriveChar c - | isAlphaNum c = c - | otherwise = '-' - + | isAlphaNum c = c + | otherwise = '-' + escapePathChar :: Char -> Char escapePathChar c - | c `elem` pathSeparators = '-' - | otherwise = c + | c `elem` pathSeparators = '-' + | otherwise = c newTempDir :: FilePath -> IO FilePath newTempDir dir = - flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory + flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory whenM :: IO Bool -> IO () -> IO () whenM mb ma = mb >>= flip when ma @@ -82,21 +85,21 @@ ghcModExecutable = fmap ( "dist/build/ghc-mod/ghc-mod") getCurrentDirectory findLibexecExe :: String -> IO FilePath findLibexecExe "cabal-helper-wrapper" = do - libexecdir <- getLibexecDir - let exeName = "cabal-helper-wrapper" - exe = libexecdir exeName + libexecdir <- getLibexecDir + let exeName = "cabal-helper-wrapper" + exe = libexecdir exeName - exists <- doesFileExist exe + exists <- doesFileExist exe - if exists - then return exe - else do - mdir <- tryFindGhcModTreeDataDir - case mdir of - Nothing -> - error $ libexecNotExitsError exeName libexecdir - Just dir -> - return $ dir "dist" "build" exeName exeName + if exists + then return exe + else do + mdir <- tryFindGhcModTreeDataDir + case mdir of + Nothing -> + error $ libexecNotExitsError exeName libexecdir + Just dir -> + return $ dir "dist" "build" exeName exeName findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe libexecNotExitsError :: String -> FilePath -> String @@ -119,22 +122,20 @@ tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath) tryFindGhcModTreeLibexecDir = do exe <- getExecutablePath' dir <- case takeFileName exe of - "ghc" -> do -- we're probably in ghci; try CWD - getCurrentDirectory - _ -> - return $ (!!4) $ iterate takeDirectory exe + "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD + _ -> return $ (!!4) $ iterate takeDirectory exe exists <- doesFileExist $ dir "ghc-mod.cabal" return $ if exists - then Just dir - else Nothing + then Just dir + else Nothing tryFindGhcModTreeDataDir :: IO (Maybe FilePath) tryFindGhcModTreeDataDir = do dir <- (!!4) . iterate takeDirectory <$> getExecutablePath' exists <- doesFileExist $ dir "ghc-mod.cabal" return $ if exists - then Just dir - else Nothing + then Just dir + else Nothing readLibExecProcess' :: (MonadIO m, ExceptionMonad m) => String -> [String] -> m String From 6a65701397b6e1a642708e63ce5bed0f2ba68343 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 18:07:04 +0300 Subject: [PATCH 5/6] Remove unused Module type --- Language/Haskell/GhcMod/Types.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index e5e0909..e431806 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -159,9 +159,6 @@ type Expression = String -- | Module name. type ModuleString = String --- | A Module -type Module = [String] - data GmLogLevel = GmSilent | GmPanic From 7b6eb55b11b5813a30077482d09366c0ec4563b6 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 18:10:37 +0300 Subject: [PATCH 6/6] Transform ModuleString and Expression type synonyms into newtypes --- Language/Haskell/GhcMod.hs | 2 +- Language/Haskell/GhcMod/Browse.hs | 2 +- Language/Haskell/GhcMod/Convert.hs | 4 ++++ Language/Haskell/GhcMod/FillSig.hs | 2 +- Language/Haskell/GhcMod/Find.hs | 5 +++-- Language/Haskell/GhcMod/Gap.hs | 6 ++++-- Language/Haskell/GhcMod/Types.hs | 6 ++++-- src/GHCMod.hs | 10 +++++----- test/FindSpec.hs | 2 +- test/InfoSpec.hs | 6 +++--- 10 files changed, 27 insertions(+), 18 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 0b358a6..763384e 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -17,7 +17,7 @@ module Language.Haskell.GhcMod ( , gmLog -- * Types , ModuleString - , Expression + , Expression(..) , GhcPkgDb , Symbol , SymbolDb diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index f691464..19a4b02 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 39bb426..a679aa0 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -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)] diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index ecfc93d..b1700eb 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -336,7 +336,7 @@ refine :: IOish m -> Int -- ^ Column number. -> Expression -- ^ A Haskell expression. -> GhcModT m String -refine file lineNo colNo expr = +refine file lineNo colNo (Expression expr) = ghandle handler $ runGmlT' [Left file] deferErrors $ do opt <- options diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index d361f20..aee450c 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -133,9 +133,10 @@ extractBindings :: (Maybe G.ModuleInfo, G.Module) -> [(Symbol, ModuleString)] extractBindings (Nothing, _) = [] extractBindings (Just inf, mdl) = - map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names + map (\name -> (getOccString name, modStr)) names where - names = G.modInfoExports inf + names = G.modInfoExports inf + modStr = ModuleString $ moduleNameString $ moduleName mdl collectModules :: [(Symbol, ModuleString)] -> [(Symbol, [ModuleString])] diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index f76c7ce..4719185 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index e431806..b33c01a 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -154,10 +154,12 @@ showPkgId :: Package -> String 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) data GmLogLevel = GmSilent diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 49e4099..b029036 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -517,8 +517,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 "" @@ -532,9 +532,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) diff --git a/test/FindSpec.hs b/test/FindSpec.hs index 3560997..55e84df 100644 --- a/test/FindSpec.hs +++ b/test/FindSpec.hs @@ -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"] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index 091bbae..6a5296c 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -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