From 7b8f1fd421dff5f37aedcf81c42451e8a8435950 Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Wed, 13 Jul 2016 08:39:47 +1000 Subject: [PATCH 01/33] Add 'imported-from' command. --- Language/Haskell/GhcMod/Error.hs | 22 +- Language/Haskell/GhcMod/Gap.hs | 50 ++ Language/Haskell/GhcMod/ImportedFrom.hs | 825 ++++++++++++++++++++++ Language/Haskell/GhcMod/Types.hs | 6 + ghc-mod.cabal | 10 + src/GHCMod.hs | 2 + src/GHCMod/Options/Commands.hs | 7 +- test/ImportedFromSpec.hs | 101 +++ test/data/imported-from/ImportedFrom01.hs | 34 + test/data/imported-from/ImportedFrom02.hs | 19 + test/data/imported-from/ImportedFrom03.hs | 38 + 11 files changed, 1112 insertions(+), 2 deletions(-) create mode 100644 Language/Haskell/GhcMod/ImportedFrom.hs create mode 100644 test/ImportedFromSpec.hs create mode 100644 test/data/imported-from/ImportedFrom01.hs create mode 100644 test/data/imported-from/ImportedFrom02.hs create mode 100644 test/data/imported-from/ImportedFrom03.hs diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 4ec373c28..8e170966f 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -80,7 +80,6 @@ gmeDoc e = case e of \ Try enabling them:" $$ nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]") - backticks d = char '`' <> d <> char '`' ctxDoc = moduleDoc *** compsDoc >>> first (<> colon) >>> uncurry (flip hang 4) @@ -104,6 +103,27 @@ gmeDoc e = case e of GMETooManyCabalFiles cfs -> text $ "Multiple cabal files found. Possible cabal files: \"" ++ intercalate "\", \"" cfs ++"\"." + GMEMissingHaddockInterface f -> + text ("Haddock interface file missing: " ++ f) $$ + text "" $$ + haddockSuggestion + GMENoVisibleExports moduleName package -> + text $ "Failed to find visible exports of \"" ++ moduleName ++ "\" in \"" ++ package ++ "\"" + + where + + backticks d = char '`' <> d <> char '`' + + haddockSuggestion = + text "- To generate Haddock docs for dependencies, try:" $$ + nest 4 (backticks $ text "cabal install --enable-documentation --haddock-hyperlink-source --only-dependencies") $$ + text "" $$ + text "- or set" $$ + nest 4 (backticks $ text "documentation: True") $$ + text "in ~/.cabal/config" $$ + text "" $$ + text "- or with Stack:" $$ + nest 4 (backticks $ text "stack haddock") ghcExceptionDoc :: GhcException -> Doc ghcExceptionDoc e@(CmdLineError _) = diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index b8f9c658b..95f052f8e 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -48,6 +48,10 @@ module Language.Haskell.GhcMod.Gap ( , mkErrStyle' , everythingStagedWithContext , withCleanupSession + , ghcQualify + , ghcIdeclHiding + , ghc_sl_fs + , ghc_ms_textual_imps ) where import Control.Applicative hiding (empty) @@ -118,6 +122,10 @@ import Control.DeepSeq (NFData(rnf)) import Data.ByteString.Lazy.Internal (ByteString(..)) #endif +#if __GLASGOW_HASKELL__ >= 800 +import BasicTypes (sl_fs, StringLiteral) +#endif + import Bag import Lexer as L import Parser @@ -687,3 +695,45 @@ withCleanupSession action = do df <- getSessionDynFlags GHC.defaultCleanupHandler df action #endif + +-- | Things for Language.Haskell.GhcMod.ImportedFrom + +#if __GLASGOW_HASKELL__ >= 710 +ghcQualify :: PrintUnqualified +ghcQualify = reallyAlwaysQualify +#else +ghcQualify :: PrintUnqualified +ghcQualify = alwaysQualify +#endif + +#if __GLASGOW_HASKELL__ >= 710 +ghcIdeclHiding :: GHC.ImportDecl GHC.RdrName -> Maybe (Bool, SrcLoc.Located [GHC.LIE GHC.RdrName]) +ghcIdeclHiding = GHC.ideclHiding +#else +-- Here, we have +-- +-- ideclHiding :: Maybe (Bool, [LIE name]) +-- +-- so we have to use noLoc to get a SrcLoc.Located type in the second part of the tuple. +ghcIdeclHiding :: GHC.ImportDecl GHC.RdrName -> Maybe (Bool, SrcLoc.Located [GHC.LIE GHC.RdrName]) +ghcIdeclHiding x = case GHC.ideclHiding x of + Just (b, lie) -> Just (b, GHC.noLoc lie) + Nothing -> Nothing + +#endif + +#if __GLASGOW_HASKELL__ >= 800 +ghc_sl_fs :: StringLiteral -> FastString +ghc_sl_fs = sl_fs +#else +ghc_sl_fs = id +#endif + + +ghc_ms_textual_imps :: GHC.ModSummary -> [Located (ImportDecl RdrName)] +#if __GLASGOW_HASKELL__ >= 800 +-- What does GHC8 give in the first part of the tuple? +ghc_ms_textual_imps ms = map (fmap simpleImportDecl . snd) (ms_textual_imps ms) +#else +ghc_ms_textual_imps = ms_textual_imps +#endif diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs new file mode 100644 index 000000000..abd230ef3 --- /dev/null +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -0,0 +1,825 @@ +-- Copyright (C) 2013-2016 Carlo Hamalainen +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, FlexibleContexts, Rank2Types, ScopedTypeVariables, ViewPatterns #-} + +module Language.Haskell.GhcMod.ImportedFrom (importedFrom) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Maybe +import Data.Char (isAlpha) +import Data.IORef +import Data.List +import Data.List.Split +import Data.Maybe +import Exception (ghandle) +import FastString +import GHC +import HscTypes +import Language.Haskell.GhcMod +import Language.Haskell.GhcMod.DynFlags +import Language.Haskell.GhcMod.FileMapping +import Language.Haskell.GhcMod.Gap +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Output +import Language.Haskell.GhcMod.SrcUtils (listifySpans) +import Outputable +import System.Directory +import System.FilePath + +import qualified Data.Map as M +import qualified Data.Set as Set +import qualified Documentation.Haddock as Haddock +import qualified GhcMonad +import qualified Safe +import qualified SrcLoc +import qualified Text.ParserCombinators.ReadP as RP + +type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@. + +data NiceImportDecl + -- | Information about an import of a Haskell module. Convenience type + -- for the bits of a 'GHC.ImportDecl' that we need. + = NiceImportDecl + { modName :: String + , modQualifier :: Maybe String + , modIsImplicit :: Bool + , modHiding :: [String] + , modImportedAs :: Maybe String + , modSpecifically :: [String] + } deriving (Show, Eq) + + +-- trace' :: Show x => String -> x -> b -> b +-- trace' m x = trace (m ++ ">>> " ++ show x) + +-- trace'' :: Outputable x => String -> x -> b -> b +-- trace'' m x = trace (m ++ ">>> " ++ showSDoc tdflags (ppr x)) + +parsePackageAndQualName :: RP.ReadP (String, String) +parsePackageAndQualName = RP.choice [parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash] + + where + + -- Package with no hash (seems to be for internal packages?) + -- base-4.8.2.0:Data.Foldable.length + parsePackageAndQualNameNoHash = do + packageName <- parsePackageName + qName <- parsePackageFinalQualName + + return (packageName, qName) + + parsePackageName = RP.get `RP.manyTill` RP.char ':' + parsePackageFinalQualName = RP.many1 RP.get + +-- Parse the package name "containers-0.5.6.2" from a string like +-- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList" +parsePackageAndQualNameWithHash :: RP.ReadP (String, String) +parsePackageAndQualNameWithHash = do + packageName <- parsePackageName + _ <- parsePackageHash + qName <- parsePackageFinalQualName + + return (packageName, qName) + + where + + parsePackageName = RP.get `RP.manyTill` RP.char '@' + parsePackageHash = RP.get `RP.manyTill` RP.char ':' + parsePackageFinalQualName = RP.many1 RP.get + +runRP :: Show t => RP.ReadP t -> String -> Either String t +runRP rp s = case RP.readP_to_S rp s of + [(m, "")] -> Right m + err -> Left $ "runRP: no unique match: " ++ show err + +-- | Convenience function for converting an 'GHC.ImportDecl' to a 'NiceImportDecl'. +-- +-- Example: +-- +-- > -- Hiding.hs +-- > module Hiding where +-- > import Data.List hiding (map) +-- > import System.Environment (getArgs) +-- > import qualified Safe +-- +-- then: +-- +-- >>> map toImportDecl <$> getTextualImports "tests/data/data/Hiding.hs" "Hiding" >>= print +-- [ NiceImportDecl { modName = "Prelude" +-- , modQualifier = Nothing +-- , modIsImplicit = True +-- , modHiding = [] +-- , modImportedAs = Nothing +-- , modSpecifically = [] +-- } +-- , NiceImportDecl {modName = "Safe" +-- , modQualifier = Nothing +-- , modIsImplicit = False +-- , modHiding = [] +-- , modImportedAs = Nothing +-- , modSpecifically = [] +-- } +-- , NiceImportDecl { modName = "System.Environment" +-- , modQualifier = Nothing +-- , modIsImplicit = False +-- , modHiding = [] +-- , modImportedAs = Nothing +-- , modSpecifically = ["getArgs"] +-- } +-- , NiceImportDecl { modName = "Data.List" +-- , modQualifier = Nothing +-- , modIsImplicit = False +-- , modHiding = ["map"] +-- , modImportedAs = Nothing +-- , modSpecifically = [] +-- } +-- ] +toImportDecl :: GHC.DynFlags -> SrcLoc.Located (GHC.ImportDecl GHC.RdrName) -> NiceImportDecl +toImportDecl dflags idecl = NiceImportDecl + { modName = name + , modQualifier = qualifier + , modIsImplicit = isImplicit + , modHiding = hiding + , modImportedAs = importedAs + , modSpecifically = specifically + } + where + idecl' = SrcLoc.unLoc idecl + name = showSDoc dflags (ppr $ GHC.ideclName idecl') + isImplicit = GHC.ideclImplicit idecl' + qualifier = unpackFS <$> ghc_sl_fs <$> GHC.ideclPkgQual idecl' + hiding = (catMaybes . parseHiding . ghcIdeclHiding) idecl' + importedAs = (showSDoc dflags . ppr) <$> ideclAs idecl' + specifically = (parseSpecifically . ghcIdeclHiding) idecl' + + grabNames :: GHC.Located [GHC.LIE GHC.RdrName] -> [String] + grabNames loc = map (showSDoc dflags . ppr) names + where names :: [RdrName] + names = map (ieName . SrcLoc.unLoc) $ SrcLoc.unLoc loc + -- FIXME We are throwing away location info by using unLoc each time? + -- Trace these things to see what we are losing. + + parseHiding :: Maybe (Bool, Located [LIE RdrName]) -> [Maybe String] + parseHiding Nothing = [Nothing] + + -- If we do + -- + -- import System.Environment ( getArgs ) + -- + -- then we get ["getArgs"] here, but we don't really need it... + parseHiding (Just (False, _)) = [] + + -- Actually hid names, e.g. + -- + -- import Data.List hiding (map) + parseHiding (Just (True, h)) = map Just $ grabNames h + + parseSpecifically :: Maybe (Bool, Located [LIE RdrName]) -> [String] + parseSpecifically (Just (False, h)) = grabNames h + parseSpecifically _ = [] + +-- | Returns True if the 'Symbol' matches the end of the 'QualifiedName'. +-- +-- Example: +-- +-- >>> postfixMatch "bar" "Foo.bar" +-- True +-- >>> postfixMatch "bar" "Foo.baz" +-- False +-- >>> postfixMatch "bar" "bar" +-- True + +postfixMatch :: String -> QualifiedName -> Bool +postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName + where endTerm = last $ splitOn "." originalSymbol + +-- | Get the module part of a qualified name. +-- +-- Example: +-- +-- >>> moduleOfQualifiedName "Foo.bar" +-- Just "Foo" +-- >>> moduleOfQualifiedName "Foo" +-- Nothing +moduleOfQualifiedName :: QualifiedName -> Maybe String +moduleOfQualifiedName qn = if null bits + then Nothing + else Just $ intercalate "." bits + where bits = reverse $ drop 1 $ reverse $ splitOn "." qn + +-- | Find the possible qualified names for the symbol at line/col in the given Haskell file and module. +-- Returns a fully qualified name thatincludes the package, hash, and name, e.g. +-- +-- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList". +qualifiedName + :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) + => String -> Int -> Int -> String -> [String] -> m [String] +qualifiedName targetModuleName lineNr colNr symbol importList = do + dflags <- GHC.getSessionDynFlags + + setContext (map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)) + `gcatch` (\(s :: SourceError) -> do gmLog GmDebug "qualifiedName" $ strDoc $ "setContext failed with a SourceError, trying to continue anyway..." ++ show s + setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) + `gcatch` (\(g :: GhcApiError) -> do gmLog GmDebug "qualifiedName" $ strDoc $ "setContext failed with a GhcApiError, trying to continue anyway..." ++ show g + setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) + `gcatch` (\(se :: SomeException) -> do gmLog GmDebug "qualifiedName" $ strDoc $ "setContext failed with a SomeException, trying to continue anyway..." ++ show se + setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) + + modSummary <- getModSummary $ mkModuleName targetModuleName :: m ModSummary + p <- parseModule modSummary :: m ParsedModule + t <- typecheckModule p :: m TypecheckedModule + + let TypecheckedModule{tm_typechecked_source = tcs} = t + bs = listifySpans tcs (lineNr, colNr) :: [LHsBind Id] + es = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id] + ps = listifySpans tcs (lineNr, colNr) :: [LPat Id] + + let bs' = map (showSDocForUser dflags ghcQualify . ppr) bs + es' = map (showSDocForUser dflags ghcQualify . ppr) es + ps' = map (showSDocForUser dflags ghcQualify . ppr) ps + + gmLog GmDebug "qualifiedName" $ strDoc $ "symbol: " ++ symbol + gmLog GmDebug "qualifiedName" $ strDoc $ "line, col: " ++ show (lineNr, colNr) + + let stuff = map dropParens $ concatMap words $ bs' ++ es' ++ ps' + gmLog GmDebug "qualifiedName" $ strDoc $ "stuff: " ++ show stuff + + return $ filter (postfixMatch symbol) stuff + + where + -- GHC8 starts showing things inside parens? Why? e.g. "(base-4.9.0.0:GHC.Num.+)" + dropParens :: String -> String + dropParens = dropWhileEnd (== ')') . dropWhile (== '(') + +ghcPkgFindModule + :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) + => String + -> m (Maybe String) +ghcPkgFindModule mod = do + rp <- gmReadProcess + + (runMaybeT . msum . map MaybeT) + [ stackGhcPkgFindModule rp mod + , hcPkgFindModule rp mod + , ghcPkgFindModule' rp mod + ] + where + + runCmd rp cmd opts = liftIO ((Just <$> (rp cmd opts "")) `catch` (\(_::IOError) -> return Nothing)) + + -- | Call @ghc-pkg find-module@ to determine that package that provides a module, e.g. @Prelude@ is defined + -- in @base-4.6.0.1@. + -- ghcPkgFindModule' :: String -> IO (Maybe String) + ghcPkgFindModule' rp m = do + let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] + gmLog GmDebug "ghcPkgFindModule'" $ strDoc $ "ghc-pkg " ++ show opts + + x <- runCmd rp "ghc-pkg" opts + + -- gmLog GmDebug "" $ strDoc $ "ghcPkgFindModule' stdout: " ++ show output + -- gmLog GmDebug "" $ strDoc $ "ghcPkgFindModule' stderr: " ++ show err + return $ case x of + Just x' -> join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) x' + Nothing -> Nothing + + -- | Call @cabal sandbox hc-pkg@ to find the package the provides a module. + -- hcPkgFindModule :: String -> IO (Maybe String) + hcPkgFindModule rp m = do + let opts = ["sandbox", "hc-pkg", "find-module", m, "--", "--simple-output"] + + x <- runCmd rp "cabal" opts + + -- gmLog GmDebug "" $ strDoc $ "hcPkgFindModule stdout: " ++ show output + -- gmLog GmDebug "" $ strDoc $ "hcPkgFindModule stderr: " ++ show err + return $ case x of + Just x' -> join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) x' + Nothing -> Nothing + + -- | Call @stack exec ghc-pkg@ to find the package the provides a module. + -- stackGhcPkgFindModule :: String -> IO (Maybe String) + stackGhcPkgFindModule rp m = do + let opts = ["exec", "ghc-pkg", "find-module", m, "--", "--simple-output"] + + x <- runCmd rp "stack" opts + + -- gmLog GmDebug "" $ strDoc $ "stackGhcPkgFindModule stdout: " ++ show output + -- gmLog GmDebug "" $ strDoc $ "stackGhcPkgFindModule stderr: " ++ show err + return $ case x of + Just x' -> join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) x' + Nothing -> Nothing + +splitPackageName :: String -> String +splitPackageName p + = case splitOn "@" p of + [p0, _] -> p0 + _ -> p + +ghcPkgHaddockUrl + :: forall m. (GmLog m, GmOut m, MonadIO m) + => FilePath + -> (FilePath -> [String] -> String -> IO String) + -> [GhcPkgDb] + -> String + -> m (Maybe String) +ghcPkgHaddockUrl ghcPkg readProc pkgDbStack p = do + gmLog GmDebug "ghcPkgHaddockUrl" $ strDoc p + + let p' = splitPackageName p + + hout <- liftIO $ readProc ghcPkg (toDocDirOpts p' pkgDbStack) "" + return $ Safe.lastMay $ words $ reverse $ dropWhile (== '\n') $ reverse hout + where + -- This fails unless we have --global and --user, unlike + -- pkgDoc elsewhere in ghc-mod. + toDocDirOpts pkg dbs = ["field", pkg, "haddock-html", "--global", "--user"] ++ ghcPkgDbStackOpts dbs + +ghcPkgHaddockInterface + :: forall (m :: * -> *). MonadIO m + => FilePath + -> (FilePath -> [String] -> String -> IO String) + -> [GhcPkgDb] + -> String + -> m (Maybe String) +ghcPkgHaddockInterface ghcPkg readProc pkgDbStack p = do + hout <- liftIO $ readProc ghcPkg (toHaskellInterfaces p pkgDbStack) "" + return $ Safe.lastMay $ words $ reverse . dropWhile (== '\n') . reverse $ hout + where + toHaskellInterfaces pkg dbs = ["field", pkg, "haddock-interfaces", "--global", "--user"] ++ ghcPkgDbStackOpts dbs + +getVisibleExports + :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) + => (String -> m (Maybe String)) + -> String + -> m (Maybe (M.Map String [String])) +getVisibleExports getHaddockInterfaces p = do + gmLog GmDebug "getVisibleExports" $ strDoc p + + let p' = splitPackageName p + + haddockInterfaceFile <- getHaddockInterfaces p' + + case haddockInterfaceFile of + Just hi -> getVisibleExports' hi + Nothing -> return Nothing + + -- FIXME getVisibleExports' <$> (getHaddockInterfaces p') + + where + + getVisibleExports' :: forall m. (GhcMonad m, MonadIO m) + => FilePath + -> m (Maybe (M.Map String [String])) + getVisibleExports' ifile = do + iface <- Haddock.readInterfaceFile nameCacheFromGhc ifile + + dflags <- GHC.getSessionDynFlags + + case iface of + Left _ -> throw $ GMEMissingHaddockInterface ifile + Right iface' -> return $ Just $ M.fromList + [ (mname, names) + | ii <- Haddock.ifInstalledIfaces iface' + , let mname = showSDoc dflags $ ppr $ Haddock.instMod ii + names = map (showSDoc dflags . ppr) $ Haddock.instVisibleExports ii + ] + + + + ------------------------------------------------------------------------------------------------------------------------ + -- Copied from http://hackage.haskell.org/package/haddock-api-2.16.1/docs/src/Haddock-InterfaceFile.html#nameCacheFromGhc + -- but for a general monad m instead of the specific monad Ghc. + ------------------------------------------------------------------------------------------------------------------------ + nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => Haddock.NameCacheAccessor m + nameCacheFromGhc = ( read_from_session , write_to_session ) + where + read_from_session = do + ref <- GhcMonad.withSession (return . hsc_NC) + liftIO $ readIORef ref + write_to_session nc' = do + ref <- GhcMonad.withSession (return . hsc_NC) + liftIO $ writeIORef ref nc' + +getModuleExports + :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) + => FilePath + -> (FilePath -> [String] -> String -> IO String) + -> NiceImportDecl + -> m (Maybe ([String], String)) +getModuleExports ghcPkg readProc m = do + minfo <- (findModule (mkModuleName $ modName m) Nothing >>= getModuleInfo) + `gcatch` (\(e :: SourceError) -> do gmLog GmDebug "getModuleExports" $ strDoc $ "Failed to find module \"" ++ modName m ++ "\": " ++ show e + return Nothing) + + p <- ghcPkgFindModule $ modName m + + dflags <- GHC.getSessionDynFlags + + case (minfo, p) of + (Nothing, _) -> return Nothing + (_, Nothing) -> return Nothing + (Just minfo', Just p') -> return $ Just (map (showSDocForUser dflags ghcQualify . ppr) $ modInfoExports minfo', p') + +type FullyQualifiedName = String -- ^ e.g. e.g. "base-4.8.2.0:Data.Foldable.length" +type StrModuleName = String -- ^ e.g. "Data.List" + +data MySymbol = MySymbolSysQualified String -- ^ e.g. "base-4.8.2.0:Data.Foldable.length" + | MySymbolUserQualified String -- ^ e.g. "DL.length" with an import earlier like "import qualified Data.List as DL" + deriving Show + +data ModuleExports = ModuleExports + { mName :: StrModuleName -- ^ e.g. "Data.List" + , mPackageName :: String -- ^ e.g. "snap-0.14.0.6" + , mInfo :: NiceImportDecl -- ^ Our parse of the module import, with info like "hiding (map)". + , qualifiedExports :: [FullyQualifiedName] -- ^ e.g. [ "base-4.8.2.0:GHC.Base.++" + -- , "base-4.8.2.0:GHC.List.filter" + -- , "base-4.8.2.0:GHC.List.zip" + -- , ... + -- ] + } + deriving Show + +-- refineAs :: MySymbol -> [ModuleExports] -> [ModuleExports] + +-- User qualified the symbol, so we can filter out anything that doesn't have a matching 'modImportedAs'. +refineAs (MySymbolUserQualified userQualSym) exports = filterM f exports + where + f export = do + -- e.g. "DL" + case moduleOfQualifiedName userQualSym of + Nothing -> fail "ImportedFrom: expected a qualified name like 'DL.length' but got Nothing." + Just userQualAs -> return $ case modImportedAs $ mInfo export of + Nothing -> False + Just modas' -> modas' == userQualAs + +-- User didn't qualify the symbol, so we have the full system qualified thing, so do nothing here. +refineAs (MySymbolSysQualified _) exports = return exports + +refineRemoveHiding :: [ModuleExports] -> [ModuleExports] +refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports + where + f export = filter (`notElem` hiding') thisExports + where hiding = modHiding $ mInfo export :: [String] -- Things that this module hides. + hiding' = map (qualifyName thisExports) hiding :: [String] -- Qualified version of hiding. + thisExports = qualifiedExports export -- Things that this module exports. + + nub' = Set.toList . Set.fromList + + qualifyName :: [QualifiedName] -> String -> QualifiedName + qualifyName qualifiedNames name + -- = case filter (postfixMatch name) qualifiedNames of + = case nub' (filter (name `f`) qualifiedNames) of + [match] -> match + m -> throw $ GMEString $ "ImportedFrom: could not qualify " ++ name ++ " from these exports: " ++ show qualifiedNames ++ "\n matches: " ++ show m + + -- Time for some stringly typed rubbish. The previous test used + -- postfixMatch but this failed on an import that had "hiding (lines, unlines)" since + -- both lines and unlines matched. Prepending a dot doesn't work due to things like ".=" from + -- Control.Lens. So we manually check that the suffix matches, that the next symbol is a dot, + -- and then an alpha character, which hopefully is the end of a module name. Such a mess. + where f n qn = if length qn - length n - 2 >= 0 + then n `isSuffixOf` qn && isAlpha (qn !! (length qn - length n - 2)) && (qn !! (length qn - length n - 1)) == '.' + else throw $ GMEString $ "ImportedFrom internal error: trying to check if \"" ++ n ++ "\" is a match for \"" ++ qn ++ "\"" + +refineExportsIt :: MySymbol -> [ModuleExports] -> [ModuleExports] +refineExportsIt mysymbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports + where + -- Deal with these? + symbol = case mysymbol of + MySymbolSysQualified s -> s + MySymbolUserQualified s -> s + + f sym export = filter (postfixMatch sym) thisExports + where thisExports = qualifiedExports export -- Things that this module exports. + +-- On an internal symbol (e.g. Show), refineExportsIt erronously filters out everything. +-- For example mnsymbol = "base-4.9.0.0:GHC.Show.C:Show" and the matching +-- name "base-4.9.0.0:GHC.Show.Show" from the Prelude. The problem seems to be the +-- module name GHC.Show.C, probably referring to an internal C library. +-- +-- To get around this, refineExportsItFallbackInternal uses a less strict matching +-- rule. If the 'stage3' results are empty we fall back to this refiner. +refineExportsItFallbackInternal :: MySymbol -> [ModuleExports] -> [ModuleExports] +refineExportsItFallbackInternal mysymbol exports + = case splitOn ":" symbol of + [p, _, x] -> map (\e -> e { qualifiedExports = f p x e }) exports + _ -> exports + where + -- Deal with these? + symbol = case mysymbol of + MySymbolSysQualified s -> s + MySymbolUserQualified s -> s + + -- Check if package name matches and postfix symbol matches (roughly). + f p sym export = filter + (\z -> p `isPrefixOf` z && postfixMatch sym z) + (qualifiedExports export) + +refineLeadingDot :: MySymbol -> [ModuleExports] -> [ModuleExports] +refineLeadingDot (MySymbolUserQualified _) exports = exports +refineLeadingDot (MySymbolSysQualified symb) exports = map (\e -> e { qualifiedExports = f leadingDot e }) exports + where + -- We use leadingDot only when we have an 'MySymbolSysQualified symb' so + -- the 'last' will be ok. Sample value of 'symb' in this case is + -- "base-4.8.2.0:Data.Foldable.length". + leadingDot :: String + leadingDot = '.' : last (splitOn "." symb) + + -- f symbol export = filter (symbol ==) thisExports + f symbol export = filter (symbol `isSuffixOf`) thisExports + where thisExports = qualifiedExports export -- Things that this module exports. + +refineVisibleExports + :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) + => (String -> m (Maybe String)) + -> [ModuleExports] + -> m [ModuleExports] +refineVisibleExports getHaddockInterfaces exports = mapM f exports + where + f :: ModuleExports -> m ModuleExports + f mexports = do + let pname = mPackageName mexports -- e.g. "base-4.8.2.0" + thisModuleName = mName mexports -- e.g. "Prelude" + qexports = qualifiedExports mexports -- e.g. ["base-4.8.2.0:GHC.Base.Just", ...] + mVisibleExportsMap <- getVisibleExports getHaddockInterfaces pname + + visibleExportsMap <- case mVisibleExportsMap of + Nothing -> fail $ "ImportedFrom: visible exports map is Nothing" + Just x -> return x + + gmLog GmDebug "visibleExportsMap" $ strDoc $ show visibleExportsMap + + let thisModVisibleExports0 = M.lookup thisModuleName visibleExportsMap + + -- On earlier versions of GHC, our qexports list will not be fully qualified, so it will + -- look like ["base:GHC.Base.Just", ...] instead of ["base-4.8.2.0:GHC.Base.Just", ...]. + -- So if thisModVisibleExports0 is Nothing, fall back to searching on a shorter pname. + let pname' = (head $ splitOn "-" pname) ++ ":" ++ thisModuleName + mThisModVisibleExports = thisModVisibleExports0 + `mplus` + (M.lookup pname' visibleExportsMap) + + thisModVisibleExports <- case mThisModVisibleExports of + Nothing -> throw $ GMENoVisibleExports thisModuleName pname' + Just x -> return x + + let qexports' = filter (hasPostfixMatch thisModVisibleExports) qexports + + gmLog GmDebug "visibleExportsMap" $ strDoc $ show (qexports, qexports') + + return $ mexports { qualifiedExports = qexports' } + + -- hasPostfixMatch "base-4.8.2.0:GHC.Base.Just" ["Just", "True", ...] -> True + hasPostfixMatch :: [String] -> String -> Bool + hasPostfixMatch xs s = last (splitOn "." s) `elem` xs + +-- | The last thing with a single export must be the match? Iffy. +getLastMatch :: [ModuleExports] -> Maybe ModuleExports +getLastMatch exports = Safe.lastMay $ filter f exports + where + f me = length (qualifiedExports me) == 1 + +-- | Try to look up the Haddock URL for a symbol. +guessHaddockUrl + :: forall m. + (GhcMonad m, MonadIO m, GmOut m, GmLog m) + => ModSummary + -> FilePath + -> String + -> String + -> Int + -> Int + -> FilePath + -> (FilePath -> [String] -> String -> IO String) + -> [GhcPkgDb] + -> m String +guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readProc pkgDbStack = do + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "targetFile: " ++ targetFile + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "targetModule: " ++ targetModule + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "symbol: " ++ show symbol + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "line nr: " ++ show lineNr + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "col nr: " ++ show colNr + + dflags <- GHC.getSessionDynFlags + + let textualImports = ghc_ms_textual_imps modSum + importDecls0 = map (toImportDecl dflags) textualImports + + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "haskellModuleNames0: " ++ show importDecls0 + + -- If symbol is something like DM.lookup, then restrict importDecls0 to the + -- one that has modImportedAs == Just "DM". + let importDecls1 = filterMatchingQualifiedImport symbol importDecls0 + + -- If that filter left us with nothing, revert back to the original list. + let importDecls2 = if null importDecls1 + then importDecls0 + else importDecls1 + + qnames <- filter (not . (' ' `elem`)) <$> qualifiedName targetModule lineNr colNr symbol (map modName importDecls2) :: m [String] + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "qnames: " ++ show qnames + + let symbolToUse :: String + symbolToUse = case qnames of + (qq:_) -> qq -- We got a qualified name, with qualified printing. Qualified! + [] -> fail "ImportedFrom: qnames is empty." + + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "symbolToUse: " ++ symbolToUse + + -- Sometimes we have to load an extra module (using setContext) otherwise + -- we can't look up the global reader environment without causing a GHC panic. + -- For example 'Int' comes from GHC.Types, which is picked up here via the + -- full qualified name. + let parsedPackagesAndQualNames = map (runRP parsePackageAndQualName) qnames + + mkNiceDecl x = [ NiceImportDecl + { modName = x + , modQualifier = Nothing + , modIsImplicit = False + , modHiding = [] + , modImportedAs = Nothing + , modSpecifically = [] + } + ] + + extraImportDecls :: [NiceImportDecl] + extraImportDecls = case Safe.headMay parsedPackagesAndQualNames of + Just (Right (_, moduleOfQualifiedName -> Just x)) -> mkNiceDecl x + _ -> [] + + importDecls3 = importDecls2 ++ extraImportDecls + + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "parsedPackagesAndQualNames: " ++ show parsedPackagesAndQualNames + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "extraImportDecls: " ++ show extraImportDecls + + exports0 <- mapM (getModuleExports ghcPkg readProc) importDecls3 :: m [Maybe ([String], String)] + + -- Sometimes the modules in extraImportDecls might be hidden or weird ones like GHC.Base that we can't + -- load, so filter out the successfully loaded ones. + let successes :: [(NiceImportDecl, Maybe ([String], String))] + successes = filter (isJust . snd) (zip importDecls3 exports0) + + toMaybe :: (NiceImportDecl, Maybe ([FullyQualifiedName], String)) + -> Maybe (NiceImportDecl, ([FullyQualifiedName], String)) + toMaybe (h, Just x) = Just (h, x) + toMaybe (_, Nothing) = Nothing + + successes' :: [(NiceImportDecl, ([String], String))] + successes' = mapMaybe toMaybe successes + + mkExports (m, (e, p)) = ModuleExports + { mName = modName m + , mPackageName = p + , mInfo = m + , qualifiedExports = e + } + + stage0 = map mkExports successes' + + -- Get all "as" imports. + let asImports :: [String] + asImports = mapMaybe (modImportedAs . mInfo) stage0 + + mySymbol = case moduleOfQualifiedName symbol of + Nothing -> MySymbolSysQualified symbolToUse + Just x -> if x `elem` asImports + then MySymbolUserQualified symbol + else MySymbolSysQualified symbolToUse + + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "mySymbol: " ++ show mySymbol + + let pprModuleExports :: ModuleExports -> String + pprModuleExports me = "(" ++ mName me ++ ", " ++ show (mInfo me) ++ ", " ++ unwords (map show $ qualifiedExports me) ++ ")" + + showDebugStage stageNr stage = forM_ stage $ \x -> gmLog GmDebug "guessHaddockUrl" $ strDoc $ stageNr ++ " " ++ pprModuleExports x + + showDebugStage "stage0" stage0 + + stage1 <- refineAs mySymbol stage0 + showDebugStage "stage1" stage1 + + let stage2 = refineRemoveHiding stage1 + showDebugStage "stage2" stage2 + + let stage3 = refineExportsIt mySymbol stage2 + showDebugStage "stage3" stage3 + + let stage4 = if all (null . qualifiedExports) stage3 + then refineExportsItFallbackInternal mySymbol stage2 + else refineLeadingDot mySymbol stage3 + showDebugStage "stage4" stage4 + + stage5 <- refineVisibleExports (ghcPkgHaddockInterface ghcPkg readProc pkgDbStack) stage4 + showDebugStage "stage5" stage5 + + let lastMatch = Safe.headMay $ catMaybes [getLastMatch stage5, getLastMatch stage4] + + gmLog GmDebug "guessHaddockUrl" $ strDoc $ show $ "lastMatch: " ++ show lastMatch + + let lastMatchModule :: String + lastMatchModule = case mName <$> lastMatch of + Just modn -> modn + _ -> fail $ "ImportedFrom: no nice match in lastMatch for module: " ++ show lastMatch + + lastMatchPackageName :: String + lastMatchPackageName = case mPackageName <$> lastMatch of + Just p -> p + _ -> fail $ "ImportedFrom: no nice match in lastMatch for package name: " ++ show lastMatch + + mhaddock <- ghcPkgHaddockUrl ghcPkg readProc pkgDbStack lastMatchPackageName + + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "lastMatchModule: " ++ lastMatchModule + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "lastMatchPackageName: " ++ lastMatchPackageName + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "mhaddock: " ++ show mhaddock + + case mhaddock of + Nothing -> fail $ "ImportedFrom: ghcPkgHaddockUrl failed to find path to HTML file." + Just haddock -> do let f = haddock (moduleNameToHtmlFile lastMatchModule) + + let mySymbol' = case mySymbol of + MySymbolSysQualified s -> s + MySymbolUserQualified s -> s + + return $ mySymbol' ++ " " ++ lastMatchModule ++ " file://" ++ f + ++ " " ++ toHackageUrl f lastMatchPackageName lastMatchModule + + where + -- Convert a module name string, e.g. @Data.List@ to @Data-List.html@. + moduleNameToHtmlFile :: String -> String + moduleNameToHtmlFile m = map f m ++ ".html" + where + f :: Char -> Char + f '.' = '-' + f c = c + + toHackageUrl :: FilePath -> String -> String -> String + toHackageUrl filepath package modulename = "https://hackage.haskell.org/package/" ++ package ++ "/" ++ "docs/" ++ modulename'' + where filepath' = map repl filepath + modulename' = head $ splitOn "." $ head $ splitOn "-" modulename + modulename'' = drop (fromJust $ substringP modulename' filepath') filepath' + + -- On Windows we get backslashes in the file path; convert + -- to forward slashes for the URL. + repl :: Char -> Char + repl '\\' = '/' + repl c = c + + -- Adapted from http://www.haskell.org/pipermail/haskell-cafe/2010-June/078702.html + substringP :: String -> String -> Maybe Int + substringP _ [] = Nothing + substringP sub str = if sub `isPrefixOf` str then Just 0 else fmap (+1) $ substringP sub (tail str) + + filterMatchingQualifiedImport :: String -> [NiceImportDecl] -> [NiceImportDecl] + filterMatchingQualifiedImport symbol hmodules + = case moduleOfQualifiedName symbol of + Nothing -> [] + asBit@(Just _) -> filter (\z -> asBit == modImportedAs z) hmodules + +-- | Look up Haddock docs for a symbol. +importedFrom + :: forall m. IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Expression -- ^ Expression (symbol) + -> GhcModT m String +importedFrom file lineNr colNr (Expression symbol) = do + ghcPkg <- getGhcPkgProgram + readProc <- gmReadProcess + pkgDbStack <- getPackageDbStack + + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withInteractiveContext $ importedFrom' ghcPkg readProc pkgDbStack + where + handler (SomeException ex) = do + gmLog GmException "imported-from" $ showDoc ex + return $ "imported-from exception: " ++ show ex + + importedFrom' + :: FilePath + -> (FilePath -> [String] -> String -> IO String) + -> [GhcPkgDb] + -> GmlT m String + importedFrom' ghcPkg readProc pkgDbStack = do + crdl <- cradle + modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) + let modstr = moduleNameString $ ms_mod_name modSum :: String + + guessHaddockUrl modSum file modstr symbol lineNr colNr ghcPkg readProc pkgDbStack diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 2be44cc37..bb58345c9 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -352,6 +352,12 @@ data GhcModError | GMETooManyCabalFiles [FilePath] -- ^ Too many cabal files found. + | GMEMissingHaddockInterface FilePath + -- ^ Haddock interface file missing. + + | GMENoVisibleExports String String + -- ^ Failed to find visible exports of module in given package. + deriving (Eq,Show,Typeable) instance Error GhcModError where diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 0b210e6b3..fdaacbfd0 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -87,6 +87,7 @@ Extra-Source-Files: ChangeLog test/data/file-mapping/*.hs test/data/file-mapping/preprocessor/*.hs test/data/file-mapping/lhs/*.lhs + test/data/imported-from/*.hs test/data/nice-qualification/*.hs test/data/stack-project/stack.yaml test/data/stack-project/new-template.cabal @@ -137,6 +138,7 @@ Library Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.GhcPkg Language.Haskell.GhcMod.HomeModuleGraph + Language.Haskell.GhcMod.ImportedFrom Language.Haskell.GhcMod.Info Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint @@ -211,6 +213,13 @@ Library if impl(ghc >= 8.0) Build-Depends: ghc-boot + if impl(ghc >= 8.0) + Build-Depends: haddock-api < 2.18 + if impl(ghc >= 7.8 && < 8.0) + Build-Depends: haddock-api < 2.16 + if impl(ghc < 7.8) + Build-Depends: haddock < 2.15.0 + Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs @@ -283,6 +292,7 @@ Test-Suite spec CustomPackageDbSpec CheckSpec FlagSpec + ImportedFromSpec InfoSpec LangSpec LintSpec diff --git a/src/GHCMod.hs b/src/GHCMod.hs index ed28d5685..936a5da40 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -13,6 +13,7 @@ import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb) +import Language.Haskell.GhcMod.ImportedFrom (importedFrom) import System.FilePath (()) import System.Directory (setCurrentDirectory, getAppUserDataDirectory, removeDirectoryRecursive) @@ -150,6 +151,7 @@ ghcCommands (CmdLint opts file) = lint opts file ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms ghcCommands (CmdCheck files) = checkSyntax files ghcCommands (CmdExpand files) = expandTemplate files +ghcCommands (CmdImportedFrom file (line, col) symb) = importedFrom file line col $ Expression symb ghcCommands (CmdInfo file symb) = info file $ Expression symb ghcCommands (CmdType wCon file (line, col)) = types wCon file line col ghcCommands (CmdSplit file (line, col)) = splits file line col diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index 688905f13..c812500de 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -50,6 +50,7 @@ data GhcModCommands = | CmdDebugComponent [String] | CmdCheck [FilePath] | CmdExpand [FilePath] + | CmdImportedFrom FilePath Point Expr | CmdInfo FilePath Symbol | CmdType Bool FilePath Point | CmdSplit FilePath Point @@ -133,6 +134,9 @@ commands = <> command "expand" $$ info expandArgSpec $$ progDesc "Like `check' but also pass `-ddump-splices' to GHC" + <> command "imported-from" + $$ info importedFromArgSpec + $$ progDesc "Get the Haddock URL of the expression under (LINE,COL)" <> command "info" $$ info infoArgSpec $$ progDesc' $$$ do @@ -228,7 +232,7 @@ locArgSpec x = x modulesArgSpec, docArgSpec, findArgSpec, lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec, - infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, + importedFromArgSpec, infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, sigArgSpec, refineArgSpec, debugComponentArgSpec, mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands @@ -268,6 +272,7 @@ browseArgSpec = CmdBrowse debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent) checkArgSpec = filesArgsSpec (pure CmdCheck) expandArgSpec = filesArgsSpec (pure CmdExpand) +importedFromArgSpec = locArgSpec (pure CmdImportedFrom) <*> strArg "SYMBOL" infoArgSpec = CmdInfo <$> strArg "FILE" <*> strArg "SYMBOL" diff --git a/test/ImportedFromSpec.hs b/test/ImportedFromSpec.hs new file mode 100644 index 000000000..3c6547f68 --- /dev/null +++ b/test/ImportedFromSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +module ImportedFromSpec where + +import Control.Applicative +import Data.List +import Language.Haskell.GhcMod +import System.FilePath +import Test.Hspec +import TestUtils +import Prelude + +import Language.Haskell.GhcMod.Utils + +--------------------------------------------------- +import Language.Haskell.GhcMod.ImportedFrom +import System.FilePath() +import Test.Hspec + +import Control.Exception as E +import System.Directory +--------------------------------------------------- + +spec :: Spec +spec = do + let tdir = "test/data/imported-from" + + describe "checkImportedFrom" $ do + + -- Previously this test looked up the "Maybe" in a type signature + -- but now it fails - for some reason the expansion of spans + -- was giving the contents of the body of the function. This worked + -- before??? + it "can look up Maybe" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 17 (Expression "Maybe") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Data-Maybe.html") + + it "can look up Just" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 12 7 (Expression "Just") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Data-Maybe.html") + + it "can look up Just" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 16 10 (Expression "Just") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Data-Maybe.html") + + it "can look up String" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 20 14 (Expression "String") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Prelude.html") + + it "can look up Int" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 23 (Expression "Int") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Prelude.html") + + it "can look up DL.length" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 23 5 (Expression "DL.length") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Data-List.html") + + it "can look up print" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 25 8 (Expression "print") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Prelude.html") + + it "can look up DM.fromList" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 27 5 (Expression "DM.fromList") + res `shouldSatisfy` (isInfixOf "containers-") + res `shouldSatisfy` (isInfixOf "Data-Map.html") + + -- This one is failing for some reason - something about not being able to load Safe? Temporarily disabling. + -- + -- Failed to load interface for \8216Safe\8217\nUse -v to see a list of the files searched for.\n + -- + --it "can look up Safe.headMay" $ do + -- withDirectory_ "test/data/imported-from" $ do + -- (res, _) <- runGmOutDef $ runGhcModT defaultOptions $ importedFrom "ImportedFrom01.hs" 29 6 (Expression "Safe.headMay") + -- res `shouldSatisfy` isRight + + it "can look up Foo.Bar.length" $ do + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 34 17 (Expression "Foo.Bar.length") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Data-List.html") + + -- These from Safe also fail. Why? + --it "can look up map" $ do + -- res <- runD' tdir $ importedFrom "ImportedFrom02.hs" 14 5 (Expression "map") + -- res `shouldSatisfy` (isInfixOf "000") + -- res `shouldSatisfy` (isInfixOf "111") + + --it "can look up head" $ do + -- res <- runD' tdir $ importedFrom "ImportedFrom02.hs" 16 5 (Expression "head") + -- res `shouldSatisfy` (isInfixOf "000") + -- res `shouldSatisfy` (isInfixOf "111") + + it "can look up when" $ do + res <- runD' tdir $ importedFrom "ImportedFrom03.hs" 15 5 (Expression "when") + res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (isInfixOf "Control-Monad.html") diff --git a/test/data/imported-from/ImportedFrom01.hs b/test/data/imported-from/ImportedFrom01.hs new file mode 100644 index 000000000..48059a96d --- /dev/null +++ b/test/data/imported-from/ImportedFrom01.hs @@ -0,0 +1,34 @@ +-- ImportedFrom01.hs + +module ImportedFrom01 where + +import Data.Maybe +import qualified Data.List as DL +import qualified Data.Map as DM +-- import qualified Safe +import qualified Data.List as Foo.Bar + +f :: a -> Maybe a +f x = Just x + +g :: IO () +g = do + let (Just _, _) = (Just 3, Just 4) + + return () + +s = "boo" :: String +s' = head s +t = Just 100 :: Maybe Int +r = DL.length [1, 2, 3] + +main = print "Hello, World!" + +h = DM.fromList [("x", "y")] + +-- sh = Safe.headMay [] + +i = 3 :: Int +i' = 3 :: Integer + +len = Foo.Bar.length diff --git a/test/data/imported-from/ImportedFrom02.hs b/test/data/imported-from/ImportedFrom02.hs new file mode 100644 index 000000000..afac299e8 --- /dev/null +++ b/test/data/imported-from/ImportedFrom02.hs @@ -0,0 +1,19 @@ +-- ImportedFrom02.hs + +module ImportedFrom02 where + +import Data.List hiding (map) +import System.Environment (getArgs) +import qualified Safe + + + + + + +m = map (+1) [1, 2, 3] + +h = head [1, 2, 3] + +h' = Safe.headMay [] + diff --git a/test/data/imported-from/ImportedFrom03.hs b/test/data/imported-from/ImportedFrom03.hs new file mode 100644 index 000000000..461f862ba --- /dev/null +++ b/test/data/imported-from/ImportedFrom03.hs @@ -0,0 +1,38 @@ +-- ImportedFrom03.hs + +module ImportedFrom03 where + +import Control.Monad ( forM_, liftM, filterM, when, unless ) +-- import Control.Monad.Identity +-- import Control.Monad.Reader +-- import Control.Monad.Trans.Writer.Lazy + + + + + +main = do + when True $ do print "hah" + + +data Hello = Hello deriving Show + +foo = do + print "hello" + putStrLn "hello" + + where + _ = (+) + _ = (-) + _ = (*) + _ = (/) + _ = True + _ = False + _ = (&&) + _ = (||) + _ = min :: Int -> Int -> Int + _ = max :: Int -> Int -> Int + _ = succ :: Int -> Int + _ = (++) + _ = (>) + _ = (==) From 5d6be7f17333d739d12c675eaf9a8cceff70c070 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 9 Aug 2016 13:10:08 +0300 Subject: [PATCH 02/33] [imported-from] Try fixing 7.10 dependencies --- ghc-mod.cabal | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index fdaacbfd0..1332a421c 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -215,7 +215,9 @@ Library if impl(ghc >= 8.0) Build-Depends: haddock-api < 2.18 - if impl(ghc >= 7.8 && < 8.0) + if impl(ghc >= 7.10 && < 8.0) + Build-Depends: haddock-api < 2.17 + if impl(ghc >= 7.8 && < 7.10) Build-Depends: haddock-api < 2.16 if impl(ghc < 7.8) Build-Depends: haddock < 2.15.0 From 3f27490f218d90523e6e6a1c5bcd0010554d1c8d Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Tue, 9 Aug 2016 19:03:28 +0800 Subject: [PATCH 03/33] Comment out unused test cases. --- test/data/imported-from/ImportedFrom03.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/data/imported-from/ImportedFrom03.hs b/test/data/imported-from/ImportedFrom03.hs index 461f862ba..4fc6a7634 100644 --- a/test/data/imported-from/ImportedFrom03.hs +++ b/test/data/imported-from/ImportedFrom03.hs @@ -21,6 +21,7 @@ foo = do print "hello" putStrLn "hello" +{- where _ = (+) _ = (-) @@ -36,3 +37,4 @@ foo = do _ = (++) _ = (>) _ = (==) +-} From b61d3e8d4973d2f30d9d06ebdc77fd90ef3abbab Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Tue, 9 Aug 2016 19:09:59 +0800 Subject: [PATCH 04/33] Avoid fromMaybe. --- Language/Haskell/GhcMod/ImportedFrom.hs | 72 ++++++++++++------------- 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index abd230ef3..15c1e1a51 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -32,6 +32,7 @@ import GHC import HscTypes import Language.Haskell.GhcMod import Language.Haskell.GhcMod.DynFlags +import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.FileMapping import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.GhcPkg @@ -460,13 +461,15 @@ data ModuleExports = ModuleExports -- User qualified the symbol, so we can filter out anything that doesn't have a matching 'modImportedAs'. refineAs (MySymbolUserQualified userQualSym) exports = filterM f exports where - f export = do - -- e.g. "DL" - case moduleOfQualifiedName userQualSym of - Nothing -> fail "ImportedFrom: expected a qualified name like 'DL.length' but got Nothing." - Just userQualAs -> return $ case modImportedAs $ mInfo export of - Nothing -> False - Just modas' -> modas' == userQualAs + -- f :: ModuleExports -> Bool + f export = case modas of + Nothing -> return False + Just modas' -> do userQualAs <- liftMaybe + (GMEString $ "ImportedFrom: expected a qualified name like 'DL.length' but got: " ++ userQualSym) + (return $ moduleOfQualifiedName userQualSym) + return $ modas' == userQualAs + + where modas = modImportedAs $ mInfo export :: Maybe String -- User didn't qualify the symbol, so we have the full system qualified thing, so do nothing here. refineAs (MySymbolSysQualified _) exports = return exports @@ -546,7 +549,7 @@ refineLeadingDot (MySymbolSysQualified symb) exports = map (\e -> e { qu where thisExports = qualifiedExports export -- Things that this module exports. refineVisibleExports - :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) + :: forall m. (GhcMonad m, MonadError GhcModError m, MonadIO m, GmOut m, GmLog m) => (String -> m (Maybe String)) -> [ModuleExports] -> m [ModuleExports] @@ -557,11 +560,9 @@ refineVisibleExports getHaddockInterfaces exports = mapM f exports let pname = mPackageName mexports -- e.g. "base-4.8.2.0" thisModuleName = mName mexports -- e.g. "Prelude" qexports = qualifiedExports mexports -- e.g. ["base-4.8.2.0:GHC.Base.Just", ...] - mVisibleExportsMap <- getVisibleExports getHaddockInterfaces pname - - visibleExportsMap <- case mVisibleExportsMap of - Nothing -> fail $ "ImportedFrom: visible exports map is Nothing" - Just x -> return x + visibleExportsMap <- liftMaybe + (GMEString "ImportedFrom: visible exports map is Nothing") + (getVisibleExports getHaddockInterfaces pname) gmLog GmDebug "visibleExportsMap" $ strDoc $ show visibleExportsMap @@ -570,14 +571,12 @@ refineVisibleExports getHaddockInterfaces exports = mapM f exports -- On earlier versions of GHC, our qexports list will not be fully qualified, so it will -- look like ["base:GHC.Base.Just", ...] instead of ["base-4.8.2.0:GHC.Base.Just", ...]. -- So if thisModVisibleExports0 is Nothing, fall back to searching on a shorter pname. - let pname' = (head $ splitOn "-" pname) ++ ":" ++ thisModuleName - mThisModVisibleExports = thisModVisibleExports0 - `mplus` - (M.lookup pname' visibleExportsMap) - - thisModVisibleExports <- case mThisModVisibleExports of - Nothing -> throw $ GMENoVisibleExports thisModuleName pname' - Just x -> return x + thisModVisibleExports <- case thisModVisibleExports0 of + Just ve -> return ve + Nothing -> let pname' = ((head $ splitOn "-" pname) ++ ":" ++ thisModuleName) in + liftMaybe + (GMENoVisibleExports thisModuleName pname') + (return $ M.lookup pname' visibleExportsMap) let qexports' = filter (hasPostfixMatch thisModVisibleExports) qexports @@ -598,7 +597,7 @@ getLastMatch exports = Safe.lastMay $ filter f exports -- | Try to look up the Haddock URL for a symbol. guessHaddockUrl :: forall m. - (GhcMonad m, MonadIO m, GmOut m, GmLog m) + (GhcMonad m, MonadError GhcModError m, MonadIO m, GmOut m, GmLog m) => ModSummary -> FilePath -> String @@ -638,7 +637,7 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr let symbolToUse :: String symbolToUse = case qnames of (qq:_) -> qq -- We got a qualified name, with qualified printing. Qualified! - [] -> fail "ImportedFrom: qnames is empty." + [] -> throw $ GMEString "ImportedFrom: qnames is empty." gmLog GmDebug "guessHaddockUrl" $ strDoc $ "symbolToUse: " ++ symbolToUse @@ -735,29 +734,30 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr let lastMatchModule :: String lastMatchModule = case mName <$> lastMatch of Just modn -> modn - _ -> fail $ "ImportedFrom: no nice match in lastMatch for module: " ++ show lastMatch + _ -> throw $ GMEString $ "ImportedFrom: no nice match in lastMatch for module: " ++ show lastMatch lastMatchPackageName :: String lastMatchPackageName = case mPackageName <$> lastMatch of Just p -> p - _ -> fail $ "ImportedFrom: no nice match in lastMatch for package name: " ++ show lastMatch - - mhaddock <- ghcPkgHaddockUrl ghcPkg readProc pkgDbStack lastMatchPackageName + _ -> throw $ GMEString $ "ImportedFrom: no nice match in lastMatch for package name: " ++ show lastMatch gmLog GmDebug "guessHaddockUrl" $ strDoc $ "lastMatchModule: " ++ lastMatchModule gmLog GmDebug "guessHaddockUrl" $ strDoc $ "lastMatchPackageName: " ++ lastMatchPackageName - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "mhaddock: " ++ show mhaddock - case mhaddock of - Nothing -> fail $ "ImportedFrom: ghcPkgHaddockUrl failed to find path to HTML file." - Just haddock -> do let f = haddock (moduleNameToHtmlFile lastMatchModule) + haddock <- liftMaybe + (GMEString $ "ImportedFrom: ghcPkgHaddockUrl failed to find path to HTML file.") + (ghcPkgHaddockUrl ghcPkg readProc pkgDbStack lastMatchPackageName) + + gmLog GmDebug "guessHaddockUrl" $ strDoc $ "haddock: " ++ show haddock + + let f = haddock (moduleNameToHtmlFile lastMatchModule) - let mySymbol' = case mySymbol of - MySymbolSysQualified s -> s - MySymbolUserQualified s -> s + let mySymbol' = case mySymbol of + MySymbolSysQualified s -> s + MySymbolUserQualified s -> s - return $ mySymbol' ++ " " ++ lastMatchModule ++ " file://" ++ f - ++ " " ++ toHackageUrl f lastMatchPackageName lastMatchModule + return $ mySymbol' ++ " " ++ lastMatchModule ++ " file://" ++ f + ++ " " ++ toHackageUrl f lastMatchPackageName lastMatchModule where -- Convert a module name string, e.g. @Data.List@ to @Data-List.html@. From 2bc7947c8464922c76be160bf1ed14dadb9274e6 Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Tue, 9 Aug 2016 20:56:39 +0800 Subject: [PATCH 05/33] Fix a regression on 7.8.4 for the imported-from command. --- Language/Haskell/GhcMod/ImportedFrom.hs | 9 ++++++--- test/ImportedFromSpec.hs | 18 +++++++++--------- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 15c1e1a51..3e0eb807b 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -564,14 +564,17 @@ refineVisibleExports getHaddockInterfaces exports = mapM f exports (GMEString "ImportedFrom: visible exports map is Nothing") (getVisibleExports getHaddockInterfaces pname) - gmLog GmDebug "visibleExportsMap" $ strDoc $ show visibleExportsMap + gmLog GmDebug "refineVisibleExports" $ strDoc $ "visibleExportsMap: " ++ show visibleExportsMap + gmLog GmDebug "refineVisibleExports" $ strDoc $ "pname: " ++ show pname + gmLog GmDebug "refineVisibleExports" $ strDoc $ "thisModuleName: " ++ show thisModuleName - let thisModVisibleExports0 = M.lookup thisModuleName visibleExportsMap + let thisModVisibleExports0 = M.lookup thisModuleName visibleExportsMap + thisModVisibleExports1 = M.lookup (pname ++ ":" ++ thisModuleName) visibleExportsMap -- On earlier versions of GHC, our qexports list will not be fully qualified, so it will -- look like ["base:GHC.Base.Just", ...] instead of ["base-4.8.2.0:GHC.Base.Just", ...]. -- So if thisModVisibleExports0 is Nothing, fall back to searching on a shorter pname. - thisModVisibleExports <- case thisModVisibleExports0 of + thisModVisibleExports <- case thisModVisibleExports0 `mplus` thisModVisibleExports1 of Just ve -> return ve Nothing -> let pname' = ((head $ splitOn "-" pname) ++ ":" ++ thisModuleName) in liftMaybe diff --git a/test/ImportedFromSpec.hs b/test/ImportedFromSpec.hs index 3c6547f68..b127a2b34 100644 --- a/test/ImportedFromSpec.hs +++ b/test/ImportedFromSpec.hs @@ -32,37 +32,37 @@ spec = do -- before??? it "can look up Maybe" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 17 (Expression "Maybe") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-Maybe.html") it "can look up Just" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 12 7 (Expression "Just") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-Maybe.html") it "can look up Just" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 16 10 (Expression "Just") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-Maybe.html") it "can look up String" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 20 14 (Expression "String") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Prelude.html") it "can look up Int" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 23 (Expression "Int") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Prelude.html") it "can look up DL.length" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 23 5 (Expression "DL.length") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-List.html") it "can look up print" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 25 8 (Expression "print") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Prelude.html") it "can look up DM.fromList" $ do @@ -81,7 +81,7 @@ spec = do it "can look up Foo.Bar.length" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 34 17 (Expression "Foo.Bar.length") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-List.html") -- These from Safe also fail. Why? @@ -97,5 +97,5 @@ spec = do it "can look up when" $ do res <- runD' tdir $ importedFrom "ImportedFrom03.hs" 15 5 (Expression "when") - res `shouldSatisfy` (isInfixOf "base-") + res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Control-Monad.html") From 0e30488b7267533c76dc04a089edcffceb888abc Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Fri, 12 Aug 2016 07:01:33 +0800 Subject: [PATCH 06/33] Use lastNote instead of last, etc. --- Language/Haskell/GhcMod/ImportedFrom.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 3e0eb807b..93a8fa949 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -209,7 +209,9 @@ toImportDecl dflags idecl = NiceImportDecl postfixMatch :: String -> QualifiedName -> Bool postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName - where endTerm = last $ splitOn "." originalSymbol + where endTerm = Safe.lastNote + ("postfixMatch: got: " ++ originalSymbol) + (splitOn "." originalSymbol) -- | Get the module part of a qualified name. -- @@ -542,7 +544,7 @@ refineLeadingDot (MySymbolSysQualified symb) exports = map (\e -> e { qu -- the 'last' will be ok. Sample value of 'symb' in this case is -- "base-4.8.2.0:Data.Foldable.length". leadingDot :: String - leadingDot = '.' : last (splitOn "." symb) + leadingDot = '.' : Safe.lastNote ("leadingDot: got: " ++ symb) (splitOn "." symb) -- f symbol export = filter (symbol ==) thisExports f symbol export = filter (symbol `isSuffixOf`) thisExports @@ -576,7 +578,7 @@ refineVisibleExports getHaddockInterfaces exports = mapM f exports -- So if thisModVisibleExports0 is Nothing, fall back to searching on a shorter pname. thisModVisibleExports <- case thisModVisibleExports0 `mplus` thisModVisibleExports1 of Just ve -> return ve - Nothing -> let pname' = ((head $ splitOn "-" pname) ++ ":" ++ thisModuleName) in + Nothing -> let pname' = ((Safe.headNote ("pname: " ++ pname) $ splitOn "-" pname) ++ ":" ++ thisModuleName) in liftMaybe (GMENoVisibleExports thisModuleName pname') (return $ M.lookup pname' visibleExportsMap) @@ -589,7 +591,7 @@ refineVisibleExports getHaddockInterfaces exports = mapM f exports -- hasPostfixMatch "base-4.8.2.0:GHC.Base.Just" ["Just", "True", ...] -> True hasPostfixMatch :: [String] -> String -> Bool - hasPostfixMatch xs s = last (splitOn "." s) `elem` xs + hasPostfixMatch xs s = Safe.lastNote ("hasPostfixMatch: got: " ++ s) (splitOn "." s) `elem` xs -- | The last thing with a single export must be the match? Iffy. getLastMatch :: [ModuleExports] -> Maybe ModuleExports @@ -774,7 +776,7 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr toHackageUrl :: FilePath -> String -> String -> String toHackageUrl filepath package modulename = "https://hackage.haskell.org/package/" ++ package ++ "/" ++ "docs/" ++ modulename'' where filepath' = map repl filepath - modulename' = head $ splitOn "." $ head $ splitOn "-" modulename + modulename' = Safe.headNote "modulename1" $ splitOn "." $ Safe.headNote "modulename2" $ splitOn "-" modulename modulename'' = drop (fromJust $ substringP modulename' filepath') filepath' -- On Windows we get backslashes in the file path; convert @@ -786,7 +788,9 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr -- Adapted from http://www.haskell.org/pipermail/haskell-cafe/2010-June/078702.html substringP :: String -> String -> Maybe Int substringP _ [] = Nothing - substringP sub str = if sub `isPrefixOf` str then Just 0 else fmap (+1) $ substringP sub (tail str) + substringP sub str = if sub `isPrefixOf` str + then Just 0 + else fmap (+1) $ substringP sub (Safe.tailNote ("substringP: " ++ str) str) filterMatchingQualifiedImport :: String -> [NiceImportDecl] -> [NiceImportDecl] filterMatchingQualifiedImport symbol hmodules From 9d281e46cf9cef0965d63d4413abfff8e3807faf Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Sat, 13 Aug 2016 19:48:13 +0800 Subject: [PATCH 07/33] Remove my clunky "find-module" code and some tidyup. --- Language/Haskell/GhcMod/ImportedFrom.hs | 113 +++++++----------------- Language/Haskell/GhcMod/PkgDoc.hs | 19 +++- 2 files changed, 51 insertions(+), 81 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 93a8fa949..2a86f8fde 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -39,6 +39,7 @@ import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Output +import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.SrcUtils (listifySpans) import Outputable import System.Directory @@ -238,11 +239,20 @@ qualifiedName targetModuleName lineNr colNr symbol importList = do dflags <- GHC.getSessionDynFlags setContext (map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)) - `gcatch` (\(s :: SourceError) -> do gmLog GmDebug "qualifiedName" $ strDoc $ "setContext failed with a SourceError, trying to continue anyway..." ++ show s + `gcatch` (\(s :: SourceError) -> do gmLog GmDebug "qualifiedName" + $ strDoc + $ "setContext failed with a SourceError, trying to continue anyway..." + ++ show s setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) - `gcatch` (\(g :: GhcApiError) -> do gmLog GmDebug "qualifiedName" $ strDoc $ "setContext failed with a GhcApiError, trying to continue anyway..." ++ show g + `gcatch` (\(g :: GhcApiError) -> do gmLog GmDebug "qualifiedName" + $ strDoc + $ "setContext failed with a GhcApiError, trying to continue anyway..." + ++ show g setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) - `gcatch` (\(se :: SomeException) -> do gmLog GmDebug "qualifiedName" $ strDoc $ "setContext failed with a SomeException, trying to continue anyway..." ++ show se + `gcatch` (\(se :: SomeException) -> do gmLog GmDebug "qualifiedName" + $ strDoc + $ "setContext failed with a SomeException, trying to continue anyway..." + ++ show se setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) modSummary <- getModSummary $ mkModuleName targetModuleName :: m ModSummary @@ -271,63 +281,6 @@ qualifiedName targetModuleName lineNr colNr symbol importList = do dropParens :: String -> String dropParens = dropWhileEnd (== ')') . dropWhile (== '(') -ghcPkgFindModule - :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) - => String - -> m (Maybe String) -ghcPkgFindModule mod = do - rp <- gmReadProcess - - (runMaybeT . msum . map MaybeT) - [ stackGhcPkgFindModule rp mod - , hcPkgFindModule rp mod - , ghcPkgFindModule' rp mod - ] - where - - runCmd rp cmd opts = liftIO ((Just <$> (rp cmd opts "")) `catch` (\(_::IOError) -> return Nothing)) - - -- | Call @ghc-pkg find-module@ to determine that package that provides a module, e.g. @Prelude@ is defined - -- in @base-4.6.0.1@. - -- ghcPkgFindModule' :: String -> IO (Maybe String) - ghcPkgFindModule' rp m = do - let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] - gmLog GmDebug "ghcPkgFindModule'" $ strDoc $ "ghc-pkg " ++ show opts - - x <- runCmd rp "ghc-pkg" opts - - -- gmLog GmDebug "" $ strDoc $ "ghcPkgFindModule' stdout: " ++ show output - -- gmLog GmDebug "" $ strDoc $ "ghcPkgFindModule' stderr: " ++ show err - return $ case x of - Just x' -> join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) x' - Nothing -> Nothing - - -- | Call @cabal sandbox hc-pkg@ to find the package the provides a module. - -- hcPkgFindModule :: String -> IO (Maybe String) - hcPkgFindModule rp m = do - let opts = ["sandbox", "hc-pkg", "find-module", m, "--", "--simple-output"] - - x <- runCmd rp "cabal" opts - - -- gmLog GmDebug "" $ strDoc $ "hcPkgFindModule stdout: " ++ show output - -- gmLog GmDebug "" $ strDoc $ "hcPkgFindModule stderr: " ++ show err - return $ case x of - Just x' -> join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) x' - Nothing -> Nothing - - -- | Call @stack exec ghc-pkg@ to find the package the provides a module. - -- stackGhcPkgFindModule :: String -> IO (Maybe String) - stackGhcPkgFindModule rp m = do - let opts = ["exec", "ghc-pkg", "find-module", m, "--", "--simple-output"] - - x <- runCmd rp "stack" opts - - -- gmLog GmDebug "" $ strDoc $ "stackGhcPkgFindModule stdout: " ++ show output - -- gmLog GmDebug "" $ strDoc $ "stackGhcPkgFindModule stderr: " ++ show err - return $ case x of - Just x' -> join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) x' - Nothing -> Nothing - splitPackageName :: String -> String splitPackageName p = case splitOn "@" p of @@ -378,11 +331,7 @@ getVisibleExports getHaddockInterfaces p = do haddockInterfaceFile <- getHaddockInterfaces p' - case haddockInterfaceFile of - Just hi -> getVisibleExports' hi - Nothing -> return Nothing - - -- FIXME getVisibleExports' <$> (getHaddockInterfaces p') + getVisibleExports' <$> getHaddockInterfaces p' where @@ -420,24 +369,27 @@ getVisibleExports getHaddockInterfaces p = do liftIO $ writeIORef ref nc' getModuleExports - :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) + :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m, IOish m) => FilePath -> (FilePath -> [String] -> String -> IO String) + -> [GhcPkgDb] -> NiceImportDecl -> m (Maybe ([String], String)) -getModuleExports ghcPkg readProc m = do +getModuleExports ghcPkg readProc pkgDbStack m = do minfo <- (findModule (mkModuleName $ modName m) Nothing >>= getModuleInfo) - `gcatch` (\(e :: SourceError) -> do gmLog GmDebug "getModuleExports" $ strDoc $ "Failed to find module \"" ++ modName m ++ "\": " ++ show e + `gcatch` (\(e :: SourceError) -> do gmLog GmDebug "getModuleExports" $ strDoc + $ "Failed to find module \"" ++ modName m + ++ "\": " ++ show e return Nothing) - p <- ghcPkgFindModule $ modName m + p <- pkgFindModule ghcPkg readProc pkgDbStack (modName m) dflags <- GHC.getSessionDynFlags case (minfo, p) of - (Nothing, _) -> return Nothing - (_, Nothing) -> return Nothing - (Just minfo', Just p') -> return $ Just (map (showSDocForUser dflags ghcQualify . ppr) $ modInfoExports minfo', p') + (Nothing, _) -> return Nothing + (_, "") -> return Nothing + (Just minfo', _) -> return $ Just (map (showSDocForUser dflags ghcQualify . ppr) $ modInfoExports minfo', p) type FullyQualifiedName = String -- ^ e.g. e.g. "base-4.8.2.0:Data.Foldable.length" type StrModuleName = String -- ^ e.g. "Data.List" @@ -491,7 +443,10 @@ refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports -- = case filter (postfixMatch name) qualifiedNames of = case nub' (filter (name `f`) qualifiedNames) of [match] -> match - m -> throw $ GMEString $ "ImportedFrom: could not qualify " ++ name ++ " from these exports: " ++ show qualifiedNames ++ "\n matches: " ++ show m + m -> fail $ "ImportedFrom: could not qualify " + ++ name ++ " from these exports: " + ++ show qualifiedNames ++ "\n matches: " + ++ show m -- Time for some stringly typed rubbish. The previous test used -- postfixMatch but this failed on an import that had "hiding (lines, unlines)" since @@ -500,7 +455,7 @@ refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports -- and then an alpha character, which hopefully is the end of a module name. Such a mess. where f n qn = if length qn - length n - 2 >= 0 then n `isSuffixOf` qn && isAlpha (qn !! (length qn - length n - 2)) && (qn !! (length qn - length n - 1)) == '.' - else throw $ GMEString $ "ImportedFrom internal error: trying to check if \"" ++ n ++ "\" is a match for \"" ++ qn ++ "\"" + else fail $ "ImportedFrom internal error: trying to check if \"" ++ n ++ "\" is a match for \"" ++ qn ++ "\"" refineExportsIt :: MySymbol -> [ModuleExports] -> [ModuleExports] refineExportsIt mysymbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports @@ -602,7 +557,7 @@ getLastMatch exports = Safe.lastMay $ filter f exports -- | Try to look up the Haddock URL for a symbol. guessHaddockUrl :: forall m. - (GhcMonad m, MonadError GhcModError m, MonadIO m, GmOut m, GmLog m) + (GhcMonad m, MonadError GhcModError m, MonadIO m, GmOut m, GmLog m, IOish m) => ModSummary -> FilePath -> String @@ -642,7 +597,7 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr let symbolToUse :: String symbolToUse = case qnames of (qq:_) -> qq -- We got a qualified name, with qualified printing. Qualified! - [] -> throw $ GMEString "ImportedFrom: qnames is empty." + [] -> fail $ "ImportedFrom: qnames is empty." gmLog GmDebug "guessHaddockUrl" $ strDoc $ "symbolToUse: " ++ symbolToUse @@ -672,7 +627,7 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr gmLog GmDebug "guessHaddockUrl" $ strDoc $ "parsedPackagesAndQualNames: " ++ show parsedPackagesAndQualNames gmLog GmDebug "guessHaddockUrl" $ strDoc $ "extraImportDecls: " ++ show extraImportDecls - exports0 <- mapM (getModuleExports ghcPkg readProc) importDecls3 :: m [Maybe ([String], String)] + exports0 <- mapM (getModuleExports ghcPkg readProc pkgDbStack) importDecls3 :: m [Maybe ([String], String)] -- Sometimes the modules in extraImportDecls might be hidden or weird ones like GHC.Base that we can't -- load, so filter out the successfully loaded ones. @@ -739,12 +694,12 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr let lastMatchModule :: String lastMatchModule = case mName <$> lastMatch of Just modn -> modn - _ -> throw $ GMEString $ "ImportedFrom: no nice match in lastMatch for module: " ++ show lastMatch + _ -> fail $ "ImportedFrom: no nice match in lastMatch for module: " ++ show lastMatch lastMatchPackageName :: String lastMatchPackageName = case mPackageName <$> lastMatch of Just p -> p - _ -> throw $ GMEString $ "ImportedFrom: no nice match in lastMatch for package name: " ++ show lastMatch + _ -> fail $ "ImportedFrom: no nice match in lastMatch for package name: " ++ show lastMatch gmLog GmDebug "guessHaddockUrl" $ strDoc $ "lastMatchModule: " ++ lastMatchModule gmLog GmDebug "guessHaddockUrl" $ strDoc $ "lastMatchPackageName: " ++ lastMatchPackageName diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index 6ec5d0d00..fbc94a093 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -1,4 +1,4 @@ -module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where +module Language.Haskell.GhcMod.PkgDoc (pkgDoc, pkgFindModule) where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg @@ -14,7 +14,8 @@ pkgDoc mdl = do ghcPkg <- getGhcPkgProgram readProc <- gmReadProcess pkgDbStack <- getPackageDbStack - pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) "" + pkg <- pkgFindModule ghcPkg readProc pkgDbStack mdl + if pkg == "" then return "\n" else do @@ -27,3 +28,17 @@ pkgDoc mdl = do toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"] ++ ghcPkgDbStackOpts dbs trim = takeWhile (`notElem` " \n") + +pkgFindModule + :: IOish m + => FilePath + -> (FilePath -> [String] -> String -> IO String) + -> [GhcPkgDb] + -> String + -> m String +pkgFindModule ghcPkg readProc pkgDbStack mdl = + liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) "" + where + toModuleOpts dbs = ["find-module", mdl, "--simple-output"] + ++ ghcPkgDbStackOpts dbs + trim = takeWhile (`notElem` " \n") From e73eea5aa9561345e72a03104e151c17015738c7 Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Sat, 13 Aug 2016 20:52:59 +0800 Subject: [PATCH 08/33] Fix two compile errors. --- Language/Haskell/GhcMod/ImportedFrom.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 2a86f8fde..b1166fc2a 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -330,8 +330,9 @@ getVisibleExports getHaddockInterfaces p = do let p' = splitPackageName p haddockInterfaceFile <- getHaddockInterfaces p' - - getVisibleExports' <$> getHaddockInterfaces p' + case haddockInterfaceFile of + Just hi -> getVisibleExports' hi + Nothing -> return Nothing where @@ -352,8 +353,6 @@ getVisibleExports getHaddockInterfaces p = do names = map (showSDoc dflags . ppr) $ Haddock.instVisibleExports ii ] - - ------------------------------------------------------------------------------------------------------------------------ -- Copied from http://hackage.haskell.org/package/haddock-api-2.16.1/docs/src/Haddock-InterfaceFile.html#nameCacheFromGhc -- but for a general monad m instead of the specific monad Ghc. @@ -455,7 +454,7 @@ refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports -- and then an alpha character, which hopefully is the end of a module name. Such a mess. where f n qn = if length qn - length n - 2 >= 0 then n `isSuffixOf` qn && isAlpha (qn !! (length qn - length n - 2)) && (qn !! (length qn - length n - 1)) == '.' - else fail $ "ImportedFrom internal error: trying to check if \"" ++ n ++ "\" is a match for \"" ++ qn ++ "\"" + else throw $ GMEString $ "ImportedFrom internal error: trying to check if \"" ++ n ++ "\" is a match for \"" ++ qn ++ "\"" refineExportsIt :: MySymbol -> [ModuleExports] -> [ModuleExports] refineExportsIt mysymbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports From d26da6e477f77a665d7c28ac0d8e080debbe987a Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Sun, 14 Aug 2016 08:22:06 +0800 Subject: [PATCH 09/33] Tidyup type signatures. --- Language/Haskell/GhcMod/ImportedFrom.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index b1166fc2a..26bc16ea6 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -368,7 +368,7 @@ getVisibleExports getHaddockInterfaces p = do liftIO $ writeIORef ref nc' getModuleExports - :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m, IOish m) + :: forall m. (GhcMonad m, GmOut m, GmLog m, IOish m) => FilePath -> (FilePath -> [String] -> String -> IO String) -> [GhcPkgDb] @@ -409,7 +409,7 @@ data ModuleExports = ModuleExports } deriving Show --- refineAs :: MySymbol -> [ModuleExports] -> [ModuleExports] +refineAs :: forall m. MonadError GhcModError m => MySymbol -> [ModuleExports] -> m [ModuleExports] -- User qualified the symbol, so we can filter out anything that doesn't have a matching 'modImportedAs'. refineAs (MySymbolUserQualified userQualSym) exports = filterM f exports @@ -556,7 +556,7 @@ getLastMatch exports = Safe.lastMay $ filter f exports -- | Try to look up the Haddock URL for a symbol. guessHaddockUrl :: forall m. - (GhcMonad m, MonadError GhcModError m, MonadIO m, GmOut m, GmLog m, IOish m) + (GhcMonad m, MonadError GhcModError m, GmOut m, GmLog m, IOish m) => ModSummary -> FilePath -> String From 8c4ee88278005361dc20601ce710b182dccbc429 Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Mon, 15 Aug 2016 08:26:04 +0800 Subject: [PATCH 10/33] Remove unused local definitions. --- Language/Haskell/GhcMod/PkgDoc.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index fbc94a093..82d1ab484 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -23,11 +23,8 @@ pkgDoc mdl = do let ret = pkg ++ " " ++ drop 14 htmlpath return ret where - toModuleOpts dbs = ["find-module", mdl, "--simple-output"] - ++ ghcPkgDbStackOpts dbs toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"] ++ ghcPkgDbStackOpts dbs - trim = takeWhile (`notElem` " \n") pkgFindModule :: IOish m From 60dfa8a7ba6b944ff9cf11dd715bf171bcab8f1f Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Mon, 15 Aug 2016 08:26:42 +0800 Subject: [PATCH 11/33] Nicer parser for postfix matching. --- Language/Haskell/GhcMod/ImportedFrom.hs | 46 ++++++++++++++++++------- 1 file changed, 34 insertions(+), 12 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 26bc16ea6..d6bb595f6 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -21,7 +21,7 @@ import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.Trans.Maybe -import Data.Char (isAlpha) +import Data.Char (isAlpha, isDigit) import Data.IORef import Data.List import Data.List.Split @@ -44,6 +44,7 @@ import Language.Haskell.GhcMod.SrcUtils (listifySpans) import Outputable import System.Directory import System.FilePath +import Text.ParserCombinators.ReadP ((+++)) import qualified Data.Map as M import qualified Data.Set as Set @@ -207,7 +208,6 @@ toImportDecl dflags idecl = NiceImportDecl -- False -- >>> postfixMatch "bar" "bar" -- True - postfixMatch :: String -> QualifiedName -> Bool postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName where endTerm = Safe.lastNote @@ -439,22 +439,44 @@ refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports qualifyName :: [QualifiedName] -> String -> QualifiedName qualifyName qualifiedNames name - -- = case filter (postfixMatch name) qualifiedNames of - = case nub' (filter (name `f`) qualifiedNames) of + = case nub' (filter (postfixMatch' name) qualifiedNames) of [match] -> match m -> fail $ "ImportedFrom: could not qualify " ++ name ++ " from these exports: " ++ show qualifiedNames ++ "\n matches: " ++ show m - -- Time for some stringly typed rubbish. The previous test used - -- postfixMatch but this failed on an import that had "hiding (lines, unlines)" since - -- both lines and unlines matched. Prepending a dot doesn't work due to things like ".=" from - -- Control.Lens. So we manually check that the suffix matches, that the next symbol is a dot, - -- and then an alpha character, which hopefully is the end of a module name. Such a mess. - where f n qn = if length qn - length n - 2 >= 0 - then n `isSuffixOf` qn && isAlpha (qn !! (length qn - length n - 2)) && (qn !! (length qn - length n - 1)) == '.' - else throw $ GMEString $ "ImportedFrom internal error: trying to check if \"" ++ n ++ "\" is a match for \"" ++ qn ++ "\"" + postfixMatch' n qn + | n == qn = True + | otherwise = case runRP (f $ reverse n) (reverse qn) of + Left _ -> False + Right () -> True + where + f n = do + _ <- RP.string n + _ <- RP.char '.' + _ <- RP.manyTill nameThenDot (nameThenEnd +++ nameThenEnd') + return () + + -- Valid chars in a haskell module name: + -- https://www.haskell.org/onlinereport/syntax-iso.html + modChar c = isAlpha c || isDigit c || (c == '\'') + + nameThenEnd = do + RP.many1 $ RP.satisfy modChar + RP.eof + + nameThenEnd' = do + RP.many1 $ RP.satisfy modChar + RP.char ':' + RP.manyTill RP.get RP.eof + RP.eof + + nameThenDot = do + RP.many1 $ RP.satisfy modChar + RP.char '.' + return () + refineExportsIt :: MySymbol -> [ModuleExports] -> [ModuleExports] refineExportsIt mysymbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports From 90667e639a57e9bc4bfc688af83d7efeeea9bff2 Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Mon, 15 Aug 2016 09:07:09 +0800 Subject: [PATCH 12/33] Show local URL if available; otherwise hackage.haskell.org. --- Language/Haskell/GhcMod/ImportedFrom.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index d6bb595f6..e51770236 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -731,14 +731,17 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr gmLog GmDebug "guessHaddockUrl" $ strDoc $ "haddock: " ++ show haddock - let f = haddock (moduleNameToHtmlFile lastMatchModule) - let mySymbol' = case mySymbol of MySymbolSysQualified s -> s MySymbolUserQualified s -> s - return $ mySymbol' ++ " " ++ lastMatchModule ++ " file://" ++ f - ++ " " ++ toHackageUrl f lastMatchPackageName lastMatchModule + let f = haddock (moduleNameToHtmlFile lastMatchModule) + + e <- liftIO $ doesFileExist f + + return $ + if e then mySymbol' ++ " " ++ lastMatchModule ++ " file://" ++ f + else mySymbol' ++ " " ++ lastMatchModule ++ " " ++ toHackageUrl f lastMatchPackageName lastMatchModule where -- Convert a module name string, e.g. @Data.List@ to @Data-List.html@. @@ -805,4 +808,5 @@ importedFrom file lineNr colNr (Expression symbol) = do modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) let modstr = moduleNameString $ ms_mod_name modSum :: String - guessHaddockUrl modSum file modstr symbol lineNr colNr ghcPkg readProc pkgDbStack + x <- guessHaddockUrl modSum file modstr symbol lineNr colNr ghcPkg readProc pkgDbStack + return $ x ++ "\n" From 8d0de1021634fe8afb3eb304a83239de78cfccbb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 27 Aug 2016 19:53:49 +0200 Subject: [PATCH 13/33] imported-from: first cleanup pass --- Language/Haskell/GhcMod/ImportedFrom.hs | 320 +++++++++++++----------- ghc-mod.cabal | 1 + 2 files changed, 170 insertions(+), 151 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index e51770236..97434b7c3 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -41,10 +41,11 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.SrcUtils (listifySpans) -import Outputable +import Outputable (showSDoc, showSDocForUser, ppr) import System.Directory import System.FilePath import Text.ParserCombinators.ReadP ((+++)) +import Text.Show.Pretty import qualified Data.Map as M import qualified Data.Set as Set @@ -76,18 +77,13 @@ data NiceImportDecl -- trace'' m x = trace (m ++ ">>> " ++ showSDoc tdflags (ppr x)) parsePackageAndQualName :: RP.ReadP (String, String) -parsePackageAndQualName = RP.choice [parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash] - +parsePackageAndQualName = + RP.choice [parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash] where - -- Package with no hash (seems to be for internal packages?) -- base-4.8.2.0:Data.Foldable.length - parsePackageAndQualNameNoHash = do - packageName <- parsePackageName - qName <- parsePackageFinalQualName - - return (packageName, qName) - + parsePackageAndQualNameNoHash = + (,) <$> parsePackageName <*> parsePackageFinalQualName parsePackageName = RP.get `RP.manyTill` RP.char ':' parsePackageFinalQualName = RP.many1 RP.get @@ -95,24 +91,20 @@ parsePackageAndQualName = RP.choice [parsePackageAndQualNameWithHash, parsePacka -- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList" parsePackageAndQualNameWithHash :: RP.ReadP (String, String) parsePackageAndQualNameWithHash = do - packageName <- parsePackageName - _ <- parsePackageHash - qName <- parsePackageFinalQualName - - return (packageName, qName) - + (,) <$> parsePackageName <* parsePackageHash <*> parsePackageFinalQualName where - parsePackageName = RP.get `RP.manyTill` RP.char '@' parsePackageHash = RP.get `RP.manyTill` RP.char ':' parsePackageFinalQualName = RP.many1 RP.get runRP :: Show t => RP.ReadP t -> String -> Either String t -runRP rp s = case RP.readP_to_S rp s of - [(m, "")] -> Right m - err -> Left $ "runRP: no unique match: " ++ show err +runRP rp s = + case RP.readP_to_S rp s of + [(m, "")] -> Right m + err -> Left $ "runRP: no unique match: " ++ show err --- | Convenience function for converting an 'GHC.ImportDecl' to a 'NiceImportDecl'. +-- | Convenience function for converting an 'GHC.ImportDecl' to a +-- 'NiceImportDecl'. -- -- Example: -- @@ -154,15 +146,18 @@ runRP rp s = case RP.readP_to_S rp s of -- , modSpecifically = [] -- } -- ] -toImportDecl :: GHC.DynFlags -> SrcLoc.Located (GHC.ImportDecl GHC.RdrName) -> NiceImportDecl -toImportDecl dflags idecl = NiceImportDecl - { modName = name - , modQualifier = qualifier - , modIsImplicit = isImplicit - , modHiding = hiding - , modImportedAs = importedAs - , modSpecifically = specifically - } +toImportDecl :: GHC.DynFlags + -> SrcLoc.Located (GHC.ImportDecl GHC.RdrName) + -> NiceImportDecl +toImportDecl dflags idecl = + NiceImportDecl + { modName = name + , modQualifier = qualifier + , modIsImplicit = isImplicit + , modHiding = hiding + , modImportedAs = importedAs + , modSpecifically = specifically + } where idecl' = SrcLoc.unLoc idecl name = showSDoc dflags (ppr $ GHC.ideclName idecl') @@ -210,9 +205,9 @@ toImportDecl dflags idecl = NiceImportDecl -- True postfixMatch :: String -> QualifiedName -> Bool postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName - where endTerm = Safe.lastNote - ("postfixMatch: got: " ++ originalSymbol) - (splitOn "." originalSymbol) + where + endTerm = Safe.lastNote ("postfixMatch: got: " ++ originalSymbol) $ + splitOn "." originalSymbol -- | Get the module part of a qualified name. -- @@ -223,43 +218,44 @@ postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName -- >>> moduleOfQualifiedName "Foo" -- Nothing moduleOfQualifiedName :: QualifiedName -> Maybe String -moduleOfQualifiedName qn = if null bits - then Nothing - else Just $ intercalate "." bits - where bits = reverse $ drop 1 $ reverse $ splitOn "." qn +moduleOfQualifiedName qn = + if null bits + then Nothing + else Just $ intercalate "." bits + where + bits = reverse $ drop 1 $ reverse $ splitOn "." qn +{-# WARNING moduleOfQualifiedName "TODO: unsafe 'drop 1'" #-} + --- | Find the possible qualified names for the symbol at line/col in the given Haskell file and module. --- Returns a fully qualified name thatincludes the package, hash, and name, e.g. +-- | Find the possible qualified names for the symbol at line/col in the given +-- Haskell file and module. Returns a fully qualified name thatincludes the +-- package, hash, and name, e.g. -- -- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList". -qualifiedName +qualifiedNameAt :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) => String -> Int -> Int -> String -> [String] -> m [String] -qualifiedName targetModuleName lineNr colNr symbol importList = do +qualifiedNameAt targetModuleName lineNr colNr symbol importList = do dflags <- GHC.getSessionDynFlags - setContext (map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)) - `gcatch` (\(s :: SourceError) -> do gmLog GmDebug "qualifiedName" - $ strDoc - $ "setContext failed with a SourceError, trying to continue anyway..." - ++ show s - setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) - `gcatch` (\(g :: GhcApiError) -> do gmLog GmDebug "qualifiedName" - $ strDoc - $ "setContext failed with a GhcApiError, trying to continue anyway..." - ++ show g - setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) - `gcatch` (\(se :: SomeException) -> do gmLog GmDebug "qualifiedName" - $ strDoc - $ "setContext failed with a SomeException, trying to continue anyway..." - ++ show se - setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) + let imports_with_target_module = targetModuleName : importList + imports_fallback = importList + ctx imports = map (IIDecl . simpleImportDecl . mkModuleName) imports + + handler :: SomeException -> m () + handler err = do + gmLog GmException "qualifiedNameAt" $ + text "setContext failed, trying to continue anyway." $+$ + text (show err) + setContext $ ctx imports_fallback + + setContext (ctx imports_with_target_module) `gcatch` handler modSummary <- getModSummary $ mkModuleName targetModuleName :: m ModSummary p <- parseModule modSummary :: m ParsedModule t <- typecheckModule p :: m TypecheckedModule - let TypecheckedModule{tm_typechecked_source = tcs} = t + let TypecheckedModule { tm_typechecked_source = tcs } = t bs = listifySpans tcs (lineNr, colNr) :: [LHsBind Id] es = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id] ps = listifySpans tcs (lineNr, colNr) :: [LPat Id] @@ -268,11 +264,11 @@ qualifiedName targetModuleName lineNr colNr symbol importList = do es' = map (showSDocForUser dflags ghcQualify . ppr) es ps' = map (showSDocForUser dflags ghcQualify . ppr) ps - gmLog GmDebug "qualifiedName" $ strDoc $ "symbol: " ++ symbol - gmLog GmDebug "qualifiedName" $ strDoc $ "line, col: " ++ show (lineNr, colNr) + gmLog GmDebug "qualifiedNameAt" $ strDoc $ "symbol: " ++ symbol + gmLog GmDebug "qualifiedNameAt" $ strDoc $ "line, col: " ++ show (lineNr, colNr) let stuff = map dropParens $ concatMap words $ bs' ++ es' ++ ps' - gmLog GmDebug "qualifiedName" $ strDoc $ "stuff: " ++ show stuff + gmLog GmDebug "qualifiedNameAt" $ strDoc $ "stuff: " ++ show stuff return $ filter (postfixMatch symbol) stuff @@ -335,10 +331,7 @@ getVisibleExports getHaddockInterfaces p = do Nothing -> return Nothing where - - getVisibleExports' :: forall m. (GhcMonad m, MonadIO m) - => FilePath - -> m (Maybe (M.Map String [String])) + getVisibleExports' :: FilePath -> m (Maybe (M.Map String [String])) getVisibleExports' ifile = do iface <- Haddock.readInterfaceFile nameCacheFromGhc ifile @@ -357,7 +350,7 @@ getVisibleExports getHaddockInterfaces p = do -- Copied from http://hackage.haskell.org/package/haddock-api-2.16.1/docs/src/Haddock-InterfaceFile.html#nameCacheFromGhc -- but for a general monad m instead of the specific monad Ghc. ------------------------------------------------------------------------------------------------------------------------ - nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => Haddock.NameCacheAccessor m + nameCacheFromGhc :: Haddock.NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do @@ -375,65 +368,82 @@ getModuleExports -> NiceImportDecl -> m (Maybe ([String], String)) getModuleExports ghcPkg readProc pkgDbStack m = do - minfo <- (findModule (mkModuleName $ modName m) Nothing >>= getModuleInfo) - `gcatch` (\(e :: SourceError) -> do gmLog GmDebug "getModuleExports" $ strDoc - $ "Failed to find module \"" ++ modName m - ++ "\": " ++ show e - return Nothing) + let + handler :: SomeException -> m (Maybe a) + handler e = do + let modDoc = doubleQuotes $ text $ modName m + gmLog GmDebug "getModuleExports" $ + (text "Failed to find module" <> modDoc) <+>: + text (show e) + return Nothing + + minfo <- (findModule (mkModuleName $ modName m) Nothing >>= getModuleInfo) + `gcatch` handler p <- pkgFindModule ghcPkg readProc pkgDbStack (modName m) dflags <- GHC.getSessionDynFlags - case (minfo, p) of - (Nothing, _) -> return Nothing - (_, "") -> return Nothing - (Just minfo', _) -> return $ Just (map (showSDocForUser dflags ghcQualify . ppr) $ modInfoExports minfo', p) + return $ case (minfo, p) of + (Nothing, _) -> Nothing + (_, "") -> Nothing + (Just minfo', _) -> Just (map (showSDocForUser dflags ghcQualify . ppr) $ modInfoExports minfo', p) + +-- * e.g. e.g. "base-4.8.2.0:Data.Foldable.length" +type FullyQualifiedName = String + +-- * e.g. "Data.List" +type StrModuleName = String -type FullyQualifiedName = String -- ^ e.g. e.g. "base-4.8.2.0:Data.Foldable.length" -type StrModuleName = String -- ^ e.g. "Data.List" -data MySymbol = MySymbolSysQualified String -- ^ e.g. "base-4.8.2.0:Data.Foldable.length" - | MySymbolUserQualified String -- ^ e.g. "DL.length" with an import earlier like "import qualified Data.List as DL" +data MySymbol = MySymbolSysQualified String + -- ^ e.g. "base-4.8.2.0:Data.Foldable.length" + | MySymbolUserQualified String + -- ^ e.g. "DL.length" with an import earlier like "import + -- qualified Data.List as DL" deriving Show data ModuleExports = ModuleExports - { mName :: StrModuleName -- ^ e.g. "Data.List" - , mPackageName :: String -- ^ e.g. "snap-0.14.0.6" - , mInfo :: NiceImportDecl -- ^ Our parse of the module import, with info like "hiding (map)". - , qualifiedExports :: [FullyQualifiedName] -- ^ e.g. [ "base-4.8.2.0:GHC.Base.++" - -- , "base-4.8.2.0:GHC.List.filter" - -- , "base-4.8.2.0:GHC.List.zip" - -- , ... - -- ] - } - deriving Show - -refineAs :: forall m. MonadError GhcModError m => MySymbol -> [ModuleExports] -> m [ModuleExports] - --- User qualified the symbol, so we can filter out anything that doesn't have a matching 'modImportedAs'. -refineAs (MySymbolUserQualified userQualSym) exports = filterM f exports + { mName :: StrModuleName + -- ^ e.g. @"Data.List"@ + , mPackageName :: String + -- ^ e.g. @"snap-0.14.0.6"@ + , mInfo :: NiceImportDecl + -- ^ Our parse of the module import, with info like "hiding (map)". + , qualifiedExports :: [FullyQualifiedName] + -- ^ e.g. + -- @ + -- [ "base-4.8.2.0:GHC.Base.++" + -- , "base-4.8.2.0:GHC.List.filter" + -- , "base-4.8.2.0:GHC.List.zip" + -- , ... + -- ] + -- @ + } deriving Show + +-- User qualified the symbol, so we can filter out anything that doesn't have a +-- matching 'modImportedAs'. +refineAs :: MySymbol -> [ModuleExports] -> [ModuleExports] +refineAs (MySymbolUserQualified userQualSym) exports = filter f exports where - -- f :: ModuleExports -> Bool - f export = case modas of - Nothing -> return False - Just modas' -> do userQualAs <- liftMaybe - (GMEString $ "ImportedFrom: expected a qualified name like 'DL.length' but got: " ++ userQualSym) - (return $ moduleOfQualifiedName userQualSym) - return $ modas' == userQualAs + f ModuleExports { mInfo = NiceImportDecl { modImportedAs = modAs } } = + modAs == moduleOfQualifiedName userQualSym - where modas = modImportedAs $ mInfo export :: Maybe String - --- User didn't qualify the symbol, so we have the full system qualified thing, so do nothing here. -refineAs (MySymbolSysQualified _) exports = return exports +-- User didn't qualify the symbol, so we have the full system qualified thing, +-- so do nothing here. +refineAs (MySymbolSysQualified _) exports = exports refineRemoveHiding :: [ModuleExports] -> [ModuleExports] -refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports +refineRemoveHiding exports = + map (\e -> e { qualifiedExports = removeHiding e }) exports where - f export = filter (`notElem` hiding') thisExports - where hiding = modHiding $ mInfo export :: [String] -- Things that this module hides. - hiding' = map (qualifyName thisExports) hiding :: [String] -- Qualified version of hiding. - thisExports = qualifiedExports export -- Things that this module exports. + removeHiding export = filter (`notElem` hiding') thisExports + where hiding = modHiding $ mInfo export :: [String] + -- ^ Things that this module hides. + hiding' = map (qualifyName thisExports) hiding :: [String] + -- ^ Qualified version of hiding. + thisExports = qualifiedExports export + -- ^ Things that this module exports. nub' = Set.toList . Set.fromList @@ -452,34 +462,32 @@ refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports Left _ -> False Right () -> True where - f n = do - _ <- RP.string n - _ <- RP.char '.' - _ <- RP.manyTill nameThenDot (nameThenEnd +++ nameThenEnd') - return () + f n = void $ + RP.string n + >> RP.char '.' + >> RP.manyTill nameThenDot (nameThenEnd +++ nameThenEnd') + -- Valid chars in a haskell module name: -- https://www.haskell.org/onlinereport/syntax-iso.html modChar c = isAlpha c || isDigit c || (c == '\'') - nameThenEnd = do - RP.many1 $ RP.satisfy modChar - RP.eof + nameThenEnd = void $ + RP.many1 (RP.satisfy modChar) >> RP.eof - nameThenEnd' = do - RP.many1 $ RP.satisfy modChar - RP.char ':' - RP.manyTill RP.get RP.eof - RP.eof - - nameThenDot = do - RP.many1 $ RP.satisfy modChar - RP.char '.' - return () + nameThenEnd' = void $ + RP.many1 (RP.satisfy modChar) + >> RP.char ':' + >> RP.manyTill RP.get RP.eof + >> RP.eof + nameThenDot = void $ + RP.many1 (RP.satisfy modChar) + >> RP.char '.' refineExportsIt :: MySymbol -> [ModuleExports] -> [ModuleExports] -refineExportsIt mysymbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports +refineExportsIt mysymbol exports = + map (\e -> e { qualifiedExports = f symbol e }) exports where -- Deal with these? symbol = case mysymbol of @@ -487,15 +495,20 @@ refineExportsIt mysymbol exports = map (\e -> e { qualifiedExports = f symbol e MySymbolUserQualified s -> s f sym export = filter (postfixMatch sym) thisExports - where thisExports = qualifiedExports export -- Things that this module exports. + where + -- * Things that this module exports. + thisExports = qualifiedExports export + --- On an internal symbol (e.g. Show), refineExportsIt erronously filters out everything. --- For example mnsymbol = "base-4.9.0.0:GHC.Show.C:Show" and the matching --- name "base-4.9.0.0:GHC.Show.Show" from the Prelude. The problem seems to be the --- module name GHC.Show.C, probably referring to an internal C library. +-- On an internal symbol (e.g. Show), refineExportsIt erronously filters out +-- everything. For example mnsymbol = "base-4.9.0.0:GHC.Show.C:Show" and the +-- matching name "base-4.9.0.0:GHC.Show.Show" from the Prelude. The problem +-- seems to be the module name GHC.Show.C, probably referring to an internal C +-- library. -- --- To get around this, refineExportsItFallbackInternal uses a less strict matching --- rule. If the 'stage3' results are empty we fall back to this refiner. +-- To get around this, refineExportsItFallbackInternal uses a less strict +-- matching rule. If the 'stage3' results are empty we fall back to this +-- refiner. refineExportsItFallbackInternal :: MySymbol -> [ModuleExports] -> [ModuleExports] refineExportsItFallbackInternal mysymbol exports = case splitOn ":" symbol of @@ -508,26 +521,29 @@ refineExportsItFallbackInternal mysymbol exports MySymbolUserQualified s -> s -- Check if package name matches and postfix symbol matches (roughly). - f p sym export = filter - (\z -> p `isPrefixOf` z && postfixMatch sym z) - (qualifiedExports export) + f p sym export = + filter + (\z -> p `isPrefixOf` z && postfixMatch sym z) + (qualifiedExports export) refineLeadingDot :: MySymbol -> [ModuleExports] -> [ModuleExports] -refineLeadingDot (MySymbolUserQualified _) exports = exports -refineLeadingDot (MySymbolSysQualified symb) exports = map (\e -> e { qualifiedExports = f leadingDot e }) exports +refineLeadingDot (MySymbolUserQualified _) exports = exports +refineLeadingDot (MySymbolSysQualified symb) exports = + map (\e -> e { qualifiedExports = f leadingDot e }) exports where -- We use leadingDot only when we have an 'MySymbolSysQualified symb' so -- the 'last' will be ok. Sample value of 'symb' in this case is -- "base-4.8.2.0:Data.Foldable.length". leadingDot :: String - leadingDot = '.' : Safe.lastNote ("leadingDot: got: " ++ symb) (splitOn "." symb) + leadingDot = + '.' : Safe.lastNote ("leadingDot: got: " ++ symb) (splitOn "." symb) -- f symbol export = filter (symbol ==) thisExports f symbol export = filter (symbol `isSuffixOf`) thisExports - where thisExports = qualifiedExports export -- Things that this module exports. + where thisExports = qualifiedExports export refineVisibleExports - :: forall m. (GhcMonad m, MonadError GhcModError m, MonadIO m, GmOut m, GmLog m) + :: forall m. (GmGhc m, MonadError GhcModError m, GmOut m, GmLog m, GmEnv m) => (String -> m (Maybe String)) -> [ModuleExports] -> m [ModuleExports] @@ -542,9 +558,11 @@ refineVisibleExports getHaddockInterfaces exports = mapM f exports (GMEString "ImportedFrom: visible exports map is Nothing") (getVisibleExports getHaddockInterfaces pname) - gmLog GmDebug "refineVisibleExports" $ strDoc $ "visibleExportsMap: " ++ show visibleExportsMap - gmLog GmDebug "refineVisibleExports" $ strDoc $ "pname: " ++ show pname - gmLog GmDebug "refineVisibleExports" $ strDoc $ "thisModuleName: " ++ show thisModuleName + gmLog GmDebug "refineVisibleExports" $ foldr (\d e -> (d <> comma) <+> e) mempty + [ text "Package name" <+>: text pname + , text "Module" <+>: text thisModuleName + ] + gmVomit "refine:visible-exports-map" (text "visibleExportsMap") (ppShow visibleExportsMap) let thisModVisibleExports0 = M.lookup thisModuleName visibleExportsMap thisModVisibleExports1 = M.lookup (pname ++ ":" ++ thisModuleName) visibleExportsMap @@ -561,7 +579,7 @@ refineVisibleExports getHaddockInterfaces exports = mapM f exports let qexports' = filter (hasPostfixMatch thisModVisibleExports) qexports - gmLog GmDebug "visibleExportsMap" $ strDoc $ show (qexports, qexports') + gmVomit "visible-exports-map" mempty (ppShow (qexports \\ qexports', qexports')) return $ mexports { qualifiedExports = qexports' } @@ -578,7 +596,7 @@ getLastMatch exports = Safe.lastMay $ filter f exports -- | Try to look up the Haddock URL for a symbol. guessHaddockUrl :: forall m. - (GhcMonad m, MonadError GhcModError m, GmOut m, GmLog m, IOish m) + (GmGhc m, MonadError GhcModError m, GmOut m, GmLog m, GmEnv m) => ModSummary -> FilePath -> String @@ -612,7 +630,7 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr then importDecls0 else importDecls1 - qnames <- filter (not . (' ' `elem`)) <$> qualifiedName targetModule lineNr colNr symbol (map modName importDecls2) :: m [String] + qnames <- filter (not . (' ' `elem`)) <$> qualifiedNameAt targetModule lineNr colNr symbol (map modName importDecls2) :: m [String] gmLog GmDebug "guessHaddockUrl" $ strDoc $ "qnames: " ++ show qnames let symbolToUse :: String @@ -691,7 +709,7 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr showDebugStage "stage0" stage0 - stage1 <- refineAs mySymbol stage0 + let stage1 = refineAs mySymbol stage0 showDebugStage "stage1" stage1 let stage2 = refineRemoveHiding stage1 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1332a421c..90fe3c4ad 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -189,6 +189,7 @@ Library , monad-journal < 0.8 && >= 0.4 , old-time < 1.2 , pretty < 1.2 + , pretty-show < 1.7 && >= 1.6.12 , process < 1.5 , syb < 0.7 , temporary < 1.3 From cbb01829d79c212d183f486e8927339325df56cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 27 Aug 2016 20:13:50 +0200 Subject: [PATCH 14/33] Cleanup the scattered copyright blurbs --- COPYING.BSD3.base | 83 +++++++++++++++++++++++ COPYING.BSD3.ghc | 31 +++++++++ COPYING.BSD3.haddock-api | 23 +++++++ LICENSE | 4 ++ Language/Haskell/GhcMod/DebugLogger.hs | 37 ++--------- Language/Haskell/GhcMod/ImportedFrom.hs | 6 +- Language/Haskell/GhcMod/Read.hs | 87 +------------------------ ghc-mod.cabal | 15 ++++- 8 files changed, 162 insertions(+), 124 deletions(-) create mode 100644 COPYING.BSD3.base create mode 100644 COPYING.BSD3.ghc create mode 100644 COPYING.BSD3.haddock-api diff --git a/COPYING.BSD3.base b/COPYING.BSD3.base new file mode 100644 index 000000000..c362f2d90 --- /dev/null +++ b/COPYING.BSD3.base @@ -0,0 +1,83 @@ +This library (libraries/base) is derived from code from several +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + * Code from the Haskell Foreign Function Interface specification, + which is (c) Manuel M. T. Chakravarty and freely redistributable + (but see the full license for restrictions). + +The full text of these licenses is reproduced below. All of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- + +Code derived from the document "The Haskell 98 Foreign Function +Interface, An Addendum to the Haskell 98 Report" is distributed under +the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + +----------------------------------------------------------------------------- diff --git a/COPYING.BSD3.ghc b/COPYING.BSD3.ghc new file mode 100644 index 000000000..92337b951 --- /dev/null +++ b/COPYING.BSD3.ghc @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/COPYING.BSD3.haddock-api b/COPYING.BSD3.haddock-api new file mode 100644 index 000000000..460decfca --- /dev/null +++ b/COPYING.BSD3.haddock-api @@ -0,0 +1,23 @@ +Copyright 2002-2010, Simon Marlow. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/LICENSE b/LICENSE index c646aebdf..d93f7d586 100644 --- a/LICENSE +++ b/LICENSE @@ -4,3 +4,7 @@ under this license and can generally be identified by the lack of a GPL header. See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for copies of the two licenses. + +We also incorporate some code from the Glasgow Haskell Compiler and related +projects. See the remaining COPYING.* files in the source distribution for their +respective licenses. \ No newline at end of file diff --git a/Language/Haskell/GhcMod/DebugLogger.hs b/Language/Haskell/GhcMod/DebugLogger.hs index 0bd0d5985..ead9097f6 100644 --- a/Language/Haskell/GhcMod/DebugLogger.hs +++ b/Language/Haskell/GhcMod/DebugLogger.hs @@ -13,42 +13,13 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . + +-- This module is derived from GHC, see COPYING.BSD3.ghc in the source +-- distribution for it's license. + {-# LANGUAGE CPP, RankNTypes #-} module Language.Haskell.GhcMod.DebugLogger where --- (c) The University of Glasgow 2005 --- --- The Glasgow Haskell Compiler License --- --- Copyright 2002, The University Court of the University of Glasgow. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- - Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright notice, --- this list of conditions and the following disclaimer in the documentation --- and/or other materials provided with the distribution. --- --- - Neither name of the University nor the names of its contributors may be --- used to endorse or promote products derived from this software without --- specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF --- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, --- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND --- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT --- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY --- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH --- DAMAGE. import GHC import FastString diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 97434b7c3..f38a967b4 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -346,10 +346,8 @@ getVisibleExports getHaddockInterfaces p = do names = map (showSDoc dflags . ppr) $ Haddock.instVisibleExports ii ] - ------------------------------------------------------------------------------------------------------------------------ - -- Copied from http://hackage.haskell.org/package/haddock-api-2.16.1/docs/src/Haddock-InterfaceFile.html#nameCacheFromGhc - -- but for a general monad m instead of the specific monad Ghc. - ------------------------------------------------------------------------------------------------------------------------ + -- Derived from haddock-api, see COPYING.BSD3.haddock-api in the source + -- distribution for it's license. nameCacheFromGhc :: Haddock.NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where diff --git a/Language/Haskell/GhcMod/Read.hs b/Language/Haskell/GhcMod/Read.hs index 21b5b65f9..c037fcd45 100644 --- a/Language/Haskell/GhcMod/Read.hs +++ b/Language/Haskell/GhcMod/Read.hs @@ -1,93 +1,12 @@ +-- This module is derived from GHC's 'libraries/base', see COPYING.BSD3.base in +-- the source distribution for it's license. + module Language.Haskell.GhcMod.Read where import Text.Read (readPrec_to_S, readPrec, minPrec) import qualified Text.ParserCombinators.ReadP as P import Text.ParserCombinators.ReadPrec (lift) --- This library (libraries/base) is derived from code from several --- sources: - --- * Code from the GHC project which is largely (c) The University of --- Glasgow, and distributable under a BSD-style license (see below), - --- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones --- and freely redistributable (but see the full license for --- restrictions). - --- * Code from the Haskell Foreign Function Interface specification, --- which is (c) Manuel M. T. Chakravarty and freely redistributable --- (but see the full license for restrictions). - --- The full text of these licenses is reproduced below. All of the --- licenses are BSD-style or compatible. - --- ----------------------------------------------------------------------------- - --- The Glasgow Haskell Compiler License - --- Copyright 2004, The University Court of the University of Glasgow. --- All rights reserved. - --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: - --- - Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. - --- - Redistributions in binary form must reproduce the above copyright notice, --- this list of conditions and the following disclaimer in the documentation --- and/or other materials provided with the distribution. - --- - Neither name of the University nor the names of its contributors may be --- used to endorse or promote products derived from this software without --- specific prior written permission. - --- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF --- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, --- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND --- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT --- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY --- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH --- DAMAGE. - --- ----------------------------------------------------------------------------- - --- Code derived from the document "Report on the Programming Language --- Haskell 98", is distributed under the following license: - --- Copyright (c) 2002 Simon Peyton Jones - --- The authors intend this Report to belong to the entire Haskell --- community, and so we grant permission to copy and distribute it for --- any purpose, provided that it is reproduced in its entirety, --- including this Notice. Modified versions of this Report may also be --- copied and distributed for any purpose, provided that the modified --- version is clearly presented as such, and that it does not claim to --- be a definition of the Haskell 98 Language. - --- ----------------------------------------------------------------------------- - --- Code derived from the document "The Haskell 98 Foreign Function --- Interface, An Addendum to the Haskell 98 Report" is distributed under --- the following license: - --- Copyright (c) 2002 Manuel M. T. Chakravarty - --- The authors intend this Report to belong to the entire Haskell --- community, and so we grant permission to copy and distribute it for --- any purpose, provided that it is reproduced in its entirety, --- including this Notice. Modified versions of this Report may also be --- copied and distributed for any purpose, provided that the modified --- version is clearly presented as such, and that it does not claim to --- be a definition of the Haskell 98 Foreign Function Interface. - --- ----------------------------------------------------------------------------- - readEither :: Read a => String -> Either String a readEither s = case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 90fe3c4ad..f67ea8b21 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -7,7 +7,11 @@ Author: Kazu Yamamoto , Maintainer: Daniel Gröber License: AGPL-3 License-File: LICENSE -License-Files: COPYING.BSD3 COPYING.AGPL3 +License-Files: COPYING.BSD3 + COPYING.BSD3.ghc + COPYING.BSD3.base + COPYING.BSD3.haddock-api + COPYING.AGPL3 Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ Synopsis: Happy Haskell Programming Description: @@ -29,11 +33,16 @@ Cabal-Version: >= 1.14 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el -Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3 + LICENSE + COPYING.BSD3 + COPYING.BSD3.ghc + COPYING.BSD3.base + COPYING.BSD3.haddock-api + COPYING.AGPL3 + NotCPP/COPYING Extra-Source-Files: ChangeLog SetupCompat.hs NotCPP/*.hs - NotCPP/COPYING Language/Haskell/GhcMod/Monad/Compat.hs_h test/data/annotations/*.hs test/data/broken-cabal/*.cabal From 4ea88f405bd0657c5c96f22b03d0aeffac71f15d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 27 Aug 2016 23:38:51 +0200 Subject: [PATCH 15/33] imported-from: another cleanup pass --- Language/Haskell/GhcMod/ImportedFrom.hs | 363 +++++++++++++++--------- ghc-mod.cabal | 4 +- 2 files changed, 223 insertions(+), 144 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index f38a967b4..966edc421 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -1,4 +1,5 @@ --- Copyright (C) 2013-2016 Carlo Hamalainen +-- Copyright (C) 2013-2016 Carlo Hamalainen +-- Copyright (C) 2016 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by @@ -14,8 +15,8 @@ -- along with this program. If not, see . {-# LANGUAGE CPP, FlexibleContexts, Rank2Types, ScopedTypeVariables, ViewPatterns #-} - -module Language.Haskell.GhcMod.ImportedFrom (importedFrom) where +-- {-# OPTIONS_GHC -fwarn-typed-holes -fdefer-type-errors #-} +module Language.Haskell.GhcMod.ImportedFrom {-# WARNING "TODO: remove use of strDoc" #-} (importedFrom) where import Control.Applicative import Control.Exception @@ -26,10 +27,19 @@ import Data.IORef import Data.List import Data.List.Split import Data.Maybe +import System.Directory +import System.FilePath +import Text.ParserCombinators.ReadP ((+++)) +import Text.Show.Pretty + import Exception (ghandle) import FastString import GHC import HscTypes +import OccName +import Module +import Outputable (showSDoc, showSDocForUser, ppr) + import Language.Haskell.GhcMod import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Error @@ -41,11 +51,7 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.SrcUtils (listifySpans) -import Outputable (showSDoc, showSDocForUser, ppr) -import System.Directory -import System.FilePath -import Text.ParserCombinators.ReadP ((+++)) -import Text.Show.Pretty + import qualified Data.Map as M import qualified Data.Set as Set @@ -69,7 +75,6 @@ data NiceImportDecl , modSpecifically :: [String] } deriving (Show, Eq) - -- trace' :: Show x => String -> x -> b -> b -- trace' m x = trace (m ++ ">>> " ++ show x) @@ -116,7 +121,8 @@ runRP rp s = -- -- then: -- --- >>> map toImportDecl <$> getTextualImports "tests/data/data/Hiding.hs" "Hiding" >>= print +-- >>> map toImportDecl +-- >>> <$> getTextualImports "tests/data/data/Hiding.hs" "Hiding" >>= print -- [ NiceImportDecl { modName = "Prelude" -- , modQualifier = Nothing -- , modIsImplicit = True @@ -171,8 +177,8 @@ toImportDecl dflags idecl = grabNames loc = map (showSDoc dflags . ppr) names where names :: [RdrName] names = map (ieName . SrcLoc.unLoc) $ SrcLoc.unLoc loc - -- FIXME We are throwing away location info by using unLoc each time? - -- Trace these things to see what we are losing. + -- FIXME We are throwing away location info by using unLoc each + -- time? Trace these things to see what we are losing. parseHiding :: Maybe (Bool, Located [LIE RdrName]) -> [Maybe String] parseHiding Nothing = [Nothing] @@ -204,7 +210,7 @@ toImportDecl dflags idecl = -- >>> postfixMatch "bar" "bar" -- True postfixMatch :: String -> QualifiedName -> Bool -postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName +postfixMatch originalSymbol qn = endTerm `isSuffixOf` qn where endTerm = Safe.lastNote ("postfixMatch: got: " ++ originalSymbol) $ splitOn "." originalSymbol @@ -224,8 +230,7 @@ moduleOfQualifiedName qn = else Just $ intercalate "." bits where bits = reverse $ drop 1 $ reverse $ splitOn "." qn -{-# WARNING moduleOfQualifiedName "TODO: unsafe 'drop 1'" #-} - +{-# DEPRECATED moduleOfQualifiedName "TODO: mkQualifiedName should store the module instead of parsing here, also usafe 'drop 1'" #-} -- | Find the possible qualified names for the symbol at line/col in the given -- Haskell file and module. Returns a fully qualified name thatincludes the @@ -235,6 +240,8 @@ moduleOfQualifiedName qn = qualifiedNameAt :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) => String -> Int -> Int -> String -> [String] -> m [String] +{-# WARNING qualifiedNameAt + "TODO: don't abuse the pretty printer, deal directly with 'Name's and such" #-} qualifiedNameAt targetModuleName lineNr colNr symbol importList = do dflags <- GHC.getSessionDynFlags @@ -245,15 +252,15 @@ qualifiedNameAt targetModuleName lineNr colNr symbol importList = do handler :: SomeException -> m () handler err = do gmLog GmException "qualifiedNameAt" $ - text "setContext failed, trying to continue anyway." $+$ - text (show err) + text "setContext failed, trying to continue anyway." $+$ + text (show err) setContext $ ctx imports_fallback setContext (ctx imports_with_target_module) `gcatch` handler - modSummary <- getModSummary $ mkModuleName targetModuleName :: m ModSummary - p <- parseModule modSummary :: m ParsedModule - t <- typecheckModule p :: m TypecheckedModule + modSummary <- getModSummary $ mkModuleName targetModuleName + p <- parseModule modSummary + t <- typecheckModule p let TypecheckedModule { tm_typechecked_source = tcs } = t bs = listifySpans tcs (lineNr, colNr) :: [LHsBind Id] @@ -265,23 +272,24 @@ qualifiedNameAt targetModuleName lineNr colNr symbol importList = do ps' = map (showSDocForUser dflags ghcQualify . ppr) ps gmLog GmDebug "qualifiedNameAt" $ strDoc $ "symbol: " ++ symbol - gmLog GmDebug "qualifiedNameAt" $ strDoc $ "line, col: " ++ show (lineNr, colNr) + gmLog GmDebug "qualifiedNameAt" $ strDoc $ + "line, col: " ++ show (lineNr, colNr) let stuff = map dropParens $ concatMap words $ bs' ++ es' ++ ps' gmLog GmDebug "qualifiedNameAt" $ strDoc $ "stuff: " ++ show stuff return $ filter (postfixMatch symbol) stuff - where - -- GHC8 starts showing things inside parens? Why? e.g. "(base-4.9.0.0:GHC.Num.+)" + -- GHC8 starts showing things inside parens? Why? + -- e.g. "(base-4.9.0.0:GHC.Num.+)" dropParens :: String -> String dropParens = dropWhileEnd (== ')') . dropWhile (== '(') splitPackageName :: String -> String -splitPackageName p - = case splitOn "@" p of - [p0, _] -> p0 - _ -> p +splitPackageName p = + case splitOn "@" p of + [p0, _] -> p0 + _ -> p ghcPkgHaddockUrl :: forall m. (GmLog m, GmOut m, MonadIO m) @@ -300,7 +308,13 @@ ghcPkgHaddockUrl ghcPkg readProc pkgDbStack p = do where -- This fails unless we have --global and --user, unlike -- pkgDoc elsewhere in ghc-mod. - toDocDirOpts pkg dbs = ["field", pkg, "haddock-html", "--global", "--user"] ++ ghcPkgDbStackOpts dbs + toDocDirOpts pkg dbs = + [ "field" + , pkg + , "haddock-html" + , "--global" + , "--user" + ] ++ ghcPkgDbStackOpts dbs ghcPkgHaddockInterface :: forall (m :: * -> *). MonadIO m @@ -311,9 +325,15 @@ ghcPkgHaddockInterface -> m (Maybe String) ghcPkgHaddockInterface ghcPkg readProc pkgDbStack p = do hout <- liftIO $ readProc ghcPkg (toHaskellInterfaces p pkgDbStack) "" - return $ Safe.lastMay $ words $ reverse . dropWhile (== '\n') . reverse $ hout + return $ Safe.lastMay $ words $ reverse $ dropWhile (== '\n') $ reverse hout where - toHaskellInterfaces pkg dbs = ["field", pkg, "haddock-interfaces", "--global", "--user"] ++ ghcPkgDbStackOpts dbs + toHaskellInterfaces pkg dbs = + [ "field" + , pkg + , "haddock-interfaces" + , "--global" + , "--user" + ] ++ ghcPkgDbStackOpts dbs getVisibleExports :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) @@ -340,11 +360,12 @@ getVisibleExports getHaddockInterfaces p = do case iface of Left _ -> throw $ GMEMissingHaddockInterface ifile Right iface' -> return $ Just $ M.fromList - [ (mname, names) - | ii <- Haddock.ifInstalledIfaces iface' - , let mname = showSDoc dflags $ ppr $ Haddock.instMod ii - names = map (showSDoc dflags . ppr) $ Haddock.instVisibleExports ii - ] + [ (mname, names) + | ii <- Haddock.ifInstalledIfaces iface' + , let mname = showSDoc dflags $ ppr $ Haddock.instMod ii + names = map (showSDoc dflags . ppr) $ + Haddock.instVisibleExports ii + ] -- Derived from haddock-api, see COPYING.BSD3.haddock-api in the source -- distribution for it's license. @@ -411,14 +432,16 @@ data ModuleExports = ModuleExports , qualifiedExports :: [FullyQualifiedName] -- ^ e.g. -- @ - -- [ "base-4.8.2.0:GHC.Base.++" - -- , "base-4.8.2.0:GHC.List.filter" - -- , "base-4.8.2.0:GHC.List.zip" - -- , ... - -- ] + -- [ "base-4.8.2.0:GHC.Base.++" + -- , "base-4.8.2.0:GHC.List.filter" + -- , "base-4.8.2.0:GHC.List.zip" + -- , ... + -- ] -- @ } deriving Show +{-# WARNING refineAs "TODO: check if non qualified 'as' imports work correctly" #-} + -- User qualified the symbol, so we can filter out anything that doesn't have a -- matching 'modImportedAs'. refineAs :: MySymbol -> [ModuleExports] -> [ModuleExports] @@ -549,41 +572,56 @@ refineVisibleExports getHaddockInterfaces exports = mapM f exports where f :: ModuleExports -> m ModuleExports f mexports = do - let pname = mPackageName mexports -- e.g. "base-4.8.2.0" - thisModuleName = mName mexports -- e.g. "Prelude" - qexports = qualifiedExports mexports -- e.g. ["base-4.8.2.0:GHC.Base.Just", ...] - visibleExportsMap <- liftMaybe - (GMEString "ImportedFrom: visible exports map is Nothing") - (getVisibleExports getHaddockInterfaces pname) - - gmLog GmDebug "refineVisibleExports" $ foldr (\d e -> (d <> comma) <+> e) mempty + let pname = mPackageName mexports + -- ^ e.g. "base-4.8.2.0" + thisModuleName = mName mexports + -- ^ e.g. "Prelude" + qexports = qualifiedExports mexports + -- ^ e.g. ["base-4.8.2.0:GHC.Base.Just", ...] + + let err = GMEString "ImportedFrom: visible exports map is Nothing" + visibleExportsMap <- + liftMaybe err (getVisibleExports getHaddockInterfaces pname) + + let ppCommaList = foldr (\d e -> (d <> comma) <+> e) mempty + gmLog GmDebug "refineVisibleExports" $ ppCommaList [ text "Package name" <+>: text pname , text "Module" <+>: text thisModuleName ] - gmVomit "refine:visible-exports-map" (text "visibleExportsMap") (ppShow visibleExportsMap) - - let thisModVisibleExports0 = M.lookup thisModuleName visibleExportsMap - thisModVisibleExports1 = M.lookup (pname ++ ":" ++ thisModuleName) visibleExportsMap - - -- On earlier versions of GHC, our qexports list will not be fully qualified, so it will - -- look like ["base:GHC.Base.Just", ...] instead of ["base-4.8.2.0:GHC.Base.Just", ...]. - -- So if thisModVisibleExports0 is Nothing, fall back to searching on a shorter pname. - thisModVisibleExports <- case thisModVisibleExports0 `mplus` thisModVisibleExports1 of - Just ve -> return ve - Nothing -> let pname' = ((Safe.headNote ("pname: " ++ pname) $ splitOn "-" pname) ++ ":" ++ thisModuleName) in - liftMaybe - (GMENoVisibleExports thisModuleName pname') - (return $ M.lookup pname' visibleExportsMap) + gmVomit "refine:visible-exports-map" + (text "visibleExportsMap") (ppShow visibleExportsMap) + + let thisModVisibleExports0 = + M.lookup thisModuleName visibleExportsMap + thisModVisibleExports1 = + M.lookup (pname ++ ":" ++ thisModuleName) visibleExportsMap + + -- On earlier versions of GHC, our qexports list will not be fully + -- qualified, so it will look like ["base:GHC.Base.Just", ...] instead + -- of ["base-4.8.2.0:GHC.Base.Just", ...]. So if thisModVisibleExports0 + -- is Nothing, fall back to searching on a shorter pname. + + thisModVisibleExports <- + case thisModVisibleExports0 `mplus` thisModVisibleExports1 of + Just ve -> return ve + Nothing -> let + pname' = (Safe.headNote ("pname: " ++ pname) $ splitOn "-" pname) + ++ ":" ++ thisModuleName + in + liftMaybe (GMENoVisibleExports thisModuleName pname') $ + return $ M.lookup pname' visibleExportsMap let qexports' = filter (hasPostfixMatch thisModVisibleExports) qexports - gmVomit "visible-exports-map" mempty (ppShow (qexports \\ qexports', qexports')) + gmVomit "visible-exports-map" mempty $ + ppShow (qexports \\ qexports', qexports') return $ mexports { qualifiedExports = qexports' } -- hasPostfixMatch "base-4.8.2.0:GHC.Base.Just" ["Just", "True", ...] -> True hasPostfixMatch :: [String] -> String -> Bool - hasPostfixMatch xs s = Safe.lastNote ("hasPostfixMatch: got: " ++ s) (splitOn "." s) `elem` xs + hasPostfixMatch xs s = + Safe.lastNote ("hasPostfixMatch: got: " ++ s) (splitOn "." s) `elem` xs -- | The last thing with a single export must be the match? Iffy. getLastMatch :: [ModuleExports] -> Maybe ModuleExports @@ -605,7 +643,8 @@ guessHaddockUrl -> (FilePath -> [String] -> String -> IO String) -> [GhcPkgDb] -> m String -guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readProc pkgDbStack = do +guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg + readProc pkgDbStack = do gmLog GmDebug "guessHaddockUrl" $ strDoc $ "targetFile: " ++ targetFile gmLog GmDebug "guessHaddockUrl" $ strDoc $ "targetModule: " ++ targetModule gmLog GmDebug "guessHaddockUrl" $ strDoc $ "symbol: " ++ show symbol @@ -617,7 +656,8 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr let textualImports = ghc_ms_textual_imps modSum importDecls0 = map (toImportDecl dflags) textualImports - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "haskellModuleNames0: " ++ show importDecls0 + gmLog GmDebug "guessHaddockUrl" $ + strDoc $ "haskellModuleNames0: " ++ show importDecls0 -- If symbol is something like DM.lookup, then restrict importDecls0 to the -- one that has modImportedAs == Just "DM". @@ -628,31 +668,36 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr then importDecls0 else importDecls1 - qnames <- filter (not . (' ' `elem`)) <$> qualifiedNameAt targetModule lineNr colNr symbol (map modName importDecls2) :: m [String] + qnames <- filter (not . (' ' `elem`)) + <$> qualifiedNameAt targetModule lineNr colNr symbol + (map modName importDecls2) :: m [String] gmLog GmDebug "guessHaddockUrl" $ strDoc $ "qnames: " ++ show qnames let symbolToUse :: String - symbolToUse = case qnames of - (qq:_) -> qq -- We got a qualified name, with qualified printing. Qualified! - [] -> fail $ "ImportedFrom: qnames is empty." + symbolToUse = + case qnames of + (qq:_) -> qq -- We got a qualified name, with qualified + -- printing. Qualified! + [] -> fail $ "ImportedFrom: qnames is empty." gmLog GmDebug "guessHaddockUrl" $ strDoc $ "symbolToUse: " ++ symbolToUse - -- Sometimes we have to load an extra module (using setContext) otherwise - -- we can't look up the global reader environment without causing a GHC panic. + -- Sometimes we have to load an extra module (using setContext) otherwise we + -- can't look up the global reader environment without causing a GHC panic. -- For example 'Int' comes from GHC.Types, which is picked up here via the -- full qualified name. let parsedPackagesAndQualNames = map (runRP parsePackageAndQualName) qnames - mkNiceDecl x = [ NiceImportDecl - { modName = x - , modQualifier = Nothing - , modIsImplicit = False - , modHiding = [] - , modImportedAs = Nothing - , modSpecifically = [] - } - ] + mkNiceDecl x = + [ NiceImportDecl + { modName = x + , modQualifier = Nothing + , modIsImplicit = False + , modHiding = [] + , modImportedAs = Nothing + , modSpecifically = [] + } + ] extraImportDecls :: [NiceImportDecl] extraImportDecls = case Safe.headMay parsedPackagesAndQualNames of @@ -661,13 +706,18 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr importDecls3 = importDecls2 ++ extraImportDecls - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "parsedPackagesAndQualNames: " ++ show parsedPackagesAndQualNames - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "extraImportDecls: " ++ show extraImportDecls + gmLog GmDebug "guessHaddockUrl" $ + strDoc $ "parsedPackagesAndQualNames: " ++ show parsedPackagesAndQualNames + + gmLog GmDebug "guessHaddockUrl" $ + strDoc $ "extraImportDecls: " ++ show extraImportDecls - exports0 <- mapM (getModuleExports ghcPkg readProc pkgDbStack) importDecls3 :: m [Maybe ([String], String)] + exports0 <- mapM (getModuleExports ghcPkg readProc pkgDbStack) importDecls3 + :: m [Maybe ([String], String)] - -- Sometimes the modules in extraImportDecls might be hidden or weird ones like GHC.Base that we can't - -- load, so filter out the successfully loaded ones. + -- Sometimes the modules in extraImportDecls might be hidden or weird ones + -- like GHC.Base that we can't load, so filter out the successfully loaded + -- ones. let successes :: [(NiceImportDecl, Maybe ([String], String))] successes = filter (isJust . snd) (zip importDecls3 exports0) @@ -679,12 +729,13 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr successes' :: [(NiceImportDecl, ([String], String))] successes' = mapMaybe toMaybe successes - mkExports (m, (e, p)) = ModuleExports - { mName = modName m - , mPackageName = p - , mInfo = m - , qualifiedExports = e - } + mkExports (m, (e, p)) = + ModuleExports + { mName = modName m + , mPackageName = p + , mInfo = m + , qualifiedExports = e + } stage0 = map mkExports successes' @@ -692,18 +743,26 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr let asImports :: [String] asImports = mapMaybe (modImportedAs . mInfo) stage0 - mySymbol = case moduleOfQualifiedName symbol of - Nothing -> MySymbolSysQualified symbolToUse - Just x -> if x `elem` asImports - then MySymbolUserQualified symbol - else MySymbolSysQualified symbolToUse + mySymbol = + case moduleOfQualifiedName symbol of + Nothing -> MySymbolSysQualified symbolToUse + Just x -> + if x `elem` asImports + then MySymbolUserQualified symbol + else MySymbolSysQualified symbolToUse gmLog GmDebug "guessHaddockUrl" $ strDoc $ "mySymbol: " ++ show mySymbol let pprModuleExports :: ModuleExports -> String - pprModuleExports me = "(" ++ mName me ++ ", " ++ show (mInfo me) ++ ", " ++ unwords (map show $ qualifiedExports me) ++ ")" + pprModuleExports me = + "(" ++ mName me ++ ", " ++ show (mInfo me) + ++ ", " ++ unwords (map show $ qualifiedExports me) + ++ ")" - showDebugStage stageNr stage = forM_ stage $ \x -> gmLog GmDebug "guessHaddockUrl" $ strDoc $ stageNr ++ " " ++ pprModuleExports x + showDebugStage stageNr stage = + forM_ stage $ \x -> + gmLog GmDebug "guessHaddockUrl" $ + strDoc $ stageNr ++ " " ++ pprModuleExports x showDebugStage "stage0" stage0 @@ -724,40 +783,50 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr stage5 <- refineVisibleExports (ghcPkgHaddockInterface ghcPkg readProc pkgDbStack) stage4 showDebugStage "stage5" stage5 - let lastMatch = Safe.headMay $ catMaybes [getLastMatch stage5, getLastMatch stage4] + let lastMatch = + Safe.headMay $ catMaybes [getLastMatch stage5, getLastMatch stage4] - gmLog GmDebug "guessHaddockUrl" $ strDoc $ show $ "lastMatch: " ++ show lastMatch + gmLog GmDebug "guessHaddockUrl" $ + strDoc $ show $ "lastMatch: " ++ show lastMatch let lastMatchModule :: String - lastMatchModule = case mName <$> lastMatch of - Just modn -> modn - _ -> fail $ "ImportedFrom: no nice match in lastMatch for module: " ++ show lastMatch + lastMatchModule = + case mName <$> lastMatch of + Just modn -> modn + _ -> fail $ "ImportedFrom: no nice match in lastMatch for module: " ++ show lastMatch lastMatchPackageName :: String - lastMatchPackageName = case mPackageName <$> lastMatch of - Just p -> p - _ -> fail $ "ImportedFrom: no nice match in lastMatch for package name: " ++ show lastMatch + lastMatchPackageName = + case mPackageName <$> lastMatch of + Just p -> p + _ -> fail $ "ImportedFrom: no nice match in lastMatch for package name: " ++ show lastMatch - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "lastMatchModule: " ++ lastMatchModule - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "lastMatchPackageName: " ++ lastMatchPackageName + gmLog GmDebug "guessHaddockUrl" $ + strDoc $ "lastMatchModule: " ++ lastMatchModule + gmLog GmDebug "guessHaddockUrl" $ + strDoc $ "lastMatchPackageName: " ++ lastMatchPackageName - haddock <- liftMaybe - (GMEString $ "ImportedFrom: ghcPkgHaddockUrl failed to find path to HTML file.") - (ghcPkgHaddockUrl ghcPkg readProc pkgDbStack lastMatchPackageName) + let err = GMEString $ "ImportedFrom: ghcPkgHaddockUrl failed to find path to HTML file." + haddock <- liftMaybe err $ + ghcPkgHaddockUrl ghcPkg readProc pkgDbStack lastMatchPackageName - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "haddock: " ++ show haddock + gmLog GmDebug "guessHaddockUrl" $ + strDoc $ "haddock: " ++ show haddock - let mySymbol' = case mySymbol of - MySymbolSysQualified s -> s - MySymbolUserQualified s -> s + let mySymbol' = + case mySymbol of + MySymbolSysQualified s -> s + MySymbolUserQualified s -> s let f = haddock (moduleNameToHtmlFile lastMatchModule) e <- liftIO $ doesFileExist f return $ - if e then mySymbol' ++ " " ++ lastMatchModule ++ " file://" ++ f - else mySymbol' ++ " " ++ lastMatchModule ++ " " ++ toHackageUrl f lastMatchPackageName lastMatchModule + if e + then mySymbol' ++ " " ++ lastMatchModule ++ " file://" ++ f + else mySymbol' ++ " " ++ lastMatchModule ++ " " + ++ toHackageUrl f lastMatchPackageName lastMatchModule where -- Convert a module name string, e.g. @Data.List@ to @Data-List.html@. @@ -769,29 +838,38 @@ guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg readPr f c = c toHackageUrl :: FilePath -> String -> String -> String - toHackageUrl filepath package modulename = "https://hackage.haskell.org/package/" ++ package ++ "/" ++ "docs/" ++ modulename'' - where filepath' = map repl filepath - modulename' = Safe.headNote "modulename1" $ splitOn "." $ Safe.headNote "modulename2" $ splitOn "-" modulename - modulename'' = drop (fromJust $ substringP modulename' filepath') filepath' - - -- On Windows we get backslashes in the file path; convert - -- to forward slashes for the URL. - repl :: Char -> Char - repl '\\' = '/' - repl c = c - - -- Adapted from http://www.haskell.org/pipermail/haskell-cafe/2010-June/078702.html - substringP :: String -> String -> Maybe Int - substringP _ [] = Nothing - substringP sub str = if sub `isPrefixOf` str - then Just 0 - else fmap (+1) $ substringP sub (Safe.tailNote ("substringP: " ++ str) str) - - filterMatchingQualifiedImport :: String -> [NiceImportDecl] -> [NiceImportDecl] - filterMatchingQualifiedImport symbol hmodules - = case moduleOfQualifiedName symbol of - Nothing -> [] - asBit@(Just _) -> filter (\z -> asBit == modImportedAs z) hmodules + toHackageUrl filepath package modulename = + "https://hackage.haskell.org/package/" ++ package ++ "/" + ++ "docs/" ++ modulename'' + where + filepath' = map repl filepath + modulename' = Safe.headNote "modulename1" + $ splitOn "." + $ Safe.headNote "modulename2" $ splitOn "-" modulename + modulename'' = + drop (fromJust $ substringP modulename' filepath') filepath' + + -- On Windows we get backslashes in the file path; convert + -- to forward slashes for the URL. + repl :: Char -> Char + repl '\\' = '/' + repl c = c + + -- Adapted from + -- http://www.haskell.org/pipermail/haskell-cafe/2010-June/078702.html + substringP :: String -> String -> Maybe Int + substringP _ [] = Nothing + substringP sub str = + if sub `isPrefixOf` str + then Just 0 + else fmap (+1) $ substringP sub (Safe.tailNote ("substringP: " ++ str) str) + + filterMatchingQualifiedImport + :: String -> [NiceImportDecl] -> [NiceImportDecl] + filterMatchingQualifiedImport symbol hmodules = + case moduleOfQualifiedName symbol of + Nothing -> [] + asBit@(Just _) -> filter (\z -> asBit == modImportedAs z) hmodules -- | Look up Haddock docs for a symbol. importedFrom @@ -824,5 +902,6 @@ importedFrom file lineNr colNr (Expression symbol) = do modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) let modstr = moduleNameString $ ms_mod_name modSum :: String - x <- guessHaddockUrl modSum file modstr symbol lineNr colNr ghcPkg readProc pkgDbStack + x <- guessHaddockUrl + modSum file modstr symbol lineNr colNr ghcPkg readProc pkgDbStack return $ x ++ "\n" diff --git a/ghc-mod.cabal b/ghc-mod.cabal index f67ea8b21..3c99bb24e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -118,7 +118,7 @@ Custom-Setup Library Default-Language: Haskell2010 - GHC-Options: -Wall -fno-warn-deprecations + GHC-Options: -Wall Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, DataKinds, KindSignatures, TypeOperators, ViewPatterns @@ -240,7 +240,7 @@ Executable ghc-mod , GHCMod.Options.Commands , GHCMod.Version , GHCMod.Options.ShellParse - GHC-Options: -Wall -fno-warn-deprecations -threaded + GHC-Options: -Wall -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base < 5 && >= 4.0 From 3f282a8cf9bab89974234de75cf10b83fc5c7b63 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sat, 22 Oct 2016 18:32:06 +0300 Subject: [PATCH 16/33] Rough sketch for imported-from idea --- Language/Haskell/GhcMod/ImportedFrom.hs | 922 ++---------------------- Language/Haskell/GhcMod/SrcUtils.hs | 20 + 2 files changed, 80 insertions(+), 862 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 966edc421..56e0f6b55 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -14,862 +14,33 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP, FlexibleContexts, Rank2Types, ScopedTypeVariables, ViewPatterns #-} -- {-# OPTIONS_GHC -fwarn-typed-holes -fdefer-type-errors #-} module Language.Haskell.GhcMod.ImportedFrom {-# WARNING "TODO: remove use of strDoc" #-} (importedFrom) where import Control.Applicative import Control.Exception -import Control.Monad -import Control.Monad.Trans.Maybe -import Data.Char (isAlpha, isDigit) -import Data.IORef import Data.List -import Data.List.Split import Data.Maybe -import System.Directory import System.FilePath -import Text.ParserCombinators.ReadP ((+++)) -import Text.Show.Pretty import Exception (ghandle) import FastString import GHC -import HscTypes import OccName -import Module -import Outputable (showSDoc, showSDocForUser, ppr) +import Packages +import Name import Language.Haskell.GhcMod import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.FileMapping import Language.Haskell.GhcMod.Gap -import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Output -import Language.Haskell.GhcMod.PkgDoc -import Language.Haskell.GhcMod.SrcUtils (listifySpans) - - -import qualified Data.Map as M -import qualified Data.Set as Set -import qualified Documentation.Haddock as Haddock -import qualified GhcMonad -import qualified Safe -import qualified SrcLoc -import qualified Text.ParserCombinators.ReadP as RP - -type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@. - -data NiceImportDecl - -- | Information about an import of a Haskell module. Convenience type - -- for the bits of a 'GHC.ImportDecl' that we need. - = NiceImportDecl - { modName :: String - , modQualifier :: Maybe String - , modIsImplicit :: Bool - , modHiding :: [String] - , modImportedAs :: Maybe String - , modSpecifically :: [String] - } deriving (Show, Eq) - --- trace' :: Show x => String -> x -> b -> b --- trace' m x = trace (m ++ ">>> " ++ show x) - --- trace'' :: Outputable x => String -> x -> b -> b --- trace'' m x = trace (m ++ ">>> " ++ showSDoc tdflags (ppr x)) - -parsePackageAndQualName :: RP.ReadP (String, String) -parsePackageAndQualName = - RP.choice [parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash] - where - -- Package with no hash (seems to be for internal packages?) - -- base-4.8.2.0:Data.Foldable.length - parsePackageAndQualNameNoHash = - (,) <$> parsePackageName <*> parsePackageFinalQualName - parsePackageName = RP.get `RP.manyTill` RP.char ':' - parsePackageFinalQualName = RP.many1 RP.get - --- Parse the package name "containers-0.5.6.2" from a string like --- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList" -parsePackageAndQualNameWithHash :: RP.ReadP (String, String) -parsePackageAndQualNameWithHash = do - (,) <$> parsePackageName <* parsePackageHash <*> parsePackageFinalQualName - where - parsePackageName = RP.get `RP.manyTill` RP.char '@' - parsePackageHash = RP.get `RP.manyTill` RP.char ':' - parsePackageFinalQualName = RP.many1 RP.get - -runRP :: Show t => RP.ReadP t -> String -> Either String t -runRP rp s = - case RP.readP_to_S rp s of - [(m, "")] -> Right m - err -> Left $ "runRP: no unique match: " ++ show err - --- | Convenience function for converting an 'GHC.ImportDecl' to a --- 'NiceImportDecl'. --- --- Example: --- --- > -- Hiding.hs --- > module Hiding where --- > import Data.List hiding (map) --- > import System.Environment (getArgs) --- > import qualified Safe --- --- then: --- --- >>> map toImportDecl --- >>> <$> getTextualImports "tests/data/data/Hiding.hs" "Hiding" >>= print --- [ NiceImportDecl { modName = "Prelude" --- , modQualifier = Nothing --- , modIsImplicit = True --- , modHiding = [] --- , modImportedAs = Nothing --- , modSpecifically = [] --- } --- , NiceImportDecl {modName = "Safe" --- , modQualifier = Nothing --- , modIsImplicit = False --- , modHiding = [] --- , modImportedAs = Nothing --- , modSpecifically = [] --- } --- , NiceImportDecl { modName = "System.Environment" --- , modQualifier = Nothing --- , modIsImplicit = False --- , modHiding = [] --- , modImportedAs = Nothing --- , modSpecifically = ["getArgs"] --- } --- , NiceImportDecl { modName = "Data.List" --- , modQualifier = Nothing --- , modIsImplicit = False --- , modHiding = ["map"] --- , modImportedAs = Nothing --- , modSpecifically = [] --- } --- ] -toImportDecl :: GHC.DynFlags - -> SrcLoc.Located (GHC.ImportDecl GHC.RdrName) - -> NiceImportDecl -toImportDecl dflags idecl = - NiceImportDecl - { modName = name - , modQualifier = qualifier - , modIsImplicit = isImplicit - , modHiding = hiding - , modImportedAs = importedAs - , modSpecifically = specifically - } - where - idecl' = SrcLoc.unLoc idecl - name = showSDoc dflags (ppr $ GHC.ideclName idecl') - isImplicit = GHC.ideclImplicit idecl' - qualifier = unpackFS <$> ghc_sl_fs <$> GHC.ideclPkgQual idecl' - hiding = (catMaybes . parseHiding . ghcIdeclHiding) idecl' - importedAs = (showSDoc dflags . ppr) <$> ideclAs idecl' - specifically = (parseSpecifically . ghcIdeclHiding) idecl' - - grabNames :: GHC.Located [GHC.LIE GHC.RdrName] -> [String] - grabNames loc = map (showSDoc dflags . ppr) names - where names :: [RdrName] - names = map (ieName . SrcLoc.unLoc) $ SrcLoc.unLoc loc - -- FIXME We are throwing away location info by using unLoc each - -- time? Trace these things to see what we are losing. - - parseHiding :: Maybe (Bool, Located [LIE RdrName]) -> [Maybe String] - parseHiding Nothing = [Nothing] - - -- If we do - -- - -- import System.Environment ( getArgs ) - -- - -- then we get ["getArgs"] here, but we don't really need it... - parseHiding (Just (False, _)) = [] - - -- Actually hid names, e.g. - -- - -- import Data.List hiding (map) - parseHiding (Just (True, h)) = map Just $ grabNames h - - parseSpecifically :: Maybe (Bool, Located [LIE RdrName]) -> [String] - parseSpecifically (Just (False, h)) = grabNames h - parseSpecifically _ = [] - --- | Returns True if the 'Symbol' matches the end of the 'QualifiedName'. --- --- Example: --- --- >>> postfixMatch "bar" "Foo.bar" --- True --- >>> postfixMatch "bar" "Foo.baz" --- False --- >>> postfixMatch "bar" "bar" --- True -postfixMatch :: String -> QualifiedName -> Bool -postfixMatch originalSymbol qn = endTerm `isSuffixOf` qn - where - endTerm = Safe.lastNote ("postfixMatch: got: " ++ originalSymbol) $ - splitOn "." originalSymbol - --- | Get the module part of a qualified name. --- --- Example: --- --- >>> moduleOfQualifiedName "Foo.bar" --- Just "Foo" --- >>> moduleOfQualifiedName "Foo" --- Nothing -moduleOfQualifiedName :: QualifiedName -> Maybe String -moduleOfQualifiedName qn = - if null bits - then Nothing - else Just $ intercalate "." bits - where - bits = reverse $ drop 1 $ reverse $ splitOn "." qn -{-# DEPRECATED moduleOfQualifiedName "TODO: mkQualifiedName should store the module instead of parsing here, also usafe 'drop 1'" #-} - --- | Find the possible qualified names for the symbol at line/col in the given --- Haskell file and module. Returns a fully qualified name thatincludes the --- package, hash, and name, e.g. --- --- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList". -qualifiedNameAt - :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) - => String -> Int -> Int -> String -> [String] -> m [String] -{-# WARNING qualifiedNameAt - "TODO: don't abuse the pretty printer, deal directly with 'Name's and such" #-} -qualifiedNameAt targetModuleName lineNr colNr symbol importList = do - dflags <- GHC.getSessionDynFlags - - let imports_with_target_module = targetModuleName : importList - imports_fallback = importList - ctx imports = map (IIDecl . simpleImportDecl . mkModuleName) imports - - handler :: SomeException -> m () - handler err = do - gmLog GmException "qualifiedNameAt" $ - text "setContext failed, trying to continue anyway." $+$ - text (show err) - setContext $ ctx imports_fallback - - setContext (ctx imports_with_target_module) `gcatch` handler - - modSummary <- getModSummary $ mkModuleName targetModuleName - p <- parseModule modSummary - t <- typecheckModule p - - let TypecheckedModule { tm_typechecked_source = tcs } = t - bs = listifySpans tcs (lineNr, colNr) :: [LHsBind Id] - es = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id] - ps = listifySpans tcs (lineNr, colNr) :: [LPat Id] - - let bs' = map (showSDocForUser dflags ghcQualify . ppr) bs - es' = map (showSDocForUser dflags ghcQualify . ppr) es - ps' = map (showSDocForUser dflags ghcQualify . ppr) ps - - gmLog GmDebug "qualifiedNameAt" $ strDoc $ "symbol: " ++ symbol - gmLog GmDebug "qualifiedNameAt" $ strDoc $ - "line, col: " ++ show (lineNr, colNr) - - let stuff = map dropParens $ concatMap words $ bs' ++ es' ++ ps' - gmLog GmDebug "qualifiedNameAt" $ strDoc $ "stuff: " ++ show stuff - - return $ filter (postfixMatch symbol) stuff - where - -- GHC8 starts showing things inside parens? Why? - -- e.g. "(base-4.9.0.0:GHC.Num.+)" - dropParens :: String -> String - dropParens = dropWhileEnd (== ')') . dropWhile (== '(') - -splitPackageName :: String -> String -splitPackageName p = - case splitOn "@" p of - [p0, _] -> p0 - _ -> p - -ghcPkgHaddockUrl - :: forall m. (GmLog m, GmOut m, MonadIO m) - => FilePath - -> (FilePath -> [String] -> String -> IO String) - -> [GhcPkgDb] - -> String - -> m (Maybe String) -ghcPkgHaddockUrl ghcPkg readProc pkgDbStack p = do - gmLog GmDebug "ghcPkgHaddockUrl" $ strDoc p - - let p' = splitPackageName p - - hout <- liftIO $ readProc ghcPkg (toDocDirOpts p' pkgDbStack) "" - return $ Safe.lastMay $ words $ reverse $ dropWhile (== '\n') $ reverse hout - where - -- This fails unless we have --global and --user, unlike - -- pkgDoc elsewhere in ghc-mod. - toDocDirOpts pkg dbs = - [ "field" - , pkg - , "haddock-html" - , "--global" - , "--user" - ] ++ ghcPkgDbStackOpts dbs - -ghcPkgHaddockInterface - :: forall (m :: * -> *). MonadIO m - => FilePath - -> (FilePath -> [String] -> String -> IO String) - -> [GhcPkgDb] - -> String - -> m (Maybe String) -ghcPkgHaddockInterface ghcPkg readProc pkgDbStack p = do - hout <- liftIO $ readProc ghcPkg (toHaskellInterfaces p pkgDbStack) "" - return $ Safe.lastMay $ words $ reverse $ dropWhile (== '\n') $ reverse hout - where - toHaskellInterfaces pkg dbs = - [ "field" - , pkg - , "haddock-interfaces" - , "--global" - , "--user" - ] ++ ghcPkgDbStackOpts dbs - -getVisibleExports - :: forall m. (GhcMonad m, MonadIO m, GmOut m, GmLog m) - => (String -> m (Maybe String)) - -> String - -> m (Maybe (M.Map String [String])) -getVisibleExports getHaddockInterfaces p = do - gmLog GmDebug "getVisibleExports" $ strDoc p - - let p' = splitPackageName p - - haddockInterfaceFile <- getHaddockInterfaces p' - case haddockInterfaceFile of - Just hi -> getVisibleExports' hi - Nothing -> return Nothing - - where - getVisibleExports' :: FilePath -> m (Maybe (M.Map String [String])) - getVisibleExports' ifile = do - iface <- Haddock.readInterfaceFile nameCacheFromGhc ifile - - dflags <- GHC.getSessionDynFlags - - case iface of - Left _ -> throw $ GMEMissingHaddockInterface ifile - Right iface' -> return $ Just $ M.fromList - [ (mname, names) - | ii <- Haddock.ifInstalledIfaces iface' - , let mname = showSDoc dflags $ ppr $ Haddock.instMod ii - names = map (showSDoc dflags . ppr) $ - Haddock.instVisibleExports ii - ] - - -- Derived from haddock-api, see COPYING.BSD3.haddock-api in the source - -- distribution for it's license. - nameCacheFromGhc :: Haddock.NameCacheAccessor m - nameCacheFromGhc = ( read_from_session , write_to_session ) - where - read_from_session = do - ref <- GhcMonad.withSession (return . hsc_NC) - liftIO $ readIORef ref - write_to_session nc' = do - ref <- GhcMonad.withSession (return . hsc_NC) - liftIO $ writeIORef ref nc' - -getModuleExports - :: forall m. (GhcMonad m, GmOut m, GmLog m, IOish m) - => FilePath - -> (FilePath -> [String] -> String -> IO String) - -> [GhcPkgDb] - -> NiceImportDecl - -> m (Maybe ([String], String)) -getModuleExports ghcPkg readProc pkgDbStack m = do - let - handler :: SomeException -> m (Maybe a) - handler e = do - let modDoc = doubleQuotes $ text $ modName m - gmLog GmDebug "getModuleExports" $ - (text "Failed to find module" <> modDoc) <+>: - text (show e) - return Nothing - - minfo <- (findModule (mkModuleName $ modName m) Nothing >>= getModuleInfo) - `gcatch` handler - - p <- pkgFindModule ghcPkg readProc pkgDbStack (modName m) - - dflags <- GHC.getSessionDynFlags - - return $ case (minfo, p) of - (Nothing, _) -> Nothing - (_, "") -> Nothing - (Just minfo', _) -> Just (map (showSDocForUser dflags ghcQualify . ppr) $ modInfoExports minfo', p) - --- * e.g. e.g. "base-4.8.2.0:Data.Foldable.length" -type FullyQualifiedName = String - --- * e.g. "Data.List" -type StrModuleName = String - - -data MySymbol = MySymbolSysQualified String - -- ^ e.g. "base-4.8.2.0:Data.Foldable.length" - | MySymbolUserQualified String - -- ^ e.g. "DL.length" with an import earlier like "import - -- qualified Data.List as DL" - deriving Show - -data ModuleExports = ModuleExports - { mName :: StrModuleName - -- ^ e.g. @"Data.List"@ - , mPackageName :: String - -- ^ e.g. @"snap-0.14.0.6"@ - , mInfo :: NiceImportDecl - -- ^ Our parse of the module import, with info like "hiding (map)". - , qualifiedExports :: [FullyQualifiedName] - -- ^ e.g. - -- @ - -- [ "base-4.8.2.0:GHC.Base.++" - -- , "base-4.8.2.0:GHC.List.filter" - -- , "base-4.8.2.0:GHC.List.zip" - -- , ... - -- ] - -- @ - } deriving Show - -{-# WARNING refineAs "TODO: check if non qualified 'as' imports work correctly" #-} - --- User qualified the symbol, so we can filter out anything that doesn't have a --- matching 'modImportedAs'. -refineAs :: MySymbol -> [ModuleExports] -> [ModuleExports] -refineAs (MySymbolUserQualified userQualSym) exports = filter f exports - where - f ModuleExports { mInfo = NiceImportDecl { modImportedAs = modAs } } = - modAs == moduleOfQualifiedName userQualSym - --- User didn't qualify the symbol, so we have the full system qualified thing, --- so do nothing here. -refineAs (MySymbolSysQualified _) exports = exports - -refineRemoveHiding :: [ModuleExports] -> [ModuleExports] -refineRemoveHiding exports = - map (\e -> e { qualifiedExports = removeHiding e }) exports - where - removeHiding export = filter (`notElem` hiding') thisExports - where hiding = modHiding $ mInfo export :: [String] - -- ^ Things that this module hides. - hiding' = map (qualifyName thisExports) hiding :: [String] - -- ^ Qualified version of hiding. - thisExports = qualifiedExports export - -- ^ Things that this module exports. - - nub' = Set.toList . Set.fromList - - qualifyName :: [QualifiedName] -> String -> QualifiedName - qualifyName qualifiedNames name - = case nub' (filter (postfixMatch' name) qualifiedNames) of - [match] -> match - m -> fail $ "ImportedFrom: could not qualify " - ++ name ++ " from these exports: " - ++ show qualifiedNames ++ "\n matches: " - ++ show m - - postfixMatch' n qn - | n == qn = True - | otherwise = case runRP (f $ reverse n) (reverse qn) of - Left _ -> False - Right () -> True - where - f n = void $ - RP.string n - >> RP.char '.' - >> RP.manyTill nameThenDot (nameThenEnd +++ nameThenEnd') - - - -- Valid chars in a haskell module name: - -- https://www.haskell.org/onlinereport/syntax-iso.html - modChar c = isAlpha c || isDigit c || (c == '\'') - - nameThenEnd = void $ - RP.many1 (RP.satisfy modChar) >> RP.eof - - nameThenEnd' = void $ - RP.many1 (RP.satisfy modChar) - >> RP.char ':' - >> RP.manyTill RP.get RP.eof - >> RP.eof - - nameThenDot = void $ - RP.many1 (RP.satisfy modChar) - >> RP.char '.' - -refineExportsIt :: MySymbol -> [ModuleExports] -> [ModuleExports] -refineExportsIt mysymbol exports = - map (\e -> e { qualifiedExports = f symbol e }) exports - where - -- Deal with these? - symbol = case mysymbol of - MySymbolSysQualified s -> s - MySymbolUserQualified s -> s - - f sym export = filter (postfixMatch sym) thisExports - where - -- * Things that this module exports. - thisExports = qualifiedExports export - - --- On an internal symbol (e.g. Show), refineExportsIt erronously filters out --- everything. For example mnsymbol = "base-4.9.0.0:GHC.Show.C:Show" and the --- matching name "base-4.9.0.0:GHC.Show.Show" from the Prelude. The problem --- seems to be the module name GHC.Show.C, probably referring to an internal C --- library. --- --- To get around this, refineExportsItFallbackInternal uses a less strict --- matching rule. If the 'stage3' results are empty we fall back to this --- refiner. -refineExportsItFallbackInternal :: MySymbol -> [ModuleExports] -> [ModuleExports] -refineExportsItFallbackInternal mysymbol exports - = case splitOn ":" symbol of - [p, _, x] -> map (\e -> e { qualifiedExports = f p x e }) exports - _ -> exports - where - -- Deal with these? - symbol = case mysymbol of - MySymbolSysQualified s -> s - MySymbolUserQualified s -> s - - -- Check if package name matches and postfix symbol matches (roughly). - f p sym export = - filter - (\z -> p `isPrefixOf` z && postfixMatch sym z) - (qualifiedExports export) - -refineLeadingDot :: MySymbol -> [ModuleExports] -> [ModuleExports] -refineLeadingDot (MySymbolUserQualified _) exports = exports -refineLeadingDot (MySymbolSysQualified symb) exports = - map (\e -> e { qualifiedExports = f leadingDot e }) exports - where - -- We use leadingDot only when we have an 'MySymbolSysQualified symb' so - -- the 'last' will be ok. Sample value of 'symb' in this case is - -- "base-4.8.2.0:Data.Foldable.length". - leadingDot :: String - leadingDot = - '.' : Safe.lastNote ("leadingDot: got: " ++ symb) (splitOn "." symb) - - -- f symbol export = filter (symbol ==) thisExports - f symbol export = filter (symbol `isSuffixOf`) thisExports - where thisExports = qualifiedExports export - -refineVisibleExports - :: forall m. (GmGhc m, MonadError GhcModError m, GmOut m, GmLog m, GmEnv m) - => (String -> m (Maybe String)) - -> [ModuleExports] - -> m [ModuleExports] -refineVisibleExports getHaddockInterfaces exports = mapM f exports - where - f :: ModuleExports -> m ModuleExports - f mexports = do - let pname = mPackageName mexports - -- ^ e.g. "base-4.8.2.0" - thisModuleName = mName mexports - -- ^ e.g. "Prelude" - qexports = qualifiedExports mexports - -- ^ e.g. ["base-4.8.2.0:GHC.Base.Just", ...] - - let err = GMEString "ImportedFrom: visible exports map is Nothing" - visibleExportsMap <- - liftMaybe err (getVisibleExports getHaddockInterfaces pname) - - let ppCommaList = foldr (\d e -> (d <> comma) <+> e) mempty - gmLog GmDebug "refineVisibleExports" $ ppCommaList - [ text "Package name" <+>: text pname - , text "Module" <+>: text thisModuleName - ] - gmVomit "refine:visible-exports-map" - (text "visibleExportsMap") (ppShow visibleExportsMap) - - let thisModVisibleExports0 = - M.lookup thisModuleName visibleExportsMap - thisModVisibleExports1 = - M.lookup (pname ++ ":" ++ thisModuleName) visibleExportsMap - - -- On earlier versions of GHC, our qexports list will not be fully - -- qualified, so it will look like ["base:GHC.Base.Just", ...] instead - -- of ["base-4.8.2.0:GHC.Base.Just", ...]. So if thisModVisibleExports0 - -- is Nothing, fall back to searching on a shorter pname. - - thisModVisibleExports <- - case thisModVisibleExports0 `mplus` thisModVisibleExports1 of - Just ve -> return ve - Nothing -> let - pname' = (Safe.headNote ("pname: " ++ pname) $ splitOn "-" pname) - ++ ":" ++ thisModuleName - in - liftMaybe (GMENoVisibleExports thisModuleName pname') $ - return $ M.lookup pname' visibleExportsMap - - let qexports' = filter (hasPostfixMatch thisModVisibleExports) qexports - - gmVomit "visible-exports-map" mempty $ - ppShow (qexports \\ qexports', qexports') - - return $ mexports { qualifiedExports = qexports' } - - -- hasPostfixMatch "base-4.8.2.0:GHC.Base.Just" ["Just", "True", ...] -> True - hasPostfixMatch :: [String] -> String -> Bool - hasPostfixMatch xs s = - Safe.lastNote ("hasPostfixMatch: got: " ++ s) (splitOn "." s) `elem` xs - --- | The last thing with a single export must be the match? Iffy. -getLastMatch :: [ModuleExports] -> Maybe ModuleExports -getLastMatch exports = Safe.lastMay $ filter f exports - where - f me = length (qualifiedExports me) == 1 - --- | Try to look up the Haddock URL for a symbol. -guessHaddockUrl - :: forall m. - (GmGhc m, MonadError GhcModError m, GmOut m, GmLog m, GmEnv m) - => ModSummary - -> FilePath - -> String - -> String - -> Int - -> Int - -> FilePath - -> (FilePath -> [String] -> String -> IO String) - -> [GhcPkgDb] - -> m String -guessHaddockUrl modSum targetFile targetModule symbol lineNr colNr ghcPkg - readProc pkgDbStack = do - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "targetFile: " ++ targetFile - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "targetModule: " ++ targetModule - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "symbol: " ++ show symbol - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "line nr: " ++ show lineNr - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "col nr: " ++ show colNr - - dflags <- GHC.getSessionDynFlags - - let textualImports = ghc_ms_textual_imps modSum - importDecls0 = map (toImportDecl dflags) textualImports - - gmLog GmDebug "guessHaddockUrl" $ - strDoc $ "haskellModuleNames0: " ++ show importDecls0 - - -- If symbol is something like DM.lookup, then restrict importDecls0 to the - -- one that has modImportedAs == Just "DM". - let importDecls1 = filterMatchingQualifiedImport symbol importDecls0 - - -- If that filter left us with nothing, revert back to the original list. - let importDecls2 = if null importDecls1 - then importDecls0 - else importDecls1 - - qnames <- filter (not . (' ' `elem`)) - <$> qualifiedNameAt targetModule lineNr colNr symbol - (map modName importDecls2) :: m [String] - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "qnames: " ++ show qnames - - let symbolToUse :: String - symbolToUse = - case qnames of - (qq:_) -> qq -- We got a qualified name, with qualified - -- printing. Qualified! - [] -> fail $ "ImportedFrom: qnames is empty." - - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "symbolToUse: " ++ symbolToUse - - -- Sometimes we have to load an extra module (using setContext) otherwise we - -- can't look up the global reader environment without causing a GHC panic. - -- For example 'Int' comes from GHC.Types, which is picked up here via the - -- full qualified name. - let parsedPackagesAndQualNames = map (runRP parsePackageAndQualName) qnames - - mkNiceDecl x = - [ NiceImportDecl - { modName = x - , modQualifier = Nothing - , modIsImplicit = False - , modHiding = [] - , modImportedAs = Nothing - , modSpecifically = [] - } - ] - - extraImportDecls :: [NiceImportDecl] - extraImportDecls = case Safe.headMay parsedPackagesAndQualNames of - Just (Right (_, moduleOfQualifiedName -> Just x)) -> mkNiceDecl x - _ -> [] - - importDecls3 = importDecls2 ++ extraImportDecls - - gmLog GmDebug "guessHaddockUrl" $ - strDoc $ "parsedPackagesAndQualNames: " ++ show parsedPackagesAndQualNames - - gmLog GmDebug "guessHaddockUrl" $ - strDoc $ "extraImportDecls: " ++ show extraImportDecls - - exports0 <- mapM (getModuleExports ghcPkg readProc pkgDbStack) importDecls3 - :: m [Maybe ([String], String)] - - -- Sometimes the modules in extraImportDecls might be hidden or weird ones - -- like GHC.Base that we can't load, so filter out the successfully loaded - -- ones. - let successes :: [(NiceImportDecl, Maybe ([String], String))] - successes = filter (isJust . snd) (zip importDecls3 exports0) - - toMaybe :: (NiceImportDecl, Maybe ([FullyQualifiedName], String)) - -> Maybe (NiceImportDecl, ([FullyQualifiedName], String)) - toMaybe (h, Just x) = Just (h, x) - toMaybe (_, Nothing) = Nothing - - successes' :: [(NiceImportDecl, ([String], String))] - successes' = mapMaybe toMaybe successes - - mkExports (m, (e, p)) = - ModuleExports - { mName = modName m - , mPackageName = p - , mInfo = m - , qualifiedExports = e - } - - stage0 = map mkExports successes' - - -- Get all "as" imports. - let asImports :: [String] - asImports = mapMaybe (modImportedAs . mInfo) stage0 - - mySymbol = - case moduleOfQualifiedName symbol of - Nothing -> MySymbolSysQualified symbolToUse - Just x -> - if x `elem` asImports - then MySymbolUserQualified symbol - else MySymbolSysQualified symbolToUse - - gmLog GmDebug "guessHaddockUrl" $ strDoc $ "mySymbol: " ++ show mySymbol - - let pprModuleExports :: ModuleExports -> String - pprModuleExports me = - "(" ++ mName me ++ ", " ++ show (mInfo me) - ++ ", " ++ unwords (map show $ qualifiedExports me) - ++ ")" - - showDebugStage stageNr stage = - forM_ stage $ \x -> - gmLog GmDebug "guessHaddockUrl" $ - strDoc $ stageNr ++ " " ++ pprModuleExports x - - showDebugStage "stage0" stage0 - - let stage1 = refineAs mySymbol stage0 - showDebugStage "stage1" stage1 - - let stage2 = refineRemoveHiding stage1 - showDebugStage "stage2" stage2 - - let stage3 = refineExportsIt mySymbol stage2 - showDebugStage "stage3" stage3 - - let stage4 = if all (null . qualifiedExports) stage3 - then refineExportsItFallbackInternal mySymbol stage2 - else refineLeadingDot mySymbol stage3 - showDebugStage "stage4" stage4 - - stage5 <- refineVisibleExports (ghcPkgHaddockInterface ghcPkg readProc pkgDbStack) stage4 - showDebugStage "stage5" stage5 - - let lastMatch = - Safe.headMay $ catMaybes [getLastMatch stage5, getLastMatch stage4] - - gmLog GmDebug "guessHaddockUrl" $ - strDoc $ show $ "lastMatch: " ++ show lastMatch - - let lastMatchModule :: String - lastMatchModule = - case mName <$> lastMatch of - Just modn -> modn - _ -> fail $ "ImportedFrom: no nice match in lastMatch for module: " ++ show lastMatch - - lastMatchPackageName :: String - lastMatchPackageName = - case mPackageName <$> lastMatch of - Just p -> p - _ -> fail $ "ImportedFrom: no nice match in lastMatch for package name: " ++ show lastMatch - - gmLog GmDebug "guessHaddockUrl" $ - strDoc $ "lastMatchModule: " ++ lastMatchModule - gmLog GmDebug "guessHaddockUrl" $ - strDoc $ "lastMatchPackageName: " ++ lastMatchPackageName - - let err = GMEString $ "ImportedFrom: ghcPkgHaddockUrl failed to find path to HTML file." - haddock <- liftMaybe err $ - ghcPkgHaddockUrl ghcPkg readProc pkgDbStack lastMatchPackageName - - gmLog GmDebug "guessHaddockUrl" $ - strDoc $ "haddock: " ++ show haddock - - let mySymbol' = - case mySymbol of - MySymbolSysQualified s -> s - MySymbolUserQualified s -> s - - let f = haddock (moduleNameToHtmlFile lastMatchModule) - - e <- liftIO $ doesFileExist f - - return $ - if e - then mySymbol' ++ " " ++ lastMatchModule ++ " file://" ++ f - else mySymbol' ++ " " ++ lastMatchModule ++ " " - ++ toHackageUrl f lastMatchPackageName lastMatchModule - - where - -- Convert a module name string, e.g. @Data.List@ to @Data-List.html@. - moduleNameToHtmlFile :: String -> String - moduleNameToHtmlFile m = map f m ++ ".html" - where - f :: Char -> Char - f '.' = '-' - f c = c - - toHackageUrl :: FilePath -> String -> String -> String - toHackageUrl filepath package modulename = - "https://hackage.haskell.org/package/" ++ package ++ "/" - ++ "docs/" ++ modulename'' - where - filepath' = map repl filepath - modulename' = Safe.headNote "modulename1" - $ splitOn "." - $ Safe.headNote "modulename2" $ splitOn "-" modulename - modulename'' = - drop (fromJust $ substringP modulename' filepath') filepath' - - -- On Windows we get backslashes in the file path; convert - -- to forward slashes for the URL. - repl :: Char -> Char - repl '\\' = '/' - repl c = c - - -- Adapted from - -- http://www.haskell.org/pipermail/haskell-cafe/2010-June/078702.html - substringP :: String -> String -> Maybe Int - substringP _ [] = Nothing - substringP sub str = - if sub `isPrefixOf` str - then Just 0 - else fmap (+1) $ substringP sub (Safe.tailNote ("substringP: " ++ str) str) - - filterMatchingQualifiedImport - :: String -> [NiceImportDecl] -> [NiceImportDecl] - filterMatchingQualifiedImport symbol hmodules = - case moduleOfQualifiedName symbol of - Nothing -> [] - asBit@(Just _) -> filter (\z -> asBit == modImportedAs z) hmodules +import Language.Haskell.GhcMod.SrcUtils (listifyStaged, findSpanName, cmp) +import GHC.SYB.Utils +import Data.Function +import Data.Version +import Prelude -- | Look up Haddock docs for a symbol. importedFrom @@ -879,29 +50,56 @@ importedFrom -> Int -- ^ Column number. -> Expression -- ^ Expression (symbol) -> GhcModT m String -importedFrom file lineNr colNr (Expression symbol) = do - ghcPkg <- getGhcPkgProgram - readProc <- gmReadProcess - pkgDbStack <- getPackageDbStack - - ghandle handler $ - runGmlT' [Left file] deferErrors $ - withInteractiveContext $ importedFrom' ghcPkg readProc pkgDbStack - where - handler (SomeException ex) = do - gmLog GmException "imported-from" $ showDoc ex - return $ "imported-from exception: " ++ show ex - - importedFrom' - :: FilePath - -> (FilePath -> [String] -> String -> IO String) - -> [GhcPkgDb] - -> GmlT m String - importedFrom' ghcPkg readProc pkgDbStack = do - crdl <- cradle - modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - let modstr = moduleNameString $ ms_mod_name modSum :: String - - x <- guessHaddockUrl - modSum file modstr symbol lineNr colNr ghcPkg readProc pkgDbStack - return $ x ++ "\n" +importedFrom file lineNr colNr (Expression symbol) = + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withInteractiveContext $ do + crdl <- cradle + modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) + dflag <- getSessionDynFlags + (Just (decls,imports, _exports, _docs)) <- renamedSource <$> (parseModule modSum >>= typecheckModule) + let + ids :: [(SrcSpan, [Name.Name])] + ids = sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) + getVisibleExports (Just (hide, lie)) mi + | hide = modInfoExports mi \\ list + | otherwise = list + where + list = listifyStaged Renamer (const True) lie :: [Name.Name] + getVisibleExports Nothing mi = modInfoExports mi + mods <- mapM ((\ImportDecl{..} -> flip (,) ideclHiding <$> findModule (unLoc ideclName) ideclPkgQual) . unLoc) imports + mis <- mapM (\(x, h) -> ((,) (moduleNameString $ moduleName x) . getVisibleExports h . fromJust) <$> getModuleInfo x) mods + let + outp = nub $ concatMap (mapMaybe f . snd) ids + f :: Name.Name -> Maybe String + f i + | Just modul <- mmodul + , symbol == occn + = let + unitid = modulePackageKey modul + modulname = moduleNameString $ moduleName modul + Just pkg = lookupPackage dflag unitid + haddock = haddockHTMLs pkg + PackageName pkgname' = packageName pkg + pkgname = unpackFS pkgname' + pkgver = showVersion $ packageVersion pkg + in Just . unwords $ + [pkgname ++ "-" ++ pkgver ++ ":" ++ modulname ++ "." ++ occn, intercalate "," impmodul] + ++ concatMap (\x -> map (\y -> x ++ '/' : dotToDash y ++ ".html") impmodul) haddock + | otherwise = Nothing + where + name = getName i + mmodul = nameModule_maybe name + occn = occNameString $ getOccName i + impmodul = map fst $ filter ((name `elem`) . snd) mis + dotToDash = + let + dtd '.' = '-' + dtd x = x + in map dtd + + return $ unlines outp + where + handler (SomeException ex) = do + gmLog GmException "types" $ showDoc ex + return [] diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index 5829fdeb8..7fa989662 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -42,6 +42,26 @@ instance HasType (LPat Id) where ---------------------------------------------------------------- +type SpanNameResult = [(SrcSpan, [G.Name])] +type SpanNameQuery a = a -> SpanNameResult + +findSpanName :: G.HsGroup G.Name -> (Int, Int) -> SpanNameResult +findSpanName tcm lc = + everythingStaged Renamer (++) [] + ([] + `mkQ` (locateName :: SpanNameQuery (G.LHsExpr G.Name)) + `extQ` (locateName :: SpanNameQuery (G.LHsType G.Name)) + `extQ` (locateName :: SpanNameQuery (Located G.Name)) + ) + tcm + where + locateName :: (Typeable a, Data a) => SpanNameQuery (Located a) + locateName (L spn x) + | G.isGoodSrcSpan spn && spn `G.spans` lc + = [(spn, listifyStaged Renamer (const True) x :: [G.Name])] + | otherwise + = [] + -- | Stores mapping from monomorphic to polymorphic types type CstGenQS = M.Map Var Type -- | Generic type to simplify SYB definition From 5e8020818f33ca16b9937f9506f07bc5badb32f4 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sat, 22 Oct 2016 19:09:12 +0300 Subject: [PATCH 17/33] Minor fix to rough sketch for imported-from idea --- Language/Haskell/GhcMod/ImportedFrom.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 56e0f6b55..58d8d2a63 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -67,14 +67,14 @@ importedFrom file lineNr colNr (Expression symbol) = where list = listifyStaged Renamer (const True) lie :: [Name.Name] getVisibleExports Nothing mi = modInfoExports mi - mods <- mapM ((\ImportDecl{..} -> flip (,) ideclHiding <$> findModule (unLoc ideclName) ideclPkgQual) . unLoc) imports - mis <- mapM (\(x, h) -> ((,) (moduleNameString $ moduleName x) . getVisibleExports h . fromJust) <$> getModuleInfo x) mods + mods <- mapM ((\ImportDecl{..} -> (,,) ideclHiding ideclAs <$> findModule (unLoc ideclName) ideclPkgQual) . unLoc) imports + mis <- mapM (\(h, a, x) -> ((,,) (moduleNameString $ moduleName x) (moduleNameString <$> a) . getVisibleExports h . fromJust) <$> getModuleInfo x) mods let outp = nub $ concatMap (mapMaybe f . snd) ids f :: Name.Name -> Maybe String f i | Just modul <- mmodul - , symbol == occn + , symbol `elem` concatMap (qnames occn) impmodul = let unitid = modulePackageKey modul modulname = moduleNameString $ moduleName modul @@ -84,14 +84,18 @@ importedFrom file lineNr colNr (Expression symbol) = pkgname = unpackFS pkgname' pkgver = showVersion $ packageVersion pkg in Just . unwords $ - [pkgname ++ "-" ++ pkgver ++ ":" ++ modulname ++ "." ++ occn, intercalate "," impmodul] - ++ concatMap (\x -> map (\y -> x ++ '/' : dotToDash y ++ ".html") impmodul) haddock + [pkgname ++ "-" ++ pkgver ++ ":" ++ modulname ++ "." ++ occn, intercalate "," (map fst impmodul)] + ++ concatMap (\x -> map ((\y -> x ++ '/' : dotToDash y ++ ".html") . fst) impmodul) haddock | otherwise = Nothing where + qnames occn' (fq, al) = + let al' | Just a <- al = [a++"."++occn'] + | otherwise = [] + in [occn', fq++"."++occn'] ++ al' name = getName i mmodul = nameModule_maybe name occn = occNameString $ getOccName i - impmodul = map fst $ filter ((name `elem`) . snd) mis + impmodul = map (\(x,y,_) -> (x,y)) $ filter (\(_,_,x) -> name `elem` x) mis dotToDash = let dtd '.' = '-' From 7f5e16b4ee823f876c1da60b657e46ec0276d61c Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 23 Oct 2016 14:13:28 +0300 Subject: [PATCH 18/33] Refine imported-from --- Language/Haskell/GhcMod/ImportedFrom.hs | 211 +++++++++++++++++------- src/GHCMod.hs | 2 +- src/GHCMod/Options/Commands.hs | 4 +- 3 files changed, 154 insertions(+), 63 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 58d8d2a63..eeeac79d6 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -1,5 +1,6 @@ -- Copyright (C) 2013-2016 Carlo Hamalainen -- Copyright (C) 2016 Daniel Gröber +-- Copyright (C) 2016 Nikolay Yakimov -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by @@ -13,9 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . - --- {-# OPTIONS_GHC -fwarn-typed-holes -fdefer-type-errors #-} -module Language.Haskell.GhcMod.ImportedFrom {-# WARNING "TODO: remove use of strDoc" #-} (importedFrom) where +module Language.Haskell.GhcMod.ImportedFrom (importedFrom) where import Control.Applicative import Control.Exception @@ -28,7 +27,7 @@ import FastString import GHC import OccName import Packages -import Name +import HscTypes import Language.Haskell.GhcMod import Language.Haskell.GhcMod.DynFlags @@ -41,69 +40,161 @@ import GHC.SYB.Utils import Data.Function import Data.Version import Prelude +import Data.Data +import Safe +import Documentation.Haddock +import Data.IORef +import System.Directory +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe + +data PackageDesc = PackageDesc + { pdName :: String + , pdVersion :: Version + , pdHdHTMLs :: [FilePath] + , pdHdIfaces :: [InstalledInterface] + } + +data ModuleDesc = ModuleDesc + { mdName :: String + , mdMod :: Module + , mdAlias :: Maybe String + , mdVisibleExports :: [Name] + , mdImplicit :: Bool + } + +getPackageDescFromPackageConfig :: (GhcMonad m, MonadIO m) => PackageConfig -> m PackageDesc +getPackageDescFromPackageConfig InstalledPackageInfo{..} + = do + let PackageName packageName' = packageName + his <- catMaybes <$> mapM (fmap (either (const Nothing) Just) . readInterfaceFile') haddockInterfaces + return PackageDesc + { pdName = unpackFS packageName' + , pdVersion = packageVersion + , pdHdHTMLs = haddockHTMLs + , pdHdIfaces = concatMap ifInstalledIfaces his + } + +readInterfaceFile' :: (MonadIO m, GhcMonad m) => FilePath -> m (Either String InterfaceFile) +readInterfaceFile' f = do + exists <- liftIO $ doesFileExist f + if exists + then readInterfaceFile nameCacheFromGhc' f + else return $ Left "No such file" + +-- Derived from haddock-api, see COPYING.BSD3.haddock-api in the source +-- distribution for it's license. +nameCacheFromGhc' :: (GhcMonad m, MonadIO m) => NameCacheAccessor m +nameCacheFromGhc' = ( read_from_session , write_to_session ) + where + read_from_session = liftIO =<< readIORef . hsc_NC <$> getSession + write_to_session nc' = liftIO =<< flip writeIORef nc' . hsc_NC <$> getSession + +getModulePackage :: (GhcMonad m, MonadIO m) => Module -> m (Maybe PackageDesc) +getModulePackage m = do + dflag <- getSessionDynFlags + let pkg = lookupPackage dflag (modulePackageKey m) + mapM getPackageDescFromPackageConfig pkg + +getModuleHaddockVisibleExports :: ModuleDesc -> PackageDesc -> [Name] +getModuleHaddockVisibleExports ModuleDesc{..} pkgdesc = + let modHdIfs = filter ((mdMod ==) . instMod) . pdHdIfaces $ pkgdesc + in concatMap instVisibleExports modHdIfs + +getModuleDescFromImport :: (GhcMonad m, MonadIO m) => ImportDecl Name -> m ModuleDesc +getModuleDescFromImport ImportDecl{..} + = do + modul <- findModule (unLoc ideclName) ideclPkgQual + modInfo <- fromJustNote "imported-from,getModuleDescFromImport" <$> getModuleInfo modul + let listNames :: Data a => a -> [Name] + listNames = listifyStaged Renamer (const True) + exprts = modInfoExports modInfo + visExprts + = case ideclHiding of + Just (True, hidden) -> exprts \\ listNames hidden + Just (False, shown) -> listNames shown + Nothing -> exprts + return ModuleDesc + { mdName = moduleNameString (moduleName modul) + , mdMod = modul + , mdAlias = moduleNameString <$> ideclAs + , mdVisibleExports = visExprts + , mdImplicit = ideclImplicit + } + +modulesWithPackages :: (GhcMonad m, MonadIO m) => [ModuleDesc] -> m [(ModuleDesc, PackageDesc)] +modulesWithPackages = (fmap catMaybes .) $ mapM $ \x@ModuleDesc{..} -> runMaybeT $ do + pkg <- MaybeT $ getModulePackage mdMod + return (x, pkg) + +preferExplicit :: [ModuleDesc] -> [ModuleDesc] +preferExplicit ms = + let (impl, expl) = partition mdImplicit ms + in expl ++ impl + +guessModule :: Maybe String -> Name -> [(ModuleDesc, PackageDesc)] -> Maybe (Name, (ModuleDesc, PackageDesc)) +guessModule mqn n ms = + let + occn = occNameString $ occName n + msf = filter f ms + f = (n `elem`) . uncurry getModuleHaddockVisibleExports + msf2 | null msf = filter f2 ms + | otherwise = msf + f2 (ModuleDesc{..},_) = n `elem` mdVisibleExports + msf3 | Just qn <- mqn + , qn /= occn = filter (f3 qn) msf2 + | otherwise = msf2 + f3 qn (ModuleDesc{..},_) + | Just as <- mdAlias = qn `elem` map (++ '.' : occn) [as, mdName] + | otherwise = qn == (mdName ++ '.' : occn) + in (,) n <$> headMay msf3 + +showOutput :: MonadIO m => Name -> (ModuleDesc, PackageDesc) -> m String +showOutput n (ModuleDesc{..}, PackageDesc{..}) = do + let + occn = occNameString $ occName n + mn = moduleNameString . moduleName $ nameModule n + package = pdName ++ "-" ++ showVersion pdVersion + fqn = package ++ ':' : mn ++ '.' : occn + hdRoot = headMay pdHdHTMLs + docFn = dotsToDashes mdName ++ ".html" + hdPath = fmap ( docFn) hdRoot + dotsToDashes = map go + where go '.' = '-' + go x = x + hackageUrl = "https://hackage.haskell.org/package/" ++ package ++ "/docs/" ++ docFn + hdPathReal <- liftIO $ runMaybeT $ do + hdp <- MaybeT $ return hdPath + exists <- lift $ doesFileExist hdp + if exists + then return hdp + else MaybeT $ return Nothing + return $ unwords [fqn, mdName, fromMaybe hackageUrl hdPathReal] ++ "\n" -- | Look up Haddock docs for a symbol. -importedFrom - :: forall m. IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Expression -- ^ Expression (symbol) - -> GhcModT m String -importedFrom file lineNr colNr (Expression symbol) = +importedFrom :: forall m. IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Maybe Expression -- ^ Expression (symbol) + -> GhcModT m String +importedFrom file lineNr colNr symbol = ghandle handler $ runGmlT' [Left file] deferErrors $ withInteractiveContext $ do crdl <- cradle modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - dflag <- getSessionDynFlags - (Just (decls,imports, _exports, _docs)) <- renamedSource <$> (parseModule modSum >>= typecheckModule) - let - ids :: [(SrcSpan, [Name.Name])] - ids = sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) - getVisibleExports (Just (hide, lie)) mi - | hide = modInfoExports mi \\ list - | otherwise = list - where - list = listifyStaged Renamer (const True) lie :: [Name.Name] - getVisibleExports Nothing mi = modInfoExports mi - mods <- mapM ((\ImportDecl{..} -> (,,) ideclHiding ideclAs <$> findModule (unLoc ideclName) ideclPkgQual) . unLoc) imports - mis <- mapM (\(h, a, x) -> ((,,) (moduleNameString $ moduleName x) (moduleNameString <$> a) . getVisibleExports h . fromJust) <$> getModuleInfo x) mods - let - outp = nub $ concatMap (mapMaybe f . snd) ids - f :: Name.Name -> Maybe String - f i - | Just modul <- mmodul - , symbol `elem` concatMap (qnames occn) impmodul - = let - unitid = modulePackageKey modul - modulname = moduleNameString $ moduleName modul - Just pkg = lookupPackage dflag unitid - haddock = haddockHTMLs pkg - PackageName pkgname' = packageName pkg - pkgname = unpackFS pkgname' - pkgver = showVersion $ packageVersion pkg - in Just . unwords $ - [pkgname ++ "-" ++ pkgver ++ ":" ++ modulname ++ "." ++ occn, intercalate "," (map fst impmodul)] - ++ concatMap (\x -> map ((\y -> x ++ '/' : dotToDash y ++ ".html") . fst) impmodul) haddock - | otherwise = Nothing - where - qnames occn' (fq, al) = - let al' | Just a <- al = [a++"."++occn'] - | otherwise = [] - in [occn', fq++"."++occn'] ++ al' - name = getName i - mmodul = nameModule_maybe name - occn = occNameString $ getOccName i - impmodul = map (\(x,y,_) -> (x,y)) $ filter (\(_,_,x) -> name `elem` x) mis - dotToDash = - let - dtd '.' = '-' - dtd x = x - in map dtd - - return $ unlines outp + (decls,imports, _exports, _docs) <- fromJustNote "imported-from,importedFrom" . renamedSource <$> (parseModule modSum >>= typecheckModule) + importDescs <- mapM (getModuleDescFromImport . unLoc) imports + let bestid = headMay $ concatMap snd $ sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) + idsMods = preferExplicit . (\x -> filter ((x `elem`) . mdVisibleExports) importDescs) <$> bestid + mbsym = getExpression <$> symbol + fmap (fromMaybe "Nothing found\n") $ runMaybeT $ do + imps <- lift . modulesWithPackages =<< MaybeT (return idsMods) + bi <- MaybeT $ return bestid + bg <- MaybeT . return $ guessModule mbsym bi imps + lift $ uncurry showOutput bg where handler (SomeException ex) = do - gmLog GmException "types" $ showDoc ex + gmLog GmException "imported-from" $ showDoc ex return [] diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 936a5da40..28aadce1d 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -151,7 +151,7 @@ ghcCommands (CmdLint opts file) = lint opts file ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms ghcCommands (CmdCheck files) = checkSyntax files ghcCommands (CmdExpand files) = expandTemplate files -ghcCommands (CmdImportedFrom file (line, col) symb) = importedFrom file line col $ Expression symb +ghcCommands (CmdImportedFrom file (line, col) symb) = importedFrom file line col $ fmap Expression symb ghcCommands (CmdInfo file symb) = info file $ Expression symb ghcCommands (CmdType wCon file (line, col)) = types wCon file line col ghcCommands (CmdSplit file (line, col)) = splits file line col diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index c812500de..c1eb396ac 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -50,7 +50,7 @@ data GhcModCommands = | CmdDebugComponent [String] | CmdCheck [FilePath] | CmdExpand [FilePath] - | CmdImportedFrom FilePath Point Expr + | CmdImportedFrom FilePath Point (Maybe Expr) | CmdInfo FilePath Symbol | CmdType Bool FilePath Point | CmdSplit FilePath Point @@ -272,7 +272,7 @@ browseArgSpec = CmdBrowse debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent) checkArgSpec = filesArgsSpec (pure CmdCheck) expandArgSpec = filesArgsSpec (pure CmdExpand) -importedFromArgSpec = locArgSpec (pure CmdImportedFrom) <*> strArg "SYMBOL" +importedFromArgSpec = locArgSpec (pure CmdImportedFrom) <*> optional (strArg "SYMBOL") infoArgSpec = CmdInfo <$> strArg "FILE" <*> strArg "SYMBOL" From 0a56669151323a5ff1bce9666a2aff28301788e6 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 23 Oct 2016 14:27:22 +0300 Subject: [PATCH 19/33] Imported-from spec update --- test/ImportedFromSpec.hs | 35 +++++++++++++---------------------- 1 file changed, 13 insertions(+), 22 deletions(-) diff --git a/test/ImportedFromSpec.hs b/test/ImportedFromSpec.hs index b127a2b34..e8ac02f49 100644 --- a/test/ImportedFromSpec.hs +++ b/test/ImportedFromSpec.hs @@ -1,23 +1,14 @@ {-# LANGUAGE CPP #-} module ImportedFromSpec where -import Control.Applicative import Data.List import Language.Haskell.GhcMod -import System.FilePath import Test.Hspec import TestUtils import Prelude -import Language.Haskell.GhcMod.Utils - --------------------------------------------------- import Language.Haskell.GhcMod.ImportedFrom -import System.FilePath() -import Test.Hspec - -import Control.Exception as E -import System.Directory --------------------------------------------------- spec :: Spec @@ -31,42 +22,42 @@ spec = do -- was giving the contents of the body of the function. This worked -- before??? it "can look up Maybe" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 17 (Expression "Maybe") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 17 (Just (Expression "Maybe")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-Maybe.html") it "can look up Just" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 12 7 (Expression "Just") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 12 7 (Just (Expression "Just")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-Maybe.html") it "can look up Just" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 16 10 (Expression "Just") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 16 10 (Just (Expression "Just")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-Maybe.html") it "can look up String" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 20 14 (Expression "String") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 20 14 (Just (Expression "String")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Prelude.html") it "can look up Int" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 23 (Expression "Int") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 23 (Just (Expression "Int")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Prelude.html") it "can look up DL.length" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 23 5 (Expression "DL.length") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 23 5 (Just (Expression "DL.length")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-List.html") it "can look up print" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 25 8 (Expression "print") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 25 8 (Just (Expression "print")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Prelude.html") it "can look up DM.fromList" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 27 5 (Expression "DM.fromList") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 27 5 (Just (Expression "DM.fromList")) res `shouldSatisfy` (isInfixOf "containers-") res `shouldSatisfy` (isInfixOf "Data-Map.html") @@ -76,26 +67,26 @@ spec = do -- --it "can look up Safe.headMay" $ do -- withDirectory_ "test/data/imported-from" $ do - -- (res, _) <- runGmOutDef $ runGhcModT defaultOptions $ importedFrom "ImportedFrom01.hs" 29 6 (Expression "Safe.headMay") + -- (res, _) <- runGmOutDef $ runGhcModT defaultOptions $ importedFrom "ImportedFrom01.hs" 29 6 (Just (Expression "Safe.headMay")) -- res `shouldSatisfy` isRight it "can look up Foo.Bar.length" $ do - res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 34 17 (Expression "Foo.Bar.length") + res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 34 17 (Just (Expression "Foo.Bar.length")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Data-List.html") -- These from Safe also fail. Why? --it "can look up map" $ do - -- res <- runD' tdir $ importedFrom "ImportedFrom02.hs" 14 5 (Expression "map") + -- res <- runD' tdir $ importedFrom "ImportedFrom02.hs" 14 5 (Just (Expression "map")) -- res `shouldSatisfy` (isInfixOf "000") -- res `shouldSatisfy` (isInfixOf "111") --it "can look up head" $ do - -- res <- runD' tdir $ importedFrom "ImportedFrom02.hs" 16 5 (Expression "head") + -- res <- runD' tdir $ importedFrom "ImportedFrom02.hs" 16 5 (Just (Expression "head")) -- res `shouldSatisfy` (isInfixOf "000") -- res `shouldSatisfy` (isInfixOf "111") it "can look up when" $ do - res <- runD' tdir $ importedFrom "ImportedFrom03.hs" 15 5 (Expression "when") + res <- runD' tdir $ importedFrom "ImportedFrom03.hs" 15 5 (Just (Expression "when")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Control-Monad.html") From 9752899349cefbdc90b0490b70877a921c9c2368 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Mon, 24 Oct 2016 00:31:47 +0300 Subject: [PATCH 20/33] [imported-from] Show originating package name --- Language/Haskell/GhcMod/ImportedFrom.hs | 13 ++++++++----- test/ImportedFromSpec.hs | 1 + 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index eeeac79d6..74391aaf2 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -149,14 +149,17 @@ guessModule mqn n ms = | otherwise = qn == (mdName ++ '.' : occn) in (,) n <$> headMay msf3 -showOutput :: MonadIO m => Name -> (ModuleDesc, PackageDesc) -> m String -showOutput n (ModuleDesc{..}, PackageDesc{..}) = do +showOutput :: (GhcMonad m, MonadIO m) => Name -> (ModuleDesc, PackageDesc) -> m String +showOutput n (ModuleDesc{..}, imppkg) = do let occn = occNameString $ occName n - mn = moduleNameString . moduleName $ nameModule n - package = pdName ++ "-" ++ showVersion pdVersion + nmod = nameModule n + mn = moduleNameString . moduleName $ nmod + modpkg <- fromMaybe imppkg <$> getModulePackage nmod + let + package = pdName modpkg ++ "-" ++ showVersion (pdVersion modpkg) fqn = package ++ ':' : mn ++ '.' : occn - hdRoot = headMay pdHdHTMLs + hdRoot = headMay $ pdHdHTMLs imppkg docFn = dotsToDashes mdName ++ ".html" hdPath = fmap ( docFn) hdRoot dotsToDashes = map go diff --git a/test/ImportedFromSpec.hs b/test/ImportedFromSpec.hs index e8ac02f49..385889e2b 100644 --- a/test/ImportedFromSpec.hs +++ b/test/ImportedFromSpec.hs @@ -45,6 +45,7 @@ spec = do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 23 (Just (Expression "Int")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Prelude.html") + res `shouldSatisfy` (isInfixOf "ghc-prim-") it "can look up DL.length" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 23 5 (Just (Expression "DL.length")) From ccf5847c97a1df3574013e38acaea39324e72d8a Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Mon, 24 Oct 2016 01:08:06 +0300 Subject: [PATCH 21/33] [imported-from] ghc8 compat --- Language/Haskell/GhcMod/Gap.hs | 47 ++++++------------------- Language/Haskell/GhcMod/ImportedFrom.hs | 6 ++-- 2 files changed, 14 insertions(+), 39 deletions(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 95f052f8e..70b8543ce 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -48,10 +48,8 @@ module Language.Haskell.GhcMod.Gap ( , mkErrStyle' , everythingStagedWithContext , withCleanupSession - , ghcQualify - , ghcIdeclHiding - , ghc_sl_fs - , ghc_ms_textual_imps + , moduleUnitId' + , sl_fs' ) where import Control.Applicative hiding (empty) @@ -698,42 +696,19 @@ withCleanupSession action = do -- | Things for Language.Haskell.GhcMod.ImportedFrom -#if __GLASGOW_HASKELL__ >= 710 -ghcQualify :: PrintUnqualified -ghcQualify = reallyAlwaysQualify -#else -ghcQualify :: PrintUnqualified -ghcQualify = alwaysQualify -#endif - -#if __GLASGOW_HASKELL__ >= 710 -ghcIdeclHiding :: GHC.ImportDecl GHC.RdrName -> Maybe (Bool, SrcLoc.Located [GHC.LIE GHC.RdrName]) -ghcIdeclHiding = GHC.ideclHiding -#else --- Here, we have --- --- ideclHiding :: Maybe (Bool, [LIE name]) --- --- so we have to use noLoc to get a SrcLoc.Located type in the second part of the tuple. -ghcIdeclHiding :: GHC.ImportDecl GHC.RdrName -> Maybe (Bool, SrcLoc.Located [GHC.LIE GHC.RdrName]) -ghcIdeclHiding x = case GHC.ideclHiding x of - Just (b, lie) -> Just (b, GHC.noLoc lie) - Nothing -> Nothing - -#endif - #if __GLASGOW_HASKELL__ >= 800 -ghc_sl_fs :: StringLiteral -> FastString -ghc_sl_fs = sl_fs +moduleUnitId' :: Module -> UnitId +moduleUnitId' = GHC.moduleUnitId +#elif __GLASGOW_HASKELL__ >= 710 +moduleUnitId' = GHC.modulePackageKey #else -ghc_sl_fs = id +moduleUnitId' = GHC.modulePackageId #endif - -ghc_ms_textual_imps :: GHC.ModSummary -> [Located (ImportDecl RdrName)] #if __GLASGOW_HASKELL__ >= 800 --- What does GHC8 give in the first part of the tuple? -ghc_ms_textual_imps ms = map (fmap simpleImportDecl . snd) (ms_textual_imps ms) +sl_fs' :: StringLiteral -> FastString +sl_fs' = sl_fs #else -ghc_ms_textual_imps = ms_textual_imps +sl_fs' :: FastString -> FastString +sl_fs' = id #endif diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 74391aaf2..c2249c5f1 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -93,7 +93,7 @@ nameCacheFromGhc' = ( read_from_session , write_to_session ) getModulePackage :: (GhcMonad m, MonadIO m) => Module -> m (Maybe PackageDesc) getModulePackage m = do dflag <- getSessionDynFlags - let pkg = lookupPackage dflag (modulePackageKey m) + let pkg = lookupPackage dflag (moduleUnitId' m) mapM getPackageDescFromPackageConfig pkg getModuleHaddockVisibleExports :: ModuleDesc -> PackageDesc -> [Name] @@ -101,10 +101,10 @@ getModuleHaddockVisibleExports ModuleDesc{..} pkgdesc = let modHdIfs = filter ((mdMod ==) . instMod) . pdHdIfaces $ pkgdesc in concatMap instVisibleExports modHdIfs -getModuleDescFromImport :: (GhcMonad m, MonadIO m) => ImportDecl Name -> m ModuleDesc +getModuleDescFromImport :: (GhcMonad m) => ImportDecl Name -> m ModuleDesc getModuleDescFromImport ImportDecl{..} = do - modul <- findModule (unLoc ideclName) ideclPkgQual + modul <- findModule (unLoc ideclName) (fmap sl_fs' ideclPkgQual) modInfo <- fromJustNote "imported-from,getModuleDescFromImport" <$> getModuleInfo modul let listNames :: Data a => a -> [Name] listNames = listifyStaged Renamer (const True) From 886e466c8a496e5672fbf5b869437101fee777f9 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Mon, 24 Oct 2016 01:38:42 +0300 Subject: [PATCH 22/33] [imported-from] ghc-7.8 compat --- Language/Haskell/GhcMod/Gap.hs | 26 +++++++++++++++++++++++++ Language/Haskell/GhcMod/ImportedFrom.hs | 13 +++++++------ 2 files changed, 33 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 70b8543ce..a148e33e2 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -50,6 +50,8 @@ module Language.Haskell.GhcMod.Gap ( , withCleanupSession , moduleUnitId' , sl_fs' + , packageNameVesrion + , lookupPackage' ) where import Control.Applicative hiding (empty) @@ -109,6 +111,8 @@ import RdrName (rdrNameOcc) #if __GLASGOW_HASKELL__ < 710 import UniqFM (eltsUFM) import Module +import Data.Generics.Schemes (gfindtype) +import Safe #endif #if __GLASGOW_HASKELL__ >= 704 @@ -702,6 +706,7 @@ moduleUnitId' = GHC.moduleUnitId #elif __GLASGOW_HASKELL__ >= 710 moduleUnitId' = GHC.modulePackageKey #else +moduleUnitId' :: Module -> PackageId moduleUnitId' = GHC.modulePackageId #endif @@ -712,3 +717,24 @@ sl_fs' = sl_fs sl_fs' :: FastString -> FastString sl_fs' = id #endif + + +#if __GLASGOW_HASKELL__ >= 710 +packageNameVesrion :: PackageConfig -> (String, Version) +packageNameVesrion + InstalledPackageInfo{packageName=PackageName pn, packageVersion=pv} + = (unpackFS pn, pv) +#else +packageNameVesrion :: PackageConfig -> (String, Version) +packageNameVesrion + InstalledPackageInfo{sourcePackageId=PackageIdentifier{pkgName=pn, pkgVersion=pv}} + = (fromJustNote "Gap,packageNameVersion" (gfindtype pn), pv) +#endif + +#if __GLASGOW_HASKELL__ >= 710 +lookupPackage' :: DynFlags -> a -> Maybe PackageConfig +lookupPackage' = lookupPackage +#else +lookupPackage' :: DynFlags -> PackageId -> Maybe PackageConfig +lookupPackage' = lookupPackage . pkgIdMap . pkgState +#endif diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index c2249c5f1..1ada610a4 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -39,7 +39,8 @@ import Language.Haskell.GhcMod.SrcUtils (listifyStaged, findSpanName, cmp) import GHC.SYB.Utils import Data.Function import Data.Version -import Prelude +import Data.Traversable +import Prelude hiding (mapM) import Data.Data import Safe import Documentation.Haddock @@ -64,13 +65,13 @@ data ModuleDesc = ModuleDesc } getPackageDescFromPackageConfig :: (GhcMonad m, MonadIO m) => PackageConfig -> m PackageDesc -getPackageDescFromPackageConfig InstalledPackageInfo{..} +getPackageDescFromPackageConfig p@InstalledPackageInfo{..} = do - let PackageName packageName' = packageName + let (pkgName, pkgVer) = packageNameVesrion p his <- catMaybes <$> mapM (fmap (either (const Nothing) Just) . readInterfaceFile') haddockInterfaces return PackageDesc - { pdName = unpackFS packageName' - , pdVersion = packageVersion + { pdName = pkgName + , pdVersion = pkgVer , pdHdHTMLs = haddockHTMLs , pdHdIfaces = concatMap ifInstalledIfaces his } @@ -93,7 +94,7 @@ nameCacheFromGhc' = ( read_from_session , write_to_session ) getModulePackage :: (GhcMonad m, MonadIO m) => Module -> m (Maybe PackageDesc) getModulePackage m = do dflag <- getSessionDynFlags - let pkg = lookupPackage dflag (moduleUnitId' m) + let pkg = lookupPackage' dflag (moduleUnitId' m) mapM getPackageDescFromPackageConfig pkg getModuleHaddockVisibleExports :: ModuleDesc -> PackageDesc -> [Name] From 2e93d4fb0a99925ccc78801b3a6ee6e40fc3a5b6 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Mon, 24 Oct 2016 01:42:04 +0300 Subject: [PATCH 23/33] [imported-from] compat cleanup --- Language/Haskell/GhcMod/Gap.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index a148e33e2..f4f65676b 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -704,6 +704,7 @@ withCleanupSession action = do moduleUnitId' :: Module -> UnitId moduleUnitId' = GHC.moduleUnitId #elif __GLASGOW_HASKELL__ >= 710 +moduleUnitId' :: Module -> PackageKey moduleUnitId' = GHC.modulePackageKey #else moduleUnitId' :: Module -> PackageId @@ -732,7 +733,11 @@ packageNameVesrion #endif #if __GLASGOW_HASKELL__ >= 710 -lookupPackage' :: DynFlags -> a -> Maybe PackageConfig +#if __GLASGOW_HASKELL__ >= 800 +lookupPackage' :: DynFlags -> UnitId -> Maybe PackageConfig +#else +lookupPackage' :: DynFlags -> PackageKey -> Maybe PackageConfig +#endif lookupPackage' = lookupPackage #else lookupPackage' :: DynFlags -> PackageId -> Maybe PackageConfig From 09e747e50cd989f1a49ed95fdca4558bd2581df5 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Mon, 24 Oct 2016 01:50:43 +0300 Subject: [PATCH 24/33] [imported-from] comment on `gfindtype` in Gap (ghc 7.8 compat) --- Language/Haskell/GhcMod/Gap.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index f4f65676b..4da71ab85 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -729,6 +729,8 @@ packageNameVesrion packageNameVesrion :: PackageConfig -> (String, Version) packageNameVesrion InstalledPackageInfo{sourcePackageId=PackageIdentifier{pkgName=pn, pkgVersion=pv}} + -- here, pkgName is `Distribution.Package.PackageName String` from Cabal + -- using gfindtype to avoid dependence on Cabal-1.18.1.5 = (fromJustNote "Gap,packageNameVersion" (gfindtype pn), pv) #endif From 18e59e83280ce37cc9d7a35de082a9e6de04c6c1 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Mon, 24 Oct 2016 23:44:54 +0300 Subject: [PATCH 25/33] [imported-from] Clean `findSpanName` --- Language/Haskell/GhcMod/SrcUtils.hs | 37 ++++++++++++++++------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index 7fa989662..fd5f70331 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -42,25 +42,28 @@ instance HasType (LPat Id) where ---------------------------------------------------------------- -type SpanNameResult = [(SrcSpan, [G.Name])] -type SpanNameQuery a = a -> SpanNameResult - -findSpanName :: G.HsGroup G.Name -> (Int, Int) -> SpanNameResult +-- | Like `mkQ`, but matches on 2-parameter polymorphic type instead of a +-- monomorphic one. +-- +-- Idea shamelessly stolen from SPJ's talk on generic function extension +-- from Oxford's Workshop on Datatype-Generic programming (2004) +-- http://www.cs.ox.ac.uk/research/pdt/ap/dgp/workshop2004/ +mkQ2 :: (Data a, Typeable t) => r -> (forall b c. (Data b, Data c) => t b c -> r) -> a -> r +mkQ2 gen spec x = maybe gen (($ x) . unQ) $ dataCast2 (Q spec) +newtype Q r a = Q { unQ :: a -> r } + +findSpanName :: G.HsGroup G.Name -> (Int, Int) -> [(SrcSpan, [G.Name])] findSpanName tcm lc = - everythingStaged Renamer (++) [] - ([] - `mkQ` (locateName :: SpanNameQuery (G.LHsExpr G.Name)) - `extQ` (locateName :: SpanNameQuery (G.LHsType G.Name)) - `extQ` (locateName :: SpanNameQuery (Located G.Name)) - ) - tcm + everythingStaged Renamer (++) [] ([] `mkQ2` locateName) tcm where - locateName :: (Typeable a, Data a) => SpanNameQuery (Located a) - locateName (L spn x) - | G.isGoodSrcSpan spn && spn `G.spans` lc - = [(spn, listifyStaged Renamer (const True) x :: [G.Name])] - | otherwise - = [] + locateName :: (Data a, Data b) => GenLocated a b -> [(SrcSpan, [G.Name])] + locateName (L spn' x) + | Just spn <- cast spn' + , G.isGoodSrcSpan spn && spn `G.spans` lc + , names <- listifyStaged Renamer (const True) x + , not (null names) + = [(spn, names)] + | otherwise = [] -- | Stores mapping from monomorphic to polymorphic types type CstGenQS = M.Map Var Type From d04522dd500525913a6f710648fe142e208e4da5 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 25 Oct 2016 00:00:35 +0300 Subject: [PATCH 26/33] [imported-from] Allow outputting several names Case when this is relevant: consider a query for source point like this: something other ^--- queryed here Which one do we choose, former or latter? I would argue we choose both and let the client decide. --- Language/Haskell/GhcMod/ImportedFrom.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 1ada610a4..203d29c72 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -18,6 +18,7 @@ module Language.Haskell.GhcMod.ImportedFrom (importedFrom) where import Control.Applicative import Control.Exception +import Control.Monad (zipWithM) import Data.List import Data.Maybe import System.FilePath @@ -173,7 +174,7 @@ showOutput n (ModuleDesc{..}, imppkg) = do if exists then return hdp else MaybeT $ return Nothing - return $ unwords [fqn, mdName, fromMaybe hackageUrl hdPathReal] ++ "\n" + return $ unwords [fqn, mdName, fromMaybe hackageUrl hdPathReal] -- | Look up Haddock docs for a symbol. importedFrom :: forall m. IOish m @@ -190,14 +191,14 @@ importedFrom file lineNr colNr symbol = modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) (decls,imports, _exports, _docs) <- fromJustNote "imported-from,importedFrom" . renamedSource <$> (parseModule modSum >>= typecheckModule) importDescs <- mapM (getModuleDescFromImport . unLoc) imports - let bestid = headMay $ concatMap snd $ sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) - idsMods = preferExplicit . (\x -> filter ((x `elem`) . mdVisibleExports) importDescs) <$> bestid + let bestids = fmap snd $ headMay $ sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) + idsMods = map (preferExplicit . (\x -> filter ((x `elem`) . mdVisibleExports) importDescs)) <$> bestids mbsym = getExpression <$> symbol - fmap (fromMaybe "Nothing found\n") $ runMaybeT $ do - imps <- lift . modulesWithPackages =<< MaybeT (return idsMods) - bi <- MaybeT $ return bestid - bg <- MaybeT . return $ guessModule mbsym bi imps - lift $ uncurry showOutput bg + fmap (maybe "Nothing found\n" unlines) $ runMaybeT $ do + imps <- lift . mapM modulesWithPackages =<< MaybeT (return idsMods) + bi <- MaybeT $ return bestids + bg <- MaybeT . return $ zipWithM (guessModule mbsym) bi imps + lift $ mapM (uncurry showOutput) bg where handler (SomeException ex) = do gmLog GmException "imported-from" $ showDoc ex From 1032e600b5939e9228ed7a8f4f2a178eb1ace0f9 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 25 Oct 2016 00:01:01 +0300 Subject: [PATCH 27/33] [imported-from] Remove redundant import --- Language/Haskell/GhcMod/ImportedFrom.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 203d29c72..9d522d2b2 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -24,7 +24,6 @@ import Data.Maybe import System.FilePath import Exception (ghandle) -import FastString import GHC import OccName import Packages From 477c3e578f0330cd47c39f034273ea36f2a19a7f Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 25 Oct 2016 00:42:04 +0300 Subject: [PATCH 28/33] [imported-from] Fix some things with `showOutput` Apparently, ghc 7.8 can be picky when to give you a package version. It can return just empty version for wired-in packages like base, etc. So I suppose we have to guess those from haddock file path if we can... --- Language/Haskell/GhcMod/ImportedFrom.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 9d522d2b2..8c931b414 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -158,8 +158,16 @@ showOutput n (ModuleDesc{..}, imppkg) = do mn = moduleNameString . moduleName $ nmod modpkg <- fromMaybe imppkg <$> getModulePackage nmod let - package = pdName modpkg ++ "-" ++ showVersion (pdVersion modpkg) - fqn = package ++ ':' : mn ++ '.' : occn + modpackage + | null (versionBranch modpackagever) = pdName modpkg + | otherwise = pdName modpkg ++ '-' : showVersion modpackagever + modpackagever = pdVersion modpkg + package + | null (versionBranch packagever) + , Just r <- hdRoot = takeFileName r + | otherwise = pdName imppkg ++ '-' : showVersion packagever + packagever = pdVersion imppkg + fqn = modpackage ++ ':' : mn ++ '.' : occn hdRoot = headMay $ pdHdHTMLs imppkg docFn = dotsToDashes mdName ++ ".html" hdPath = fmap ( docFn) hdRoot From eb8e4021838f05e84d64ab438ff25084306c1831 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 25 Oct 2016 00:58:34 +0300 Subject: [PATCH 29/33] [imported-from] Fix broken test --- test/ImportedFromSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/ImportedFromSpec.hs b/test/ImportedFromSpec.hs index 385889e2b..584f9ab06 100644 --- a/test/ImportedFromSpec.hs +++ b/test/ImportedFromSpec.hs @@ -45,7 +45,7 @@ spec = do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 22 23 (Just (Expression "Int")) res `shouldSatisfy` (\x -> "base-" `isInfixOf` x || "haskell98-" `isInfixOf` x || "haskell2010-" `isInfixOf` x) res `shouldSatisfy` (isInfixOf "Prelude.html") - res `shouldSatisfy` (isInfixOf "ghc-prim-") + res `shouldSatisfy` (isPrefixOf "ghc-prim") it "can look up DL.length" $ do res <- runD' tdir $ importedFrom "ImportedFrom01.hs" 23 5 (Just (Expression "DL.length")) From 87390ee6e9e32156e64d0994be92f34b773cdc44 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 25 Oct 2016 21:06:59 +0300 Subject: [PATCH 30/33] [imported-from] Removed unused definitions --- Language/Haskell/GhcMod/Error.hs | 22 +--------------------- Language/Haskell/GhcMod/PkgDoc.hs | 20 ++++---------------- Language/Haskell/GhcMod/Types.hs | 6 ------ 3 files changed, 5 insertions(+), 43 deletions(-) diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 8e170966f..4ec373c28 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -80,6 +80,7 @@ gmeDoc e = case e of \ Try enabling them:" $$ nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]") + backticks d = char '`' <> d <> char '`' ctxDoc = moduleDoc *** compsDoc >>> first (<> colon) >>> uncurry (flip hang 4) @@ -103,27 +104,6 @@ gmeDoc e = case e of GMETooManyCabalFiles cfs -> text $ "Multiple cabal files found. Possible cabal files: \"" ++ intercalate "\", \"" cfs ++"\"." - GMEMissingHaddockInterface f -> - text ("Haddock interface file missing: " ++ f) $$ - text "" $$ - haddockSuggestion - GMENoVisibleExports moduleName package -> - text $ "Failed to find visible exports of \"" ++ moduleName ++ "\" in \"" ++ package ++ "\"" - - where - - backticks d = char '`' <> d <> char '`' - - haddockSuggestion = - text "- To generate Haddock docs for dependencies, try:" $$ - nest 4 (backticks $ text "cabal install --enable-documentation --haddock-hyperlink-source --only-dependencies") $$ - text "" $$ - text "- or set" $$ - nest 4 (backticks $ text "documentation: True") $$ - text "in ~/.cabal/config" $$ - text "" $$ - text "- or with Stack:" $$ - nest 4 (backticks $ text "stack haddock") ghcExceptionDoc :: GhcException -> Doc ghcExceptionDoc e@(CmdLineError _) = diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index 82d1ab484..6ec5d0d00 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -1,4 +1,4 @@ -module Language.Haskell.GhcMod.PkgDoc (pkgDoc, pkgFindModule) where +module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg @@ -14,28 +14,16 @@ pkgDoc mdl = do ghcPkg <- getGhcPkgProgram readProc <- gmReadProcess pkgDbStack <- getPackageDbStack - pkg <- pkgFindModule ghcPkg readProc pkgDbStack mdl - + pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) "" if pkg == "" then return "\n" else do htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) "" let ret = pkg ++ " " ++ drop 14 htmlpath return ret - where - toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"] - ++ ghcPkgDbStackOpts dbs - -pkgFindModule - :: IOish m - => FilePath - -> (FilePath -> [String] -> String -> IO String) - -> [GhcPkgDb] - -> String - -> m String -pkgFindModule ghcPkg readProc pkgDbStack mdl = - liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) "" where toModuleOpts dbs = ["find-module", mdl, "--simple-output"] ++ ghcPkgDbStackOpts dbs + toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"] + ++ ghcPkgDbStackOpts dbs trim = takeWhile (`notElem` " \n") diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index bb58345c9..2be44cc37 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -352,12 +352,6 @@ data GhcModError | GMETooManyCabalFiles [FilePath] -- ^ Too many cabal files found. - | GMEMissingHaddockInterface FilePath - -- ^ Haddock interface file missing. - - | GMENoVisibleExports String String - -- ^ Failed to find visible exports of module in given package. - deriving (Eq,Show,Typeable) instance Error GhcModError where From f5e911b0d5fe3f7c7cfedd7c348ce7e25e77594c Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 25 Oct 2016 21:37:18 +0300 Subject: [PATCH 31/33] [imported-from] Print a warning when can't find haddock interface --- Language/Haskell/GhcMod/ImportedFrom.hs | 27 +++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 8c931b414..7607e9397 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -64,7 +64,7 @@ data ModuleDesc = ModuleDesc , mdImplicit :: Bool } -getPackageDescFromPackageConfig :: (GhcMonad m, MonadIO m) => PackageConfig -> m PackageDesc +getPackageDescFromPackageConfig :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) => PackageConfig -> m PackageDesc getPackageDescFromPackageConfig p@InstalledPackageInfo{..} = do let (pkgName, pkgVer) = packageNameVesrion p @@ -76,12 +76,27 @@ getPackageDescFromPackageConfig p@InstalledPackageInfo{..} , pdHdIfaces = concatMap ifInstalledIfaces his } -readInterfaceFile' :: (MonadIO m, GhcMonad m) => FilePath -> m (Either String InterfaceFile) +readInterfaceFile' :: (GmOut m, GmLog m, MonadIO m, GhcMonad m) => FilePath -> m (Either String InterfaceFile) readInterfaceFile' f = do exists <- liftIO $ doesFileExist f if exists then readInterfaceFile nameCacheFromGhc' f - else return $ Left "No such file" + else do + gmLog GmWarning "imported-from" haddockSuggestion + return $ Left "No such file" + where + backticks d = char '`' <> d <> char '`' + haddockSuggestion = + text "Couldn't find haddock interface" <+> quotes (text f) $$ + text "- To generate Haddock docs for dependencies, try:" $$ + nest 4 (backticks $ text "cabal install --enable-documentation --haddock-hyperlink-source --only-dependencies") $$ + text "" $$ + text "- or set" $$ + nest 4 (backticks $ text "documentation: True") $$ + text "in ~/.cabal/config" $$ + text "" $$ + text "- or with Stack:" $$ + nest 4 (backticks $ text "stack haddock") -- Derived from haddock-api, see COPYING.BSD3.haddock-api in the source -- distribution for it's license. @@ -91,7 +106,7 @@ nameCacheFromGhc' = ( read_from_session , write_to_session ) read_from_session = liftIO =<< readIORef . hsc_NC <$> getSession write_to_session nc' = liftIO =<< flip writeIORef nc' . hsc_NC <$> getSession -getModulePackage :: (GhcMonad m, MonadIO m) => Module -> m (Maybe PackageDesc) +getModulePackage :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) => Module -> m (Maybe PackageDesc) getModulePackage m = do dflag <- getSessionDynFlags let pkg = lookupPackage' dflag (moduleUnitId' m) @@ -123,7 +138,7 @@ getModuleDescFromImport ImportDecl{..} , mdImplicit = ideclImplicit } -modulesWithPackages :: (GhcMonad m, MonadIO m) => [ModuleDesc] -> m [(ModuleDesc, PackageDesc)] +modulesWithPackages :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) => [ModuleDesc] -> m [(ModuleDesc, PackageDesc)] modulesWithPackages = (fmap catMaybes .) $ mapM $ \x@ModuleDesc{..} -> runMaybeT $ do pkg <- MaybeT $ getModulePackage mdMod return (x, pkg) @@ -150,7 +165,7 @@ guessModule mqn n ms = | otherwise = qn == (mdName ++ '.' : occn) in (,) n <$> headMay msf3 -showOutput :: (GhcMonad m, MonadIO m) => Name -> (ModuleDesc, PackageDesc) -> m String +showOutput :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) => Name -> (ModuleDesc, PackageDesc) -> m String showOutput n (ModuleDesc{..}, imppkg) = do let occn = occNameString $ occName n From f7f4fd85c5b92d0eb54fd26ea9d31696c4e9d0dc Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 25 Oct 2016 23:07:31 +0300 Subject: [PATCH 32/33] [imported-from] Add some minimal error reporting --- Language/Haskell/GhcMod/ImportedFrom.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 7607e9397..7f89ca729 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -18,7 +18,6 @@ module Language.Haskell.GhcMod.ImportedFrom (importedFrom) where import Control.Applicative import Control.Exception -import Control.Monad (zipWithM) import Data.List import Data.Maybe import System.FilePath @@ -213,14 +212,19 @@ importedFrom file lineNr colNr symbol = modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) (decls,imports, _exports, _docs) <- fromJustNote "imported-from,importedFrom" . renamedSource <$> (parseModule modSum >>= typecheckModule) importDescs <- mapM (getModuleDescFromImport . unLoc) imports - let bestids = fmap snd $ headMay $ sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) - idsMods = map (preferExplicit . (\x -> filter ((x `elem`) . mdVisibleExports) importDescs)) <$> bestids + bestids <- + case fmap snd $ headMay $ sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) of + Just x -> return x + Nothing -> error $ "No names found at " ++ show (lineNr, colNr) + let idsMods = map (preferExplicit . (\x -> filter ((x `elem`) . mdVisibleExports) importDescs)) bestids mbsym = getExpression <$> symbol - fmap (maybe "Nothing found\n" unlines) $ runMaybeT $ do - imps <- lift . mapM modulesWithPackages =<< MaybeT (return idsMods) - bi <- MaybeT $ return bestids - bg <- MaybeT . return $ zipWithM (guessModule mbsym) bi imps - lift $ mapM (uncurry showOutput) bg + imps <- mapM modulesWithPackages idsMods + bg <- + case catMaybes $ zipWith (guessModule mbsym) bestids imps of + [] -> error $ "No modules exporting " + ++ fromMaybe (intercalate "," (map (occNameString . getOccName) bestids)) mbsym + x -> return x + unlines <$> mapM (uncurry showOutput) bg where handler (SomeException ex) = do gmLog GmException "imported-from" $ showDoc ex From 87808c9832c0b69b18c26906d0aeb06e9d174109 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 26 Oct 2016 19:30:40 +0200 Subject: [PATCH 33/33] imported-from: code style cleanup --- Language/Haskell/GhcMod/ImportedFrom.hs | 181 +++++++++++++----------- 1 file changed, 95 insertions(+), 86 deletions(-) diff --git a/Language/Haskell/GhcMod/ImportedFrom.hs b/Language/Haskell/GhcMod/ImportedFrom.hs index 7f89ca729..6d4929744 100644 --- a/Language/Haskell/GhcMod/ImportedFrom.hs +++ b/Language/Haskell/GhcMod/ImportedFrom.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . + module Language.Haskell.GhcMod.ImportedFrom (importedFrom) where import Control.Applicative @@ -63,11 +64,12 @@ data ModuleDesc = ModuleDesc , mdImplicit :: Bool } -getPackageDescFromPackageConfig :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) => PackageConfig -> m PackageDesc +getPackageDescFromPackageConfig :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) + => PackageConfig -> m PackageDesc getPackageDescFromPackageConfig p@InstalledPackageInfo{..} = do let (pkgName, pkgVer) = packageNameVesrion p - his <- catMaybes <$> mapM (fmap (either (const Nothing) Just) . readInterfaceFile') haddockInterfaces + his <- catMaybes <$> mapM readInterfaceFile' haddockInterfaces return PackageDesc { pdName = pkgName , pdVersion = pkgVer @@ -75,20 +77,23 @@ getPackageDescFromPackageConfig p@InstalledPackageInfo{..} , pdHdIfaces = concatMap ifInstalledIfaces his } -readInterfaceFile' :: (GmOut m, GmLog m, MonadIO m, GhcMonad m) => FilePath -> m (Either String InterfaceFile) +readInterfaceFile' :: (GmOut m, GmLog m, MonadIO m, GhcMonad m) + => FilePath -> m (Maybe InterfaceFile) readInterfaceFile' f = do - exists <- liftIO $ doesFileExist f - if exists - then readInterfaceFile nameCacheFromGhc' f - else do - gmLog GmWarning "imported-from" haddockSuggestion - return $ Left "No such file" + exists <- liftIO $ doesFileExist f + if exists + then either (const Nothing) Just <$> readInterfaceFile nameCacheFromGhc' f + else do + gmLog GmWarning "imported-from" haddockSuggestion + return Nothing where backticks d = char '`' <> d <> char '`' haddockSuggestion = text "Couldn't find haddock interface" <+> quotes (text f) $$ text "- To generate Haddock docs for dependencies, try:" $$ - nest 4 (backticks $ text "cabal install --enable-documentation --haddock-hyperlink-source --only-dependencies") $$ + nest 4 (backticks $ text "cabal install --enable-documentation\ + \--haddock-hyperlink-source\ + \--only-dependencies") $$ text "" $$ text "- or set" $$ nest 4 (backticks $ text "documentation: True") $$ @@ -105,7 +110,8 @@ nameCacheFromGhc' = ( read_from_session , write_to_session ) read_from_session = liftIO =<< readIORef . hsc_NC <$> getSession write_to_session nc' = liftIO =<< flip writeIORef nc' . hsc_NC <$> getSession -getModulePackage :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) => Module -> m (Maybe PackageDesc) +getModulePackage :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) + => Module -> m (Maybe PackageDesc) getModulePackage m = do dflag <- getSessionDynFlags let pkg = lookupPackage' dflag (moduleUnitId' m) @@ -117,10 +123,9 @@ getModuleHaddockVisibleExports ModuleDesc{..} pkgdesc = in concatMap instVisibleExports modHdIfs getModuleDescFromImport :: (GhcMonad m) => ImportDecl Name -> m ModuleDesc -getModuleDescFromImport ImportDecl{..} - = do +getModuleDescFromImport ImportDecl{..} = do modul <- findModule (unLoc ideclName) (fmap sl_fs' ideclPkgQual) - modInfo <- fromJustNote "imported-from,getModuleDescFromImport" <$> getModuleInfo modul + modInfo <- fromJustNote "getModuleDescFromImport" <$> getModuleInfo modul let listNames :: Data a => a -> [Name] listNames = listifyStaged Renamer (const True) exprts = modInfoExports modInfo @@ -137,19 +142,18 @@ getModuleDescFromImport ImportDecl{..} , mdImplicit = ideclImplicit } -modulesWithPackages :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) => [ModuleDesc] -> m [(ModuleDesc, PackageDesc)] -modulesWithPackages = (fmap catMaybes .) $ mapM $ \x@ModuleDesc{..} -> runMaybeT $ do - pkg <- MaybeT $ getModulePackage mdMod - return (x, pkg) - -preferExplicit :: [ModuleDesc] -> [ModuleDesc] -preferExplicit ms = - let (impl, expl) = partition mdImplicit ms - in expl ++ impl - -guessModule :: Maybe String -> Name -> [(ModuleDesc, PackageDesc)] -> Maybe (Name, (ModuleDesc, PackageDesc)) -guessModule mqn n ms = - let +modulesWithPackages :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) + => [ModuleDesc] -> m [(ModuleDesc, PackageDesc)] +modulesWithPackages = + (fmap catMaybes .) $ mapM $ \x@ModuleDesc{..} -> runMaybeT $ do + pkg <- MaybeT $ getModulePackage mdMod + return (x, pkg) + +guessModule :: Maybe String + -> Name + -> [(ModuleDesc, PackageDesc)] + -> Maybe (Name, (ModuleDesc, PackageDesc)) +guessModule mqn n ms = let occn = occNameString $ occName n msf = filter f ms f = (n `elem`) . uncurry getModuleHaddockVisibleExports @@ -162,70 +166,75 @@ guessModule mqn n ms = f3 qn (ModuleDesc{..},_) | Just as <- mdAlias = qn `elem` map (++ '.' : occn) [as, mdName] | otherwise = qn == (mdName ++ '.' : occn) - in (,) n <$> headMay msf3 + in + (,) n <$> headMay msf3 -showOutput :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) => Name -> (ModuleDesc, PackageDesc) -> m String +showOutput :: (GmOut m, GmLog m, GhcMonad m, MonadIO m) + => Name -> (ModuleDesc, PackageDesc) -> m String showOutput n (ModuleDesc{..}, imppkg) = do - let - occn = occNameString $ occName n - nmod = nameModule n - mn = moduleNameString . moduleName $ nmod - modpkg <- fromMaybe imppkg <$> getModulePackage nmod - let - modpackage - | null (versionBranch modpackagever) = pdName modpkg - | otherwise = pdName modpkg ++ '-' : showVersion modpackagever - modpackagever = pdVersion modpkg - package - | null (versionBranch packagever) - , Just r <- hdRoot = takeFileName r - | otherwise = pdName imppkg ++ '-' : showVersion packagever - packagever = pdVersion imppkg - fqn = modpackage ++ ':' : mn ++ '.' : occn - hdRoot = headMay $ pdHdHTMLs imppkg - docFn = dotsToDashes mdName ++ ".html" - hdPath = fmap ( docFn) hdRoot - dotsToDashes = map go - where go '.' = '-' - go x = x - hackageUrl = "https://hackage.haskell.org/package/" ++ package ++ "/docs/" ++ docFn - hdPathReal <- liftIO $ runMaybeT $ do - hdp <- MaybeT $ return hdPath - exists <- lift $ doesFileExist hdp - if exists - then return hdp - else MaybeT $ return Nothing - return $ unwords [fqn, mdName, fromMaybe hackageUrl hdPathReal] + let occn = occNameString $ occName n + nmod = nameModule n + mn = moduleNameString . moduleName $ nmod + modpkg <- fromMaybe imppkg <$> getModulePackage nmod + let modpackage + | null (versionBranch modpackagever) = pdName modpkg + | otherwise = pdName modpkg ++ '-' : showVersion modpackagever + modpackagever = pdVersion modpkg + package + | null (versionBranch packagever) + , Just r <- hdRoot = takeFileName r + | otherwise = pdName imppkg ++ '-' : showVersion packagever + packagever = pdVersion imppkg + fqn = modpackage ++ ':' : mn ++ '.' : occn + hdRoot = headMay $ pdHdHTMLs imppkg + docFn = dotsToDashes mdName ++ ".html" + hdPath = fmap ( docFn) hdRoot + dotsToDashes = map go + where go '.' = '-' + go x = x + hackageUrl = "https://hackage.haskell.org/package/" + ++ package ++ "/docs/" ++ docFn + hdPathReal <- liftIO $ runMaybeT $ do + hdp <- MaybeT $ return hdPath + exists <- lift $ doesFileExist hdp + if exists + then return hdp + else MaybeT $ return Nothing + return $ unwords [fqn, mdName, fromMaybe hackageUrl hdPathReal] -- | Look up Haddock docs for a symbol. importedFrom :: forall m. IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Maybe Expression -- ^ Expression (symbol) + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Maybe Expression -- ^ Expression (symbol) -> GhcModT m String importedFrom file lineNr colNr symbol = - ghandle handler $ - runGmlT' [Left file] deferErrors $ - withInteractiveContext $ do - crdl <- cradle - modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) - (decls,imports, _exports, _docs) <- fromJustNote "imported-from,importedFrom" . renamedSource <$> (parseModule modSum >>= typecheckModule) - importDescs <- mapM (getModuleDescFromImport . unLoc) imports - bestids <- - case fmap snd $ headMay $ sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) of - Just x -> return x - Nothing -> error $ "No names found at " ++ show (lineNr, colNr) - let idsMods = map (preferExplicit . (\x -> filter ((x `elem`) . mdVisibleExports) importDescs)) bestids - mbsym = getExpression <$> symbol - imps <- mapM modulesWithPackages idsMods - bg <- - case catMaybes $ zipWith (guessModule mbsym) bestids imps of - [] -> error $ "No modules exporting " - ++ fromMaybe (intercalate "," (map (occNameString . getOccName) bestids)) mbsym - x -> return x - unlines <$> mapM (uncurry showOutput) bg + handler $ runGmlT' [Left file] deferErrors $ withInteractiveContext $ do + crdl <- cradle + modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) + Just (decls,imports, _exports, _docs) + <- renamedSource <$> (parseModule modSum >>= typecheckModule) + importDescs :: [ModuleDesc] + <- mapM (getModuleDescFromImport . unLoc) imports + bestids <- + case sortBy (cmp `on` fst) $ findSpanName decls (lineNr, colNr) of + ((_, x):_) -> return x + [] -> error $ "No names found at " ++ show (lineNr, colNr) + let visExports xs n = filter ((elem n) . mdVisibleExports) xs + idsMods = map (preferExplicit . visExports importDescs) bestids + mbsym = getExpression <$> symbol + imps <- mapM modulesWithPackages idsMods + let bestids_str = + intercalate "," (map (occNameString . getOccName) bestids) + bg <- case catMaybes $ zipWith (guessModule mbsym) bestids imps of + [] -> error $ "No modules exporting " ++ fromMaybe bestids_str mbsym + x -> return x + unlines <$> mapM (uncurry showOutput) bg where - handler (SomeException ex) = do - gmLog GmException "imported-from" $ showDoc ex - return [] + handler = ghandle $ \(SomeException ex) -> + gmLog GmException "imported-from" (showDoc ex) >> return [] + + preferExplicit :: [ModuleDesc] -> [ModuleDesc] + preferExplicit ms = + let (impl, expl) = partition mdImplicit ms in expl ++ impl