ghc-imported-from (empty) → 0.1.0.0
raw patch · 13 files changed
+1153/−0 lines, 13 filesdep +Cabaldep +basedep +containerssetup-changed
Dependencies added: Cabal, base, containers, directory, filepath, ghc, ghc-mod, ghc-paths, ghc-syb-utils, hspec, mtl, process, safe, syb, transformers
Files
- GhcImportedFrom.hs +677/−0
- LICENSE +30/−0
- Main.hs +39/−0
- README.md +61/−0
- Setup.hs +2/−0
- UtilsFromGhcMod.hs +87/−0
- ghc-imported-from.cabal +87/−0
- test/Dir.hs +25/−0
- test/ImportedFromSpec.hs +77/−0
- test/Spec.hs +1/−0
- test/data/Hiding.hs +19/−0
- test/data/Muddle.hs +33/−0
- test/data/When.hs +15/−0
+ GhcImportedFrom.hs view
@@ -0,0 +1,677 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+-- |+-- Module : GhcImportedFrom+-- Copyright : Carlo Hamalainen 2013, 2014+-- License : BSD3+--+-- Maintainer : carlo@carlo-hamalainen.net+-- Stability : experimental+-- Portability : portable+--+-- Synopsis: Attempt to guess the location of the Haddock HTML+-- documentation for a given symbol in a particular module, file, and+-- line/col location.+--+-- Latest development version: <https://github.com/carlohamalainen/ghc-imported-from>.++module GhcImportedFrom ( QualifiedName(..)+ , Symbol(..)+ , GhcOptions(..)+ , GhcPkgOptions(..)+ , HaskellModule(..)+ , ghcOptionToGhcPKg+ , getGhcOptionsViaGhcMod+ , getGHCOptionsViaCradle+ , modifyDFlags+ , setDynamicFlags+ , getTextualImports+ , getSummary+ , toHaskellModule+ , lookupSymbol+ , symbolImportedFrom+ , postfixMatch+ , moduleOfQualifiedName+ , qualifiedName+ , ghcPkgFindModule+ , ghcPkgHaddockUrl+ , moduleNameToHtmlFile+ , expandMatchingAsImport+ , specificallyMatches+ , toHackageUrl+ , bestPrefixMatches+ , findHaddockModule+ , matchToUrl+ , guessHaddockUrl+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Instances()+import Control.Monad.Writer+import Control.Monad.Trans as CMT+import Data.Function (on)+import Data.List+import Data.Maybe+import Data.Typeable()+import Desugar()+import DynFlags+import FastString+import GHC+import GHC.Paths (libdir)+import GHC.SYB.Utils()+import HscTypes+import Name+import Outputable+import RdrName+import System.Directory+import System.Environment()+import System.FilePath+import System.IO+import System.Process+import TcRnTypes()++import qualified DynFlags()+import qualified GhcMonad+import qualified MonadUtils()+import qualified Packages+import qualified SrcLoc+import qualified Safe++import Language.Haskell.GhcMod+import Language.Haskell.GhcMod.Internal++import UtilsFromGhcMod++type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@.++type Symbol = String -- ^ A symbol, possibly qualified, e.g. @bar@ or @Foo.bar@.++newtype GhcOptions+ -- | List of user-supplied GHC options, refer to @tets@ subdirectory for example usage. Note that+ -- GHC API and ghc-pkg have inconsistencies in the naming of options, see <http://www.vex.net/~trebla/haskell/sicp.xhtml> for more details.+ = GhcOptions [String] deriving (Show)++newtype GhcPkgOptions+ -- | List of user-supplied ghc-pkg options.+ = GhcPkgOptions [String] deriving (Show)++data HaskellModule+ -- | Information about an import of a Haskell module.+ = HaskellModule { modName :: String+ , modQualifier :: Maybe String+ , modIsImplicit :: Bool+ , modHiding :: [String]+ , modImportedAs :: Maybe String+ , modSpecifically :: [String]+ } deriving (Show, Eq)++-- | Convert a GHC command line option to a @ghc-pkg@ command line option. This function+-- is incomplete; it only handles a few cases at the moment.+ghcOptionToGhcPKg :: [String] -> [String]+ghcOptionToGhcPKg [] = []+ghcOptionToGhcPKg (x:xs) = case x of "-no-user-package-db" -> "--no-user-package-db":ghcOptionToGhcPKg xs+ "-package-db" -> ["--package-db", head xs] ++ ghcOptionToGhcPKg (tail xs)+ _ -> error $ "Unknown GHC option: " ++ show (x:xs) -- FIXME Other cases?++-- | Use ghcmod's API to get the GHC options for a project. This uses 'findCradle', 'cradlePackageDbOpts', and 'GhcOptions'.+getGhcOptionsViaGhcMod :: IO GhcOptions+getGhcOptionsViaGhcMod = GhcOptions . cradlePackageDbOpts <$> findCradle++-- | Use ghcmod's API to get the GHC options for a project. This uses 'findCradle' and 'getGHCOptions.'+getGHCOptionsViaCradle :: IO [GHCOption]+getGHCOptionsViaCradle = do+ c <- findCradle+ pkgDesc <- GhcMonad.liftIO $ parseCabalFile $ fromJust $ cradleCabalFile c+ let binfo = head $ cabalAllBuildInfo pkgDesc+ getGHCOptions [] c (fromJust $ cradleCabalDir c) binfo++-- | Add user-supplied GHC options to those discovered via ghc-mod.+modifyDFlags :: [String] -> DynFlags -> IO ([String], [GHCOption], DynFlags)+modifyDFlags ghcOpts0 dflags0 =+ defaultErrorHandler defaultFatalMessager defaultFlushOut $+ runGhc (Just libdir) $ do+ (GhcOptions ghcOpts1) <- GhcMonad.liftIO getGhcOptionsViaGhcMod+ ghcOpts2 <- GhcMonad.liftIO getGHCOptionsViaCradle++ -- FIXME need to add ghcOpts1 and ghcOpts2 to the WriterT, but here+ -- we are inside the GhcMonad, so need to do some transformer stuff.+ -- Instead we laboriously return ghcOpts1 and ghcOpts2 up the call chain.+ -- GhcMonad.liftIO $ putStrLn $ "ghcOpts1: " ++ show ghcOpts1+ -- GhcMonad.liftIO $ putStrLn $ "ghcOpts2: " ++ show ghcOpts2++ (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 (map SrcLoc.noLoc $ ghcOpts1 ++ ghcOpts2 ++ ghcOpts0)++ let dflags2 = dflags1 { hscTarget = HscInterpreted+ , ghcLink = LinkInMemory+ }++ return (ghcOpts1, ghcOpts2, dflags2)++-- | Set GHC options and run 'initPackages' in 'GhcMonad'.+--+-- Typical use:+--+-- > defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+-- > runGhc (Just libdir) $ do+-- > getSessionDynFlags >>= setDynamicFlags (GhcOptions myGhcOptionList)+-- > -- do stuff+setDynamicFlags :: GhcMonad m => GhcOptions -> DynFlags -> m ([String], [GHCOption], DynFlags)+setDynamicFlags (GhcOptions extraGHCOpts) dflags0 = do+ (ghcOpts1, ghcOpts2, dflags1) <- GhcMonad.liftIO $ modifyDFlags extraGHCOpts dflags0+ void $ setSessionDynFlags dflags1+ _ <- GhcMonad.liftIO $ Packages.initPackages dflags1+ return (ghcOpts1, ghcOpts2, dflags1)++-- |Read the textual imports in a file.+--+-- Example:+--+-- >>> (showSDoc tracingDynFlags) . ppr <$> getTextualImports "test/data/Hiding.hs" "Hiding" >>= putStrLn+-- [ import (implicit) Prelude, import qualified Safe+-- , import System.Environment ( getArgs )+-- , import Data.List hiding ( map )+-- ]+--+-- See also 'toHaskellModule' and 'getSummary'.++getTextualImports :: GhcOptions -> FilePath -> String -> WriterT [String] IO [SrcLoc.Located (ImportDecl RdrName)]+getTextualImports ghcopts targetFile targetModuleName = do+ (ghcOpts1, ghcOpts2, modSum) <- CMT.liftIO $ getSummary ghcopts targetFile targetModuleName++ myTell $ "getTextualImports: ghcOpts1: " ++ show ghcOpts1+ myTell $ "getTextualImports: ghcOpts2: " ++ show ghcOpts2++ return $ ms_textual_imps modSum++-- | Get the module summary for a particular file/module. The first and second components of the+-- return value are @ghcOpts1@ and @ghcOpts2@; see 'setDynamicFlags'.+getSummary :: GhcOptions -> FilePath -> String -> IO ([String], [GHCOption], ModSummary)+getSummary ghcopts targetFile targetModuleName =+ defaultErrorHandler defaultFatalMessager defaultFlushOut $+ runGhc (Just libdir) $ do+ (ghcOpts1, ghcOpts2, _) <- getSessionDynFlags >>= setDynamicFlags ghcopts++ -- Load the target file (e.g. "Muddle.hs").+ target <- guessTarget targetFile Nothing+ setTargets [target]+ _ <- load LoadAllTargets++ -- Set the context by loading the module, e.g. "Muddle" which is in "Muddle.hs".+ setContext [(IIDecl . simpleImportDecl . mkModuleName) targetModuleName]++ -- Extract the module summary.+ modSum <- getModSummary (mkModuleName targetModuleName)++ return (ghcOpts1, ghcOpts2, modSum)++-- |Convenience function for converting an 'GHC.ImportDecl' to a 'HaskellModule'.+--+-- Example:+--+-- > -- Hiding.hs+-- > module Hiding where+-- > import Data.List hiding (map)+-- > import System.Environment (getArgs)+-- > import qualified Safe+--+-- then:+--+-- >>> map toHaskellModule <$> getTextualImports "tests/data/data/Hiding.hs" "Hiding" >>= print+-- [ HaskellModule { modName = "Prelude"+-- , modQualifier = Nothing+-- , modIsImplicit = True+-- , modHiding = []+-- , modImportedAs = Nothing+-- , modSpecifically = []+-- }+-- , HaskellModule {modName = "Safe"+-- , modQualifier = Nothing+-- , modIsImplicit = False+-- , modHiding = []+-- , modImportedAs = Nothing+-- , modSpecifically = []+-- }+-- , HaskellModule { modName = "System.Environment"+-- , modQualifier = Nothing+-- , modIsImplicit = False+-- , modHiding = []+-- , modImportedAs = Nothing+-- , modSpecifically = ["getArgs"]+-- }+-- , HaskellModule { modName = "Data.List"+-- , modQualifier = Nothing+-- , modIsImplicit = False+-- , modHiding = ["map"]+-- , modImportedAs = Nothing+-- , modSpecifically = []+-- }+-- ]++toHaskellModule :: SrcLoc.Located (GHC.ImportDecl GHC.RdrName) -> HaskellModule+toHaskellModule idecl = HaskellModule name qualifier isImplicit hiding importedAs specifically+ where idecl' = SrcLoc.unLoc idecl+ name = showSDoc tracingDynFlags (ppr $ GHC.ideclName idecl')+ isImplicit = GHC.ideclImplicit idecl'+ qualifier = unpackFS <$> GHC.ideclPkgQual idecl'+ hiding = map removeBrackets $ (catMaybes . parseHiding . GHC.ideclHiding) idecl'+ importedAs = (showSDoc tracingDynFlags . ppr) <$> ideclAs idecl'+ specifically = map removeBrackets $ (parseSpecifically . GHC.ideclHiding) idecl'++ removeBrackets :: [a] -> [a]+ removeBrackets [] = []+ removeBrackets x = (init . tail) x++ grabNames :: GHC.Located (GHC.IE GHC.RdrName) -> String+ grabNames loc = showSDoc tracingDynFlags (ppr names)+ where names = GHC.ieNames $ SrcLoc.unLoc loc++ parseHiding :: Maybe (Bool, [Located (IE 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 (IE RdrName)]) -> [String]+ parseSpecifically (Just (False, h)) = map grabNames h+ parseSpecifically _ = []++-- |Find all matches for a symbol in a source file. The last parameter is a list of+-- imports.+--+-- Example:+--+-- >>> x <- lookupSymbol "tests/data/data/Hiding.hs" "Hiding" "head" ["Prelude", "Safe", "System.Environment", "Data.List"]+-- *GhcImportedFrom> putStrLn . (showSDoc tracingDynFlags) . ppr $ x+-- [(GHC.List.head,+-- [GHC.List.head+-- imported from `Data.List' at tests/data/data/Hiding.hs:5:1-29+-- (and originally defined in `base:GHC.List')])]++lookupSymbol :: GhcOptions -> FilePath -> String -> String -> [String] -> IO [(Name, [GlobalRdrElt])]+lookupSymbol ghcopts targetFile targetModuleName qualifiedSymbol importList =+ defaultErrorHandler defaultFatalMessager defaultFlushOut $+ runGhc (Just libdir) $ do+ _ <- getSessionDynFlags >>= setDynamicFlags ghcopts++ target <- guessTarget targetFile Nothing+ setTargets [target]+ _ <- load LoadAllTargets++ -- Bring in the target module and its imports.+ setContext $ map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)++ -- Get the module summary, then parse it, type check it, and desugar it.+ modSummary <- getModSummary $ mkModuleName targetModuleName :: Ghc ModSummary+ p <- parseModule modSummary :: Ghc ParsedModule+ t <- typecheckModule p :: Ghc TypecheckedModule+ d <- desugarModule t :: Ghc DesugaredModule++ -- The "guts" has the global reader environment, which we need.+ let guts = coreModule d :: ModGuts+ gre = HscTypes.mg_rdr_env guts :: GlobalRdrEnv++ -- Beware that parseName expects an unambiguous symbol otherwise it causes a+ -- GHC panic. A fully qualified name should suffice. Is there a way to+ -- catch this exception?+ names <- parseName qualifiedSymbol+ let occNames = map nameOccName names :: [OccName]+ occNamesLookups = map (lookupGlobalRdrEnv gre) occNames :: [[GlobalRdrElt]]++ return $ zip names occNamesLookups++-- | List of possible modules which have resulted in+-- the name being in the current scope. Using a+-- global reader we get the provenance data and then+-- get the list of import specs.+symbolImportedFrom :: GlobalRdrElt -> [ModuleName]+symbolImportedFrom occNameLookup = map importSpecModule whys+ where prov = gre_prov occNameLookup :: Provenance+ Imported (whys :: [ImportSpec]) = prov++-- This definition of separateBy is taken+-- from: http://stackoverflow.com/a/4978733+separateBy :: Eq a => a -> [a] -> [[a]]+separateBy chr = unfoldr sep' where+ sep' [] = Nothing+ sep' l = Just . fmap (drop 1) . break (==chr) $ l++-- | 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 :: Symbol -> QualifiedName -> Bool+postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName+ where endTerm = last $ separateBy '.' originalSymbol++-- | Get the module part of a qualified name.+--+-- Example:+--+-- >>> moduleOfQualifiedName "Foo.bar"+-- Just "Foo"+-- >>> moduleOfQualifiedName "bar"+-- Nothing+moduleOfQualifiedName :: QualifiedName -> Maybe String+moduleOfQualifiedName qn = if null bits+ then Nothing+ else Just $ intercalate "." bits+ where bits = reverse $ drop 1 $ reverse $ separateBy '.' qn++-- | Find the possible qualified names for the symbol at line/col in the given Haskell file and module.+--+-- Example:+--+-- >>> x <- qualifiedName "tests/data/data/Muddle.hs" "Muddle" 27 5 ["Data.Maybe", "Data.List", "Data.Map", "Safe"]+-- >>> forM_ x print+-- "AbsBinds [] []\n {Exports: [Muddle.h <= h\n <>]\n Exported types: Muddle.h\n :: Data.Map.Base.Map GHC.Base.String GHC.Base.String\n [LclId]\n Binds: h = Data.Map.Base.fromList [(\"x\", \"y\")]}"+-- "h = Data.Map.Base.fromList [(\"x\", \"y\")]"+-- "Data.Map.Base.fromList [(\"x\", \"y\")]"+-- "Data.Map.Base.fromList"++qualifiedName :: GhcOptions -> FilePath -> String -> Int -> Int -> [String] -> IO [String]+qualifiedName ghcopts targetFile targetModuleName lineNr colNr importList =+ defaultErrorHandler defaultFatalMessager defaultFlushOut $+ runGhc (Just libdir) $ do+ _ <- getSessionDynFlags >>= setDynamicFlags ghcopts++ target <- guessTarget targetFile Nothing+ setTargets [target]+ _ <- load LoadAllTargets++ setContext $ map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)++ modSummary <- getModSummary $ mkModuleName targetModuleName :: Ghc ModSummary+ p <- parseModule modSummary :: Ghc ParsedModule+ t <- typecheckModule p :: Ghc 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 foo x = showSDoc tracingDynFlags $ ppr x+ bs' = map foo bs+ es' = map foo es+ ps' = map foo ps++ return $ bs' ++ es' ++ ps'++-- Read everything else available on a handle, and return the empty+-- string if we have hit EOF.+readRestOfHandle :: Handle -> IO String+readRestOfHandle h = do+ ineof <- hIsEOF h+ if ineof+ then return ""+ else hGetContents h++-- | 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 :: GhcPkgOptions -> String -> WriterT [String] IO (Maybe String)+ghcPkgFindModule (GhcPkgOptions extraGHCPkgOpts) m = do++ (GhcOptions gopts) <- CMT.liftIO getGhcOptionsViaGhcMod :: WriterT [String] IO GhcOptions++ let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] ++ ghcOptionToGhcPKg gopts ++ extraGHCPkgOpts+ myTell $ "ghc-pkg " ++ show opts++ (_, Just hout, Just herr, _) <- CMT.liftIO $ createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ output <- CMT.liftIO $ readRestOfHandle hout+ err <- CMT.liftIO $ readRestOfHandle herr+ myTell $ "ghcPkgFindModule stdout: " ++ output+ myTell $ "ghcPkgFindModule stderr: " ++ err++ return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output++-- | Call @ghc-pkg field@ to get the @haddock-html@ field for a package.+ghcPkgHaddockUrl :: GhcPkgOptions -> String -> WriterT [String] IO (Maybe String)+ghcPkgHaddockUrl (GhcPkgOptions extraGHCPkgOpts) p = do+ (GhcOptions gopts) <- CMT.liftIO getGhcOptionsViaGhcMod :: WriterT [String] IO GhcOptions++ let opts = ["field", p, "haddock-html"] ++ ["--global", "--user"] ++ ghcOptionToGhcPKg gopts ++ extraGHCPkgOpts+ myTell $ "ghc-pkg "++ show opts++ (_, Just hout, _, _) <- CMT.liftIO $ createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ line <- CMT.liftIO $ (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout+ return $ Safe.lastMay $ words line++-- | 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++-- | If the Haskell module has an import like @import qualified Data.List as DL@, convert an+-- occurence @DL.fromList@ to the qualified name using the actual module name: @Data.List.fromList@.+--+-- Example:+--+-- > -- Muddle.hs+-- >+-- > module Muddle where+-- >+-- > import Data.Maybe+-- > import qualified Data.List as DL+-- > import qualified Data.Map as DM+-- > import qualified Safe+--+-- then:+--+-- >>> hmodules <- map toHaskellModule <$> getTextualImports "tests/data/data/Muddle.hs" "Muddle"+-- >>> print $ expandMatchingAsImport "DL.fromList" hmodules+-- Just "Data.List.fromList"++expandMatchingAsImport :: QualifiedName -> [HaskellModule] -> Maybe QualifiedName+expandMatchingAsImport symbol hmodules = case x of (Just (h, Just cp)) -> Just $ modName h ++ drop (length cp) symbol+ _ -> Nothing+ where x = Safe.headMay $ filter (isJust . snd) $ zip hmodules (map (cmpMod symbol) hmodules)++ cmpMod s (HaskellModule _ _ _ _ (Just impAs) _) = if impAs `isPrefixOf` s+ then Just $ commonPrefix s impAs+ else Nothing+ cmpMod _ _ = Nothing++ -- http://www.haskell.org/pipermail/beginners/2011-April/006856.html+ commonPrefix :: Eq a => [a] -> [a] -> [a]+ commonPrefix a b = map fst (takeWhile (uncurry (==)) (zip a b))++-- | Return list of modules which explicitly import a symbol.+--+-- Example:+--+-- > -- Hiding.hs+-- > module Hiding where+-- > import Data.List hiding (map)+-- > import System.Environment (getArgs)+-- > import qualified Safe+--+-- >>> hmodules <- map toHaskellModule <$> getTextualImports "tests/data/data/Hiding.hs" "Hiding"+-- >>> print $ specificallyMatches "getArgs" hmodules+-- [ HaskellModule { modName = "System.Environment"+-- , modQualifier = Nothing+-- , modIsImplicit = False+-- , modHiding = []+-- , modImportedAs = Nothing+-- , modSpecifically = ["getArgs"]+-- }+-- ]++specificallyMatches :: Symbol -> [HaskellModule] -> [HaskellModule]+specificallyMatches symbol = filter (\h -> symbol `elem` modSpecifically h)++-- | Convert a file path to a Hackage HTML file to its equivalent on @https://hackage.haskell.org@.+toHackageUrl :: FilePath -> String -> String -> String+toHackageUrl filepath package modulename = "https://hackage.haskell.org/package/" ++ package ++ "/" ++ "docs/" ++ modulename''+ where filepath' = map repl filepath+ modulename' = head $ separateBy '.' $ head $ separateBy '-' 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)++-- | When we use 'parseName' to convert a 'String' to a 'Name' we get a list of matches instead of+-- a unique match, so we end up having to guess the best match based on the qualified name.+bestPrefixMatches :: Name -> [GlobalRdrElt] -> [String]+bestPrefixMatches name lookUp = x''+ where name' = showSDoc tracingDynFlags $ ppr name+ name'' = fromJust $ moduleOfQualifiedName name' -- FIXME dangerous fromJust+ x = concatMap symbolImportedFrom lookUp+ x' = map (showSDoc tracingDynFlags . ppr) x+ x'' = filter (name'' `isPrefixOf`) x'++-- | Find the haddock module. Returns a 4-tuple consisting of: module that the symbol is imported+-- from, haddock url, module, and module's HTML filename.+findHaddockModule :: QualifiedName -> [HaskellModule] -> GhcPkgOptions -> (Name, [GlobalRdrElt]) -> WriterT [String] IO (Maybe String, Maybe String, Maybe String, Maybe String)+findHaddockModule symbol'' smatches ghcPkgOpts (name, lookUp) = do+ myTell $ "name: " ++ showSDoc tracingDynFlags (ppr name)++ let definedIn = nameModule name+ bpms = bestPrefixMatches name lookUp+ importedFrom = if null smatches+ -- then Safe.headMay $ concatMap symbolImportedFrom lookUp :: Maybe ModuleName+ -- FIXME should really return *all* of these matches, not just the first one. We+ -- can't be certain that we're choosing the best one. Ditto for all other+ -- uses of head or Safe.headMay.+ then if null bpms then Safe.headMay $ map (showSDoc tracingDynFlags . ppr) $ concatMap symbolImportedFrom lookUp+ else Safe.headMay bpms :: Maybe String+ else (Just . (showSDoc tracingDynFlags . ppr) . mkModuleName . fromJust . moduleOfQualifiedName) symbol'' -- FIXME dangerous fromJust++ myTell $ "definedIn: " ++ showSDoc tracingDynFlags (ppr definedIn)+ myTell $ "bpms: " ++ show bpms+ myTell $ "concat $ map symbolImportedFrom lookUp: " ++ showSDoc tracingDynFlags (ppr $ concatMap symbolImportedFrom lookUp)+++ myTell $ "importedFrom: " ++ show importedFrom++ foundModule <- maybe (return Nothing) (ghcPkgFindModule ghcPkgOpts) importedFrom+ myTell $ "ghcPkgFindModule result: " ++ show foundModule++ let base = moduleNameToHtmlFile <$> importedFrom++ myTell $ "base: : " ++ show base++ -- haddock <- fmap (filter ('"' /=)) <$> maybe (return Nothing) (ghcPkgHaddockUrl ghcPkgOpts) foundModule+ haddock <- maybe (return Nothing) (ghcPkgHaddockUrl ghcPkgOpts) foundModule++ myTell $ "haddock: " ++ show haddock+ myTell $ "foundModule: " ++ show foundModule++ return (importedFrom, haddock, foundModule, base)++myTell :: MonadWriter [t] m => t -> m ()+myTell x = tell [x]++-- | Convert our match to a URL, either @file://@ if the file exists, or to @hackage.org@ otherwise.+matchToUrl :: (Maybe String, Maybe String, Maybe String, Maybe String) -> WriterT [String] IO String+matchToUrl (importedFrom, haddock, foundModule, base) = do+ let importedFrom' = fromJust importedFrom+ haddock' = fromJust haddock+ foundModule' = fromJust foundModule+ base' = fromJust base++ f = haddock' </> base'++ e <- CMT.liftIO $ doesFileExist f++ if e then return $ "file://" ++ f+ else do myTell $ "f: " ++ show f+ myTell $ "foundModule: " ++ show foundModule'+ return $ toHackageUrl f foundModule' (showSDoc tracingDynFlags (ppr importedFrom'))+++-- | Attempt to guess the Haddock url, either a local file path or url to @hackage.haskell.org@+-- for the symbol in the given file, module, at the specified line and column location.+--+-- Example:+--+-- >>> guessHaddockUrl "tests/data/data/Muddle.hs" "Muddle" "Maybe" 11 11+-- (lots of output)+-- SUCCESS: file:///home/carlo/opt/ghc-7.6.3_build/share/doc/ghc/html/libraries/base-4.6.0.1/Data-Maybe.html++guessHaddockUrl :: FilePath -> String -> Symbol -> Int -> Int -> GhcOptions -> GhcPkgOptions -> WriterT [String] IO (Either String String)+guessHaddockUrl targetFile targetModule symbol lineNr colNr (GhcOptions ghcOpts0) ghcPkgOpts = do+ myTell $ "targetFile: " ++ targetFile+ myTell $ "targetModule: " ++ targetModule+ myTell $ "symbol: " ++ show symbol+ myTell $ "line nr: " ++ show lineNr+ myTell $ "col nr: " ++ show colNr++ textualImports <- getTextualImports (GhcOptions ghcOpts0) targetFile targetModule++ let haskellModuleNames = map (modName . toHaskellModule) textualImports+ myTell $ "haskellModuleNames: " ++ show haskellModuleNames++ qnames <- CMT.liftIO $ filter (not . (' ' `elem`)) <$> qualifiedName (GhcOptions ghcOpts0) targetFile targetModule lineNr colNr haskellModuleNames++ myTell $ "qualified names: " ++ show qnames++ let matchingAsImport = expandMatchingAsImport symbol (map toHaskellModule textualImports)+ myTell $ "matchingAsImport: " ++ show matchingAsImport++ let postMatches = filter (postfixMatch symbol) qnames :: [String]+ symbol' = fromMaybe (if null postMatches then symbol else minimumBy (compare `on` length) postMatches) matchingAsImport++ myTell $ "postMatches: " ++ show postMatches+ myTell $ "symbol': " ++ symbol'++ let maybeExtraModule = moduleOfQualifiedName symbol'+ haskellModuleNames' = if symbol == symbol' then haskellModuleNames else haskellModuleNames ++ [fromJust maybeExtraModule]++ myTell $ "maybeExtraModule: " ++ show maybeExtraModule+ myTell $ "haskellModuleNames': " ++ show haskellModuleNames'++ let smatches = specificallyMatches symbol (map toHaskellModule textualImports)+ myTell $ "smatches: " ++ show smatches++ let symbol'' = if null smatches+ then symbol'+ else modName (head smatches) ++ "." ++ symbol++ myTell $ "symbol'': " ++ symbol''++ let allJust (a, b, c, d) = isJust a && isJust b && isJust c && isJust d++ final1 <- CMT.liftIO $ lookupSymbol (GhcOptions ghcOpts0) targetFile targetModule symbol'' haskellModuleNames'+ final2 <- filter allJust <$> mapM (findHaddockModule symbol'' smatches ghcPkgOpts) final1++ final3 <- mapM matchToUrl final2++ return (if null final3 then Left "No matches found."+ else Right $ head final3)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Carlo Hamalainen++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 the name of Carlo Hamalainen nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER OR 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.
+ Main.hs view
@@ -0,0 +1,39 @@+import GhcImportedFrom++import Data.List+import Data.Maybe+import System.Environment+import System.IO()++import Control.Monad (forM_)+import Control.Monad.Writer++main :: IO ()+main = do+ args <- getArgs++ -- quick and dirty argument parsing, no error checking+ let targetFile = args !! 0+ targetModule = args !! 1+ symbol = args !! 2+ lineNo = (read $ args !! 3) :: Int+ colNo = (read $ args !! 4) :: Int+ rest = drop 5 args++ -- assert: rest !! 0 == "--ghc-options"++ let n = fromJust $ elemIndex "--ghc-pkg-options" rest++ -- assert: rest !! n == "--ghc-pkg-options"++ let ghcopts = GhcOptions $ tail $ take n rest+ let ghcpkgopts = GhcPkgOptions $ drop (n + 1) rest++ print ghcopts+ print ghcpkgopts++ (res, logMessages) <- runWriterT $ guessHaddockUrl targetFile targetModule symbol lineNo colNo ghcopts ghcpkgopts++ case res of Right x -> do forM_ logMessages putStrLn+ putStrLn $ "SUCCESS: " ++ x+ Left err -> putStrLn $ "FAIL: " ++ show err
+ README.md view
@@ -0,0 +1,61 @@+ghc-imported-from+=================++For a given Haskell source file, determine the path to the Haddock documentation for a symbol at a particular line/col location.++Example: on the file [Muddle.hs](https://github.com/carlohamalainen/ghc-imported-from/blob/master/tests/Muddle.hs),++ ../.cabal-sandbox/bin/ghc-imported-from Muddle.hs Muddle Maybe 11 11++says++ SUCCESS: /home/carlo/opt/ghc-7.6.3_build/share/doc/ghc/html/libraries/base-4.6.0.1/Data-Maybe.html++since the usage of ```Maybe``` at line 11, column 11, is from the ```Data.Maybe``` module.++Difficulties arise because some symbols are exported from a certain+package but defined in another, for example ```String``` is defined in+```GHC.Base``` but is exported from the standard prelude, the module+```Prelude```. There are other cases to deal with including qualified+imports, selective imports, imports with hidden components, etc.++Preference is given to any locally available Haddock documentation,+and then to the generic url at hackage.org.++## Install++### ghc-imported-from++Install into ```~/.cabal```:++ git clone https://github.com/carlohamalainen/ghc-imported-from+ cd ghc-imported-from+ cabal install++Or, install into a sandbox:++ git clone https://github.com/carlohamalainen/ghc-imported-from+ cd ghc-imported-from+ ./build_in_sandbox.sh++Either way, ensure that ```ghc-imported-from``` is in the current PATH.++### ghcimportedfrom-vim++Follow the instructions at+[https://github.com/carlohamalainen/ghcimportedfrom-vim](https://github.com/carlohamalainen/ghcimportedfrom-vim)+to install the Vim plugin.++## Usage++See the ```tests``` subdirectory for some examples. Or load your favourite Haskell project and hit F4.++Or watch the screencast (be sure to set 720p HD and then fullscreen):++[http://www.youtube.com/watch?v=VVc8uupYJGs](http://www.youtube.com/watch?v=VVc8uupYJGs)++## Beware++If you use Cabal sandboxes, you'll have to hardcode the path to the package config file. This is a known issue: [https://github.com/carlohamalainen/ghc-imported-from/issues/3](https://github.com/carlohamalainen/ghc-imported-from/issues/3)++Feedback and pull requests most welcome!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ UtilsFromGhcMod.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE Rank2Types #-}++-----------------------------------------------------------------------------+-- |+-- Module : UtilsFromGhcMod+-- Copyright : Carlo Hamalainen 2013, 2014+-- License : BSD3+--+-- Maintainer : carlo@carlo-hamalainen.net+-- Stability : experimental+-- Portability : portable+--+-- The ghc-mod project has some very useful functions that are not+-- exported, so here I've pulled out the few that I need. Credit for+-- the code in this file is due to Kazu Yamamoto <kazu@iij.ad.jp>.+--+-- * <http://www.mew.org/~kazu/proj/ghc-mod/en>+--+-- * <https://github.com/kazu-yamamoto/ghc-mod>+--+-- Hopefully this is ok since ghc-mod and this project are both licensed BSD3.++module UtilsFromGhcMod where++import Control.Applicative+import Data.Generics hiding (typeOf)+import GHC+import GHC.SYB.Utils+import System.Directory+import System.FilePath++import Packages++import Language.Haskell.GhcMod+import Language.Haskell.GhcMod.Internal+import Distribution.PackageDescription+import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))+import Distribution.Simple.Program (ghcProgram)+import Distribution.Simple.Program.Types (programName, programFindVersion)+import Distribution.Verbosity (silent)++import Control.Exception (throwIO)++-- ghcmod/Language/Haskell/GhcMod/Info.hs+listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]+listifySpans tcs lc = listifyStaged TypeChecker p tcs+ where+ p (L spn _) = isGoodSrcSpan spn && spn `spans` lc++-- ghcmod/Language/Haskell/GhcMod/Info.hs+listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]+listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))++-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs+getGHCOptions :: [GHCOption] -> Cradle -> String -> BuildInfo -> IO [GHCOption]+getGHCOptions ghcopts cradle cdir binfo = do+ cabalCpp <- cabalCppOptions cdir+ let cpps = map ("-optP" ++) $ cppOptions binfo ++ cabalCpp+ return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps+ where+ pkgDb = cradlePackageDbOpts cradle+ lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo+ libDirs = map ("-L" ++) $ extraLibDirs binfo+ exts = map (("-X" ++) . display) $ usedExtensions binfo+ libs = map ("-l" ++) $ extraLibs binfo++-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs+-- modification: return $ if ... instead of if .. return+cabalCppOptions :: FilePath -> IO [String]+cabalCppOptions dir = do+ exist <- doesFileExist cabalMacro+ return $ if exist then ["-include", cabalMacro]+ else []+ where+ cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"++-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs+getGHCId :: IO CompilerId+getGHCId = CompilerId GHC <$> getGHC++-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs+getGHC :: IO Version+getGHC = do+ mv <- programFindVersion ghcProgram silent (programName ghcProgram)+ case mv of+ Nothing -> throwIO $ userError "ghc not found"+ Just v -> return v
+ ghc-imported-from.cabal view
@@ -0,0 +1,87 @@+name: ghc-imported-from+version: 0.1.0.0+synopsis: Find the Haddock documentation for a symbol.+description: Given a Haskell module and symbol, determine the URL to the Haddock documentation+ for that symbol.+homepage: https://github.com/carlohamalainen/ghc-imported-from+license: BSD3+license-file: LICENSE+author: Carlo Hamalainen+maintainer: carlo@carlo-hamalainen.net+-- copyright:+category: Development+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++extra-source-files: test/*.hs+ test/data/*.hs++library+ exposed-modules: GhcImportedFrom+ other-modules: UtilsFromGhcMod++ other-extensions: CPP, Rank2Types+ build-depends: base >=4.6 && <4.7+ , syb >=0.4 && <0.5+ , ghc >=7.6 && <7.7+ , ghc-paths >=0.1 && <0.2+ , ghc-syb-utils+ , Cabal+ , ghc-mod+ , filepath+ , safe+ , process+ , directory+ , containers >= 0.5.0.0 && <= 0.5.0.0+ , mtl+ , transformers++ default-language: Haskell2010++executable ghc-imported-from+ main-is: Main.hs+ GHC-Options: -Wall+ -- other-modules:+ other-extensions: CPP, Rank2Types+ build-depends: base >=4.6 && <4.7+ , syb >=0.4 && <0.5+ , ghc >=7.6 && <7.7+ , ghc-paths >=0.1 && <0.2+ , ghc-syb-utils+ , Cabal+ , ghc-mod+ , filepath+ , safe+ , process+ , directory+ , containers >= 0.5.0.0 && <= 0.5.0.0+ , mtl+ , transformers++ -- hs-source-dirs:+ default-language: Haskell2010++Test-Suite spec+ Default-Language: Haskell2010+ GHC-Options: -Wall+ Main-Is: Spec.hs+ Hs-Source-Dirs: test, .+ Type: exitcode-stdio-1.0+ Other-Modules: Dir+ ImportedFromSpec+ Build-Depends: base >=4.6 && <4.7+ , syb >=0.4 && <0.5+ , ghc >=7.6 && <7.7+ , ghc-paths >=0.1 && <0.2+ , ghc-syb-utils+ , Cabal+ , ghc-mod+ , filepath+ , safe+ , process+ , directory+ , containers >= 0.5.0.0 && <= 0.5.0.0+ , mtl+ , transformers+ , hspec
+ test/Dir.hs view
@@ -0,0 +1,25 @@+-- copied from ghc-mod/test+module Dir where++import Control.Exception as E+import Data.List (isPrefixOf)+import System.Directory+import System.FilePath (addTrailingPathSeparator)++withDirectory_ :: FilePath -> IO a -> IO a+withDirectory_ dir action = bracket getCurrentDirectory+ setCurrentDirectory+ (\_ -> setCurrentDirectory dir >> action)++withDirectory :: FilePath -> (FilePath -> IO a) -> IO a+withDirectory dir action = bracket getCurrentDirectory+ setCurrentDirectory+ (\d -> setCurrentDirectory dir >> action d)++toRelativeDir :: FilePath -> FilePath -> FilePath+toRelativeDir dir file+ | dir' `isPrefixOf` file = drop len file+ | otherwise = file+ where+ dir' = addTrailingPathSeparator dir+ len = length dir'
+ test/ImportedFromSpec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE RankNTypes #-}++module ImportedFromSpec where++import Control.Monad.Writer+import Data.List (isSuffixOf, isInfixOf, isPrefixOf)+import GhcImportedFrom+import System.FilePath()+import Test.Hspec++import Dir++isRight :: forall a b. Either a b -> Bool+isRight = either (const False) (const True)++spec :: Spec+spec = do+ describe "checkImportedFrom" $ do+ it "can look up Maybe" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "Maybe" 11 11 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up Just" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "Just" 12 7 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up Just" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "Just" 16 10 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up String" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "String" 20 14 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up Int" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "Int" 22 23 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up DL.length" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "DL.length" 23 5 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up print" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "print" 25 8 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up DM.fromList" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "DM.fromList" 27 5 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up Safe.headMay" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Muddle.hs" "Muddle" "Safe.headMay" 29 6 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up map" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Hiding.hs" "Hiding" "map" 12 5 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up head" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "Hiding.hs" "Hiding" "head" 12 5 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight++ it "can look up when" $ do+ withDirectory_ "test/data" $ do+ (res, _) <- runWriterT $ guessHaddockUrl "When.hs" "When" "when" 15 5 (GhcOptions []) (GhcPkgOptions [])+ res `shouldSatisfy` isRight
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/data/Hiding.hs view
@@ -0,0 +1,19 @@+-- Hiding.hs++module Hiding 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 []+
+ test/data/Muddle.hs view
@@ -0,0 +1,33 @@+-- Muddle.hs++module Muddle where++import Data.Maybe+import qualified Data.List as DL+import qualified Data.Map as DM+import qualified Safe+-- import Data.List hiding (map)++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+
+ test/data/When.hs view
@@ -0,0 +1,15 @@+-- When.hs++module When 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"