diff --git a/GhcImportedFrom.hs b/GhcImportedFrom.hs new file mode 100644 --- /dev/null +++ b/GhcImportedFrom.hs @@ -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: . + +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 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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UtilsFromGhcMod.hs b/UtilsFromGhcMod.hs new file mode 100644 --- /dev/null +++ b/UtilsFromGhcMod.hs @@ -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 . +-- +-- * +-- +-- * +-- +-- 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 diff --git a/ghc-imported-from.cabal b/ghc-imported-from.cabal new file mode 100644 --- /dev/null +++ b/ghc-imported-from.cabal @@ -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 diff --git a/test/Dir.hs b/test/Dir.hs new file mode 100644 --- /dev/null +++ b/test/Dir.hs @@ -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' diff --git a/test/ImportedFromSpec.hs b/test/ImportedFromSpec.hs new file mode 100644 --- /dev/null +++ b/test/ImportedFromSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/data/Hiding.hs b/test/data/Hiding.hs new file mode 100644 --- /dev/null +++ b/test/data/Hiding.hs @@ -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 [] + diff --git a/test/data/Muddle.hs b/test/data/Muddle.hs new file mode 100644 --- /dev/null +++ b/test/data/Muddle.hs @@ -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 + diff --git a/test/data/When.hs b/test/data/When.hs new file mode 100644 --- /dev/null +++ b/test/data/When.hs @@ -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"