ghc-imported-from 0.2.1.1 → 0.3.0.0
raw patch · 4 files changed
+642/−376 lines, 4 filesdep +haddock-api
Dependencies added: haddock-api
Files
- Language/Haskell/GhcImportedFrom.hs +613/−328
- README.md +20/−47
- changelog.md +5/−0
- ghc-imported-from.cabal +4/−1
Language/Haskell/GhcImportedFrom.hs view
@@ -30,7 +30,6 @@ , getTextualImports , getSummary , toHaskellModule- , lookupSymbol , symbolImportedFrom , postfixMatch , moduleOfQualifiedName@@ -38,11 +37,6 @@ , ghcPkgFindModule , ghcPkgHaddockUrl , moduleNameToHtmlFile- , expandMatchingAsImport- , specificallyMatches- , toHackageUrl- , bestPrefixMatches- , findHaddockModule , matchToUrl , guessHaddockUrl , haddockUrl@@ -58,17 +52,19 @@ import Control.Monad import Control.Monad.Instances() import Control.Monad.Writer+import Data.Either (rights) import Data.Function (on)+import Data.Traversable 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 Module import Name import Outputable import RdrName@@ -79,8 +75,10 @@ import System.Process import TcRnTypes() import HsImpExp+import HsTypes+import Type+import HsPat -import qualified DynFlags() import qualified GhcMonad import qualified MonadUtils() import qualified Packages@@ -93,6 +91,8 @@ , Cradle(..) ) +import qualified Data.Map as M+ import Language.Haskell.GhcMod.Monad ( runGmOutT ) import qualified Language.Haskell.GhcMod.Types as GhcModTypes @@ -108,8 +108,12 @@ import qualified Text.Parsec as TP import Data.Functor.Identity +import qualified Documentation.Haddock as Haddock+ import Debug.Trace +import qualified DynFlags()+ #if __GLASGOW_HASKELL__ >= 708 import DynFlags ( unsafeGlobalDynFlags ) tdflags = unsafeGlobalDynFlags@@ -122,15 +126,97 @@ trace' m x = trace (m ++ ">>> " ++ show x) trace'' :: Outputable x => String -> x -> b -> b-trace'' m x = trace (m ++ ">>> " ++ (showSDoc tdflags (ppr x)))+trace'' m x = trace (m ++ ">>> " ++ showSDoc tdflags (ppr x)) +shortcut :: [IO (Maybe a)] -> IO (Maybe a)+shortcut [] = return Nothing+shortcut (a:as) = do+ a' <- a++ case a' of+ a''@(Just _) -> return a''+ Nothing -> shortcut as+ type GHCOption = String +getStackSnapshotPkgDb :: IO (Maybe String)+getStackSnapshotPkgDb = do+ putStrLn "getStackSnapshotPkgDb ..."++ let p = (proc "stack" ["path", "--snapshot-pkg-db"]){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ (Just _, Just hout, Just _, _) <- createProcess p++ ineof <- hIsEOF hout++ x <- if ineof+ then return ""+ else (unwords . words) <$> hGetLine hout++ return $ if x == "" then Nothing else Just x++getStackLocalPkgDb :: IO (Maybe String)+getStackLocalPkgDb = do+ putStrLn "getStackLocalPkgDb ..."++ let p = (proc "stack" ["path", "--local-pkg-db"]){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ (Just _, Just hout, Just _, _) <- createProcess p++ ineof <- hIsEOF hout++ x <- if ineof+ then return ""+ else (unwords . words) <$> hGetLine hout++ return $ if x == "" then Nothing else Just x++getGhcOptionsViaStack :: IO (Maybe [String])+getGhcOptionsViaStack = do+ putStrLn "getGhcOptionsViaStack..."++ stackSnapshotPkgDb <- (fmap ("-package-db " ++)) <$> getStackSnapshotPkgDb :: IO (Maybe String)+ stackLocalPkgDb <- (fmap ("-package-db " ++)) <$> getStackLocalPkgDb :: IO (Maybe String)++ case (stackSnapshotPkgDb, stackLocalPkgDb) of+ (Nothing, _) -> return Nothing+ (_, Nothing) -> return Nothing+ (Just stackSnapshotPkgDb', Just stackLocalPkgDb') -> do+ let p = (proc "stack" ["ghci", "--with-ghc=fake-ghc-for-ghc-imported-from"]){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ (Just _, Just hout, Just _, _) <- createProcess p++ ineof <- hIsEOF hout++ result <- if ineof+ then return ""+ else do firstLine <- hGetLine hout+ if "GHCi" `isPrefixOf` firstLine+ then error "Accidentally started an interactive session with 'stack ghci'?"+ else readRestOfHandle hout++ let result' = filter ("--interactive" `isPrefixOf`) . lines $ result++ return $ case length result' of+ 1 -> Just $ (filterOpts $ words $ head result') ++ [stackSnapshotPkgDb', stackLocalPkgDb']+ _ -> Nothing+ getGhcOptionsViaCabalRepl :: IO (Maybe [String]) getGhcOptionsViaCabalRepl = do- putStrLn $ "getGhcOptionsViaCabalRepl..."+ putStrLn "getGhcOptionsViaCabalRepl..." - (Just _, Just hout, Just _, _) <- createProcess (proc "cabal" ["repl", "--with-ghc=fake-ghc-for-ghc-imported-from"]){ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+ (Just _, Just hout, Just _, _) <- createProcess (proc "cabal" ["repl", "--with-ghc=fake-ghc-for-ghc-imported-from"]){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ } ineof <- hIsEOF hout @@ -160,10 +246,7 @@ return (c:cs) parseDottedHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String-parseDottedHaskellModuleName = do- TP.char '.'- cs <- parseHaskellModuleName- return cs+parseDottedHaskellModuleName = TP.char '.' >> parseHaskellModuleName parseFullHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String parseFullHaskellModuleName = do@@ -173,11 +256,51 @@ return $ intercalate "." (h:rest) parseHelper :: String -> Bool-parseHelper s = case (TP.parse (parseFullHaskellModuleName <* TP.eof) "" s) of Right _ -> False- Left _ -> True+parseHelper s = case TP.parse (parseFullHaskellModuleName <* TP.eof) "" s of Right _ -> False+ Left _ -> True +parsePackageAndQualName = TP.choice [TP.try parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash]++-- Package with no hash (seems to be for internal packages?)+-- base-4.8.2.0:Data.Foldable.length+parsePackageAndQualNameNoHash :: TP.ParsecT String u Data.Functor.Identity.Identity (String, String)+parsePackageAndQualNameNoHash = do+ packageName <- parsePackageName+ qualName <- parsePackageFinalQualName++ return (packageName, qualName)++ where++ parsePackageName :: TP.ParsecT String u Data.Functor.Identity.Identity String+ parsePackageName = TP.anyChar `TP.manyTill` TP.char ':'++ parsePackageFinalQualName :: TP.ParsecT String u Data.Functor.Identity.Identity String+ parsePackageFinalQualName = TP.many1 TP.anyChar++-- 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 :: TP.ParsecT String u Data.Functor.Identity.Identity (String, String)+parsePackageAndQualNameWithHash = do+ packageName <- parsePackageName+ _ <- parsePackageHash+ qualName <- parsePackageFinalQualName++ return (packageName, qualName)++ where++ parsePackageName :: TP.ParsecT String u Data.Functor.Identity.Identity String+ parsePackageName = TP.anyChar `TP.manyTill` TP.char '@'++ parsePackageHash :: TP.ParsecT String u Data.Functor.Identity.Identity String+ parsePackageHash = TP.anyChar `TP.manyTill` TP.char ':'++ parsePackageFinalQualName :: TP.ParsecT String u Data.Functor.Identity.Identity String+ parsePackageFinalQualName = TP.many1 TP.anyChar+ getGhcOptionsViaCabalReplOrEmpty :: IO [String]-getGhcOptionsViaCabalReplOrEmpty = liftM (fromMaybe []) getGhcOptionsViaCabalRepl+getGhcOptionsViaCabalReplOrEmpty = fromMaybe [] <$> shortcut [getGhcOptionsViaStack, getGhcOptionsViaCabalRepl] type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@. @@ -253,34 +376,37 @@ GhcMonad.liftIO $ putStrLn $ "getTextualImports: allGhcOpts: " ++ show allGhcOpts + -- graph <- getModuleGraph+ -- GhcMonad.liftIO $ error $ show $ map ms_hspp_file graph+ return (allGhcOpts, 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 :: GhcMonad m => GhcOptions -> FilePath -> String -> m ([GHCOption], ModSummary) getSummary ghcopts targetFile targetModuleName = do- GhcMonad.liftIO $ putStrLn $ "getSummary, setting dynamic flags..."+ GhcMonad.liftIO $ putStrLn "getSummary, setting dynamic flags..." (allGhcOpts, _) <- getSessionDynFlags >>= setDynamicFlags ghcopts GhcMonad.liftIO $ putStrLn $ "getSummary, allGhcOpts: " ++ show allGhcOpts -- Load the target file (e.g. "Muddle.hs").- GhcMonad.liftIO $ putStrLn $ "getSummary, loading the target file..."+ GhcMonad.liftIO $ putStrLn "getSummary, loading the target file..." target <- guessTarget targetFile Nothing setTargets [target] _ <- load LoadAllTargets -- Set the context by loading the module, e.g. "Muddle" which is in "Muddle.hs".- GhcMonad.liftIO $ putStrLn $ "getSummary, setting the context..."+ GhcMonad.liftIO $ putStrLn "getSummary, setting the context..." - (setContext [(IIDecl . simpleImportDecl . mkModuleName) targetModuleName])+ setContext [(IIDecl . simpleImportDecl . mkModuleName) targetModuleName] `gcatch` (\(e :: SourceError) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a SourceError, trying to continue anyway..." ++ show e)) `gcatch` (\(g :: GhcApiError) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g)) `gcatch` (\(se :: SomeException) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a SomeException, trying to continue anyway..." ++ show se)) -- Extract the module summary.- GhcMonad.liftIO $ putStrLn $ "getSummary, extracting the module summary..."+ GhcMonad.liftIO $ putStrLn "getSummary, extracting the module summary..." modSum <- getModSummary (mkModuleName targetModuleName) -- graph <- GHC.depanal [] False@@ -339,20 +465,16 @@ name = showSDoc tdflags (ppr $ GHC.ideclName idecl') isImplicit = GHC.ideclImplicit idecl' qualifier = unpackFS <$> GHC.ideclPkgQual idecl'- hiding = map removeBrackets $ (catMaybes . parseHiding . GHC.ideclHiding) idecl'+ hiding = (catMaybes . parseHiding . GHC.ideclHiding) idecl' importedAs = (showSDoc tdflags . ppr) <$> ideclAs idecl'- specifically = map removeBrackets $ (parseSpecifically . GHC.ideclHiding) idecl'-- removeBrackets :: [a] -> [a]- removeBrackets [] = []- removeBrackets x = (init . tail) x+ specifically = (parseSpecifically . GHC.ideclHiding) idecl' grabNames :: GHC.Located (GHC.IE GHC.RdrName) -> String grabNames loc = showSDoc tdflags (ppr names) where names = GHC.ieNames $ SrcLoc.unLoc loc grabNames' :: GHC.Located [GHC.LIE GHC.RdrName] -> [String]- grabNames' loc = map (\n -> showSDoc tdflags (ppr n)) names+ grabNames' loc = map (showSDoc tdflags . 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?@@ -377,66 +499,6 @@ parseSpecifically (Just (False, h)) = 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 tdflags) . 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 -> String -> String -> String -> [String] -> Ghc [(Name, [GlobalRdrElt])]-lookupSymbol ghcopts targetFile targetModuleName qualifiedSymbol importList = do- GhcMonad.liftIO $ putStrLn $ "lookupSymbol::: " ++ show (ghcopts, targetFile, targetModuleName, qualifiedSymbol, importList)-- -- Bring in the target module and its imports.- (setContext $ map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList))- `gcatch` (\(s :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "lookupSymbol: setContext failed with a SourceError, trying to continue anyway..." ++ show s- setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)- `gcatch` (\(g :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn $ "lookupSymbol: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g- setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)- `gcatch` (\(se :: SomeException) -> do GhcMonad.liftIO $ putStrLn $ "lookupSymbol: setContext failed with a SomeException, trying to continue anyway..." ++ show se- setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)-- GhcMonad.liftIO $ putStrLn $ "lookupSymbol::: continuing1..."-- -- 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-- GhcMonad.liftIO $ putStrLn $ "lookupSymbol::: continuing2..."-- -- The "guts" has the global reader environment, which we need.- let guts = coreModule d :: ModGuts- gre = HscTypes.mg_rdr_env guts :: GlobalRdrEnv-- GhcMonad.liftIO $ putStrLn $ "lookupSymbol::: continuing3..."-- -- parseName expects an unambiguous symbol otherwise it causes a- -- GHC panic. A fully qualified name should suffice. If this step- -- fails we return an empty list.- names <- (parseName qualifiedSymbol)- `gcatch` (\(s :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "lookupSymbol: parseName failed with a SourceError, trying to continue anyway..." ++ show s- return [])- `gcatch` (\(g :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn $ "lookupSymbol: parseName failed with a GhcApiError, trying to continue anyway..." ++ show g- return [])- `gcatch` (\(se :: SomeException) -> do GhcMonad.liftIO $ putStrLn $ "lookupSymbol: parseName failed with a SomeException, trying to continue anyway..." ++ show se- return [])-- GhcMonad.liftIO $ putStrLn $ "lookupSymbol::: continuing4..."- let occNames = map nameOccName names :: [OccName]- occNamesLookups = map (lookupGlobalRdrEnv gre) occNames :: [[GlobalRdrElt]]-- GhcMonad.liftIO $ putStrLn $ "lookupSymbol::: continuing5..."-- 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@@ -494,7 +556,7 @@ qualifiedName :: GhcOptions -> FilePath -> String -> Int -> Int -> [String] -> Ghc [String] qualifiedName ghcopts targetFile targetModuleName lineNr colNr importList = do- (setContext $ map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList))+ setContext (map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)) `gcatch` (\(s :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SourceError, trying to continue anyway..." ++ show s setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList) `gcatch` (\(g :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g@@ -518,6 +580,44 @@ return $ bs' ++ es' ++ ps' +-- Like qualifiedName but uses 'reallyAlwaysQualify' to show the fully qualified name, e.g.+-- "containers-0.5.6.2@conta_2C3ZI8RgPO2LBMidXKTvIU:Data.Map.Base.fromList" instead of+-- "Data.Map.Base.fromList". Will probably replace qualifiedName once more testing has+-- been done. If this works we can also remove 'ghcPkgFindModule' which uses a shell+-- call to try to find the package name.+qualifiedName' :: GhcOptions -> FilePath -> String -> Int -> Int -> String -> [String] -> Ghc [String]+qualifiedName' ghcopts targetFile targetModuleName lineNr colNr symbol importList = do+ setContext (map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList))+ `gcatch` (\(s :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SourceError, trying to continue anyway..." ++ show s+ setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)+ `gcatch` (\(g :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g+ setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)+ `gcatch` (\(se :: SomeException) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SomeException, trying to continue anyway..." ++ show se+ setContext $ map (IIDecl . simpleImportDecl . mkModuleName) 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]+ -- ls0 = listifySpans tcs (lineNr, colNr) :: [LHsBindLR Id Id]+ -- ls1 = listifySpans tcs (lineNr, colNr) :: [LIPBind Id]+ -- ls2 = listifySpans tcs (lineNr, colNr) :: [LPat Id]+ -- ls3 = listifySpans tcs (lineNr, colNr) :: [LHsDecl Id]+ -- ls4 = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id]+ -- ls5 = listifySpans tcs (lineNr, colNr) :: [LHsTupArg Id]+ -- ls6 = listifySpans tcs (lineNr, colNr) :: [LHsCmd Id]+ -- ls7 = listifySpans tcs (lineNr, colNr) :: [LHsCmdTop Id]++ let bs' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) bs+ es' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) es+ ps' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) ps++ return $ filter (postfixMatch symbol) $ concatMap words $ bs' ++ es' ++ ps'+ -- Read everything else available on a handle, and return the empty -- string if we have hit EOF. readRestOfHandle :: Handle -> IO String@@ -535,10 +635,17 @@ optsForGhcPkg ("-no-user-package-conf":rest) = "--no-user-package-conf" : optsForGhcPkg rest optsForGhcPkg (_:rest) = optsForGhcPkg rest +ghcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)+ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m =+ shortcut [ stackGhcPkgFindModule m+ , hcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m+ , _ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m+ ]+ -- | 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] -> GhcPkgOptions -> String -> IO (Maybe String)-ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m = do+_ghcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)+_ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m = do let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts putStrLn $ "ghc-pkg " ++ show opts @@ -550,14 +657,57 @@ output <- readRestOfHandle hout err <- readRestOfHandle herr - putStrLn $ "ghcPkgFindModule stdout: " ++ show output- putStrLn $ "ghcPkgFindModule stderr: " ++ show err+ putStrLn $ "_ghcPkgFindModule stdout: " ++ show output+ putStrLn $ "_ghcPkgFindModule stderr: " ++ show err return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output --- | Call @ghc-pkg field@ to get the @haddock-html@ field for a package.+-- | Call @cabal sandbox hc-pkg@ to find the package the provides a module.+hcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)+hcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m = do+ let opts = ["sandbox", "hc-pkg", "find-module", m, "--", "--simple-output"]++ (_, Just hout, Just herr, _) <- createProcess (proc "cabal" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ output <- readRestOfHandle hout+ err <- readRestOfHandle herr++ putStrLn $ "hcPkgFindModule stdout: " ++ show output+ putStrLn $ "hcPkgFindModule stderr: " ++ show err++ return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output++-- | Call @stack exec ghc-pkg@ to find the package the provides a module.+stackGhcPkgFindModule :: String -> IO (Maybe String)+stackGhcPkgFindModule m = do+ do let opts = ["exec", "ghc-pkg", "find-module", m, "--", "--simple-output"]+ (_, Just hout, Just herr, _) <- createProcess (proc "stack" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ output <- readRestOfHandle hout+ err <- readRestOfHandle herr++ putStrLn $ "stackGhcPkgFindModule stdout: " ++ show output+ putStrLn $ "stackGhcPkgFindModule stderr: " ++ show err++ return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output++ ghcPkgHaddockUrl :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)-ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do+ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p =+ shortcut [ stackPkgHaddockUrl p+ , sandboxPkgHaddockUrl p+ , _ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p+ ]++-- | Call @ghc-pkg field@ to get the @haddock-html@ field for a package.+_ghcPkgHaddockUrl :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)+_ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do let opts = ["field", p, "haddock-html"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts putStrLn $ "ghc-pkg "++ show opts @@ -569,6 +719,138 @@ line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout return $ Safe.lastMay $ words line +-- | Call cabal sandbox hc-pkg to find the haddock url.+sandboxPkgHaddockUrl :: String -> IO (Maybe String)+sandboxPkgHaddockUrl p = do+ let opts = ["sandbox", "hc-pkg", "field", p, "haddock-html"]+ putStrLn $ "cabal sandbox hc-pkg field " ++ p ++ " haddock-html"++ (_, Just hout, _, _) <- createProcess (proc "cabal" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout+ print ("line", line)++ if "haddock-html:" `isInfixOf` line+ then do print ("line2", Safe.lastMay $ words line)+ return $ Safe.lastMay $ words line+ else return Nothing++-- | Call cabal stack to find the haddock url.+stackPkgHaddockUrl :: String -> IO (Maybe String)+stackPkgHaddockUrl p = do+ let opts = ["exec", "ghc-pkg", "field", p, "haddock-html"]+ putStrLn $ "stack exec hc-pkg field " ++ p ++ " haddock-html"++ (_, Just hout, _, _) <- createProcess (proc "stack" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout+ print ("line", line)++ if "haddock-html:" `isInfixOf` line+ then do print ("line2", Safe.lastMay $ words line)+ return $ Safe.lastMay $ words line+ else return Nothing++++++++++++++ghcPkgHaddockInterface :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)+ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p =+ shortcut [ stackGhcPkgHaddockInterface p+ , cabalPkgHaddockInterface p+ , _ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p+ ]++ where++ _ghcPkgHaddockInterface :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)+ _ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do+ let opts = ["field", p, "haddock-interfaces"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts+ putStrLn $ "ghc-pkg "++ show opts++ (_, Just hout, _, _) <- createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout+ return $ Safe.lastMay $ words line++ -- | Call cabal sandbox hc-pkg to find the haddock Interfaces.+ cabalPkgHaddockInterface :: String -> IO (Maybe String)+ cabalPkgHaddockInterface p = do+ let opts = ["sandbox", "hc-pkg", "field", p, "haddock-interfaces"]+ putStrLn $ "cabal sandbox hc-pkg field " ++ p ++ " haddock-interfaces"++ (_, Just hout, _, _) <- createProcess (proc "cabal" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout+ print $ ("ZZZZZZZZZZZZZ", line)++ return $ if "haddock-interfaces" `isInfixOf` line+ then Safe.lastMay $ words line+ else Nothing++ -- | Call stack to find the haddock Interfaces.+ stackGhcPkgHaddockInterface :: String -> IO (Maybe String)+ stackGhcPkgHaddockInterface p = do+ let opts = ["exec", "ghc-pkg", "field", p, "haddock-interfaces"]+ putStrLn $ "stack exec ghc-pkg field " ++ p ++ " haddock-interfaces"++ (_, Just hout, _, _) <- createProcess (proc "stack" opts){ std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout+ print $ ("UUUUUUUUUUUUU", line, opts)++ return $ if "haddock-interfaces" `isInfixOf` line+ then Safe.lastMay $ words line+ else Nothing+++getVisibleExports :: [String] -> GhcPkgOptions -> String -> Ghc (Maybe (M.Map String [String]))+getVisibleExports allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do+ haddockInterfaceFile <- GhcMonad.liftIO $ ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p+ join <$> traverse getVisibleExports' haddockInterfaceFile++ where++ getVisibleExports' :: FilePath -> Ghc (Maybe (M.Map String [String]))+ getVisibleExports' ifile = do+ iface <- Haddock.readInterfaceFile Haddock.nameCacheFromGhc ifile++ case iface of+ Left err -> GhcMonad.liftIO $ do putStrLn $ "Failed to read the Haddock interface file: " ++ ifile+ putStrLn "You probably installed packages without using the '--enable-documentation' flag."+ putStrLn ""+ putStrLn "Try something like:\n\n\tcabal install --enable-documentation p"+ error $ "No haddock interfaces file, giving up."+ Right iface' -> do let m = map (\ii -> (Haddock.instMod ii, Haddock.instVisibleExports ii)) $ Haddock.ifInstalledIfaces iface' :: [(Module, [Name])]+ m' = map (\(mname, names) -> (showSDoc tdflags $ ppr mname, map (showSDoc tdflags . ppr) names)) m :: [(String, [String])]+ return $ Just $ M.fromList m'+++ -- | Convert a module name string, e.g. @Data.List@ to @Data-List.html@. moduleNameToHtmlFile :: String -> String moduleNameToHtmlFile m = map f m ++ ".html"@@ -576,63 +858,9 @@ 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)+{-+I don't want to use this any more. The refiner works so much better with+the local haddock interfaces file... -- | Convert a file path to a Hackage HTML file to its equivalent on @https://hackage.haskell.org@. toHackageUrl :: FilePath -> String -> String -> String@@ -652,64 +880,6 @@ substringP _ [] = Nothing substringP sub str = if sub `isPrefixOf` str then Just 0 else (+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- = case moduleOfQualifiedName name' of- Just name'' -> filter (name'' `isPrefixOf`) x'- Nothing -> []- where name' = showSDoc tdflags $ ppr name- x = concatMap symbolImportedFrom lookUp- x' = map (showSDoc tdflags . ppr) 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] -> [String] -> GhcPkgOptions -> (Name, [GlobalRdrElt]) -> IO [(Maybe String, Maybe String, Maybe String, Maybe String)]-findHaddockModule symbol'' smatches allGhcOpts ghcpkgOpts (name, lookUp) = do- -- FIXME this is messy- if isJust (moduleOfQualifiedName symbol'')- then do- let lastBitOfSymbol = last $ separateBy '.' symbol''- putStrLn $ "findHaddockModule, symbol'': " ++ symbol''- putStrLn $ "findHaddockModule, lastBitOfSymbol: " ++ lastBitOfSymbol- putStrLn $ "name: " ++ showSDoc tdflags (ppr name)-- let definedIn = nameModule name- bpms = bestPrefixMatches name lookUp- importedFrom :: [String]- importedFrom = if null smatches- then if null bpms then map (showSDoc tdflags . ppr) $ concatMap symbolImportedFrom lookUp- else catMaybes $ return $ Safe.headMay bpms- else return $ case moduleOfQualifiedName symbol'' of- Nothing -> trace "Got Nothing when looking up module of qualified name." []- Just modOfQualSym'' -> ((showSDoc tdflags . ppr) . mkModuleName) modOfQualSym''-- putStrLn $ "definedIn: " ++ showSDoc tdflags (ppr definedIn)- putStrLn $ "bpms: " ++ show bpms- putStrLn $ "concat $ map symbolImportedFrom lookUp: " ++ showSDoc tdflags (ppr $ concatMap symbolImportedFrom lookUp)--- putStrLn $ "importedFrom: " ++ show importedFrom-- forM importedFrom $ \impfrom -> do- let impfrom' = Just impfrom- foundModule <- maybe (return Nothing) (ghcPkgFindModule allGhcOpts ghcpkgOpts) impfrom'- putStrLn $ "ghcPkgFindModule result: " ++ show foundModule-- let base = moduleNameToHtmlFile <$> impfrom'-- putStrLn $ "base: : " ++ show base-- haddock <- maybe (return Nothing) (ghcPkgHaddockUrl allGhcOpts ghcpkgOpts) foundModule-- putStrLn $ "haddock: " ++ show haddock- putStrLn $ "foundModule1: " ++ show foundModule-- return (impfrom', haddock, foundModule, base)- else- return []- -- | 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) -> IO String matchToUrl (importedFrom, haddock, foundModule, base) = do@@ -732,71 +902,156 @@ putStrLn $ "foundModule2: " ++ show foundModule' putStrLn $ "calling toHackageUrl with params: " ++ show (f, foundModule', importedFrom') return $ toHackageUrl f foundModule' importedFrom'+-} +-- | Convert our match to a URL of the form @file://@ so that we can open it in a web browser.+matchToUrl :: (Maybe String, Maybe String, Maybe String, Maybe String) -> IO String+matchToUrl (importedFrom, haddock, foundModule, base) = do+ when (isNothing importedFrom) $ error "importedFrom is Nothing :("+ when (isNothing haddock) $ error "haddock is Nothing :("+ when (isNothing foundModule) $ error "foundModule is Nothing :("+ when (isNothing base) $ error "base is Nothing :(" --- | The 'concatMapM' function generalizes 'concatMap' to arbitrary monads.-concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]-concatMapM f xs = liftM concat (mapM f xs)+ let importedFrom' = fromJust importedFrom+ haddock' = fromJust haddock+ foundModule' = fromJust foundModule+ base' = fromJust base -isHidden :: String -> String -> HaskellModule -> Bool-isHidden symbol mname (HaskellModule name qualifier isImplicit hiding importedAs specifically) = mname == name && isNothing importedAs && symbol `elem` hiding+ f = haddock' </> base' + e <- doesFileExist f++ if e then return $ "file://" ++ f+ else do putStrLn $ "Please reinstall packages using the flag '--enable-documentation' for 'cabal install.\n"+ error $ "Could not find " ++ f+ filterMatchingQualifiedImport :: String -> [HaskellModule] -> [HaskellModule] filterMatchingQualifiedImport symbol hmodules = case moduleOfQualifiedName symbol of Nothing -> [] asBit@(Just _) -> filter (\z -> asBit == modImportedAs z) hmodules -isInHiddenPackage :: GhcMonad m => String -> m Bool-isInHiddenPackage mName =- (do setContext $ map (IIDecl . simpleImportDecl . mkModuleName) [mName]- -- We were able to load the package, so it is not hidden.- return False)- `gcatch` (\(_ :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "isInHiddenPackage: module " ++ mName ++ " is in a hidden package."- return True)+-- Copied from ghc-mod-5.5.0.0+findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle+findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog)) +getModuleExports :: GhcOptions+ -> GhcPkgOptions+ -> HaskellModule+ -> Ghc (Maybe ([String], String))+getModuleExports (GhcOptions ghcOpts) ghcPkgOpts m = do+ minfo <- ((findModule (mkModuleName $ modName m) Nothing) >>= getModuleInfo)+ `gcatch` (\(e :: SourceError) -> return Nothing) -finalCase :: [String] -> String -> String -> [Char] -> [[Char]] -> Ghc [String]-finalCase ghcOpts0 targetFile targetModule symbol haskellModuleNames' = do- blah <- forM haskellModuleNames' $ \hm -> do fff <- lookupSymbol (GhcOptions ghcOpts0) targetFile targetModule (hm ++ "." ++ symbol) haskellModuleNames'- if (length fff) > 0- then do GhcMonad.liftIO $ putStrLn $ "finalCase: " ++ hm- return [hm]- else return []- return $ concat blah+ p <- GhcMonad.liftIO $ ghcPkgFindModule ghcOpts ghcPkgOpts (modName m) -actualFinalCase allGhcOpts ghcpkgOptions targetFile targetModule symbol haskellModuleNames' = do- -- This is getting ridiculous...- GhcMonad.liftIO $ putStrLn "last bits 1..."- zzz <- finalCase allGhcOpts targetFile targetModule symbol haskellModuleNames'- GhcMonad.liftIO $ putStrLn "last bits 2..."- yyy <- forM zzz $ \r -> do p <- GhcMonad.liftIO $ ghcPkgFindModule allGhcOpts ghcpkgOptions r- GhcMonad.liftIO $ print $ "forM_ last bits: " ++ show p- case p of Nothing -> return []- (Just _) -> return [(r, fromJust p)]+ case (minfo, p) of+ (Nothing, _) -> return Nothing+ (_, Nothing) -> return Nothing+ (Just minfo', Just p') -> return $ Just (map (showSDocForUser tdflags reallyAlwaysQualify . ppr) $ modInfoExports minfo', p') - let yyy' = concat yyy+type UnqualifiedName = String -- ^ e.g. "Just"+type FullyQualifiedName = String -- ^ e.g. e.g. "base-4.8.2.0:Data.Foldable.length"+type StrModuleName = String -- ^ e.g. "Data.List" - GhcMonad.liftIO $ putStrLn "last bits 3..."- -- FIXME why don't we have the full ghc options right now? More than just the user-supplied ones?- yyy'' <- forM yyy' $ \(mname, pname) -> do haddock <- GhcMonad.liftIO $ ghcPkgHaddockUrl allGhcOpts (GhcPkgOptions allGhcOpts) pname- if isJust haddock- then do GhcMonad.liftIO $ putStrLn $ "last bits 3 inner loop: " ++ show haddock- url <- GhcMonad.liftIO $ matchToUrl (Just mname, haddock, Just mname, Just $ moduleNameToHtmlFile mname)- return $ Just url- else return Nothing+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 - GhcMonad.liftIO $ putStrLn $ "yyy'': " ++ show yyy''+data ModuleExports = ModuleExports+ { mName :: StrModuleName -- ^ e.g. "Data.List"+ , mPackageName :: String -- ^ e.g. "snap-0.14.0.6"+ , mInfo :: HaskellModule -- ^ 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 - GhcMonad.liftIO $ putStrLn "last bits 4..."- let yyy''' = catMaybes yyy''- GhcMonad.liftIO $ print $ "yyy''': " ++ (show yyy''')+pprModuleExports :: ModuleExports -> String+pprModuleExports me = mName me ++ "\n" ++ show (mInfo me) ++ "\n" ++ unwords (map show $ qualifiedExports me) - return yyy'''+refineAs :: MySymbol -> [ModuleExports] -> [ModuleExports] --- Copied from ghc-mod-5.5.0.0-findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle-findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))+-- User qualified the symbol, so we can filter out anything that doesn't have a matching 'modImportedAs'.+refineAs (MySymbolUserQualified userQualSym) exports = filter f exports+ where+ f export = case modas of+ Nothing -> False+ Just modas' -> modas' == userQualAs+ where modas = modImportedAs $ mInfo export :: Maybe String + -- e.g. "DL"+ userQualAs = fromMaybe (error $ "Expected a qualified name like 'DL.length' but got: " ++ userQualSym)+ (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 :: String -> [ModuleExports] -> [ModuleExports]+refineRemoveHiding symbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports+ where+ f symbol 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.++ qualifyName :: [QualifiedName] -> Symbol -> QualifiedName+ qualifyName qualifiedNames name+ = case filter (postfixMatch name) qualifiedNames of+ [match] -> match+ _ -> error $ "Could not qualify " ++ name ++ " from these exports: " ++ show qualifiedNames++refineExportsIt :: String -> [ModuleExports] -> [ModuleExports]+refineExportsIt symbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports+ where+ -- f symbol export = filter (symbol ==) thisExports+ f symbol export = filter (postfixMatch symbol) thisExports+ where thisExports = qualifiedExports export -- Things that this module exports.++refineLeadingDot :: MySymbol -> [ModuleExports] -> [ModuleExports]+refineLeadingDot (MySymbolUserQualified userQualSym) exports = exports+refineLeadingDot (MySymbolSysQualified symb) exports = map (\e -> e { qualifiedExports = f leadingDot e }) exports+ where+ leadingDot :: String+ leadingDot = '.' : last (separateBy '.' symb)++ -- f symbol export = filter (symbol ==) thisExports+ f symbol export = filter (symbol `isSuffixOf`) thisExports+ where thisExports = qualifiedExports export -- Things that this module exports.++refineVisibleExports :: [String] -> GhcPkgOptions -> [ModuleExports] -> Ghc [ModuleExports]+refineVisibleExports allGhcOpts ghcpkgOptions exports = mapM f exports+ where+ f :: ModuleExports -> Ghc 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 <- getVisibleExports allGhcOpts ghcpkgOptions pname+ GhcMonad.liftIO $ print visibleExportsMap++ let thisModVisibleExports = fromMaybe+ (error $ "Could not get visible exports of " ++ pname)+ (join $ traverse (M.lookup thisModuleName) visibleExportsMap)++ let qexports' = filter (hasPostfixMatch thisModVisibleExports) qexports++ GhcMonad.liftIO $ print (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 (separateBy '.' 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+ -- | 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. --@@ -806,9 +1061,9 @@ -- (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 -> IO (Either String [String])+guessHaddockUrl :: FilePath -> String -> Symbol -> Int -> Int -> GhcOptions -> GhcPkgOptions -> IO (Either String String) guessHaddockUrl _targetFile targetModule symbol lineNr colNr (GhcOptions ghcOpts0) ghcpkgOptions = do- cradle <- runGmOutT GhcModTypes.defaultOptions $ findCradleNoLog+ cradle <- runGmOutT GhcModTypes.defaultOptions findCradleNoLog let currentDir = cradleCurrentDir cradle workDir = cradleRootDir cradle setCurrentDirectory workDir@@ -827,7 +1082,6 @@ putStrLn $ "ghcOpts0: " ++ show ghcOpts0 putStrLn $ "ghcpkgOptions: " ++ show ghcpkgOptions - -- Put a runGhc up here, then change the types further down??? runGhc (Just libdir) $ do (allGhcOpts, textualImports) <- getTextualImports (GhcOptions ghcOpts0) targetFile targetModule @@ -843,87 +1097,123 @@ let haskellModuleNames = if null filterThings then map modName haskellModules0 else map modName filterThings qnames <- filter (not . (' ' `elem`)) <$> qualifiedName (GhcOptions ghcOpts0) targetFile targetModule lineNr colNr haskellModuleNames- GhcMonad.liftIO $ putStrLn $ "qualified names: " ++ show qnames - let matchingAsImport = expandMatchingAsImport symbol (map toHaskellModule textualImports)- GhcMonad.liftIO $ putStrLn $ "matchingAsImport: " ++ show matchingAsImport+ qnames_with_qualified_printing <- filter (not . (' ' `elem`)) <$> qualifiedName' (GhcOptions ghcOpts0) targetFile targetModule lineNr colNr symbol haskellModuleNames :: Ghc [String]+ GhcMonad.liftIO $ putStrLn $ "qualified names with qualified printing: " ++ show qnames_with_qualified_printing - let postMatches = filter (postfixMatch symbol) qnames :: [String]- symbol' = fromMaybe (if null postMatches then symbol else minimumBy (compare `on` length) postMatches) matchingAsImport+ let parsedPackagesAndQualNames :: [Either TP.ParseError (String, String)]+ parsedPackagesAndQualNames = map (TP.parse parsePackageAndQualName "") qnames_with_qualified_printing - GhcMonad.liftIO $ putStrLn $ "postMatches: " ++ show postMatches- GhcMonad.liftIO $ putStrLn $ "symbol': " ++ symbol'+ GhcMonad.liftIO $ putStrLn $ "qqqqqq1: " ++ show parsedPackagesAndQualNames - let maybeExtraModule = moduleOfQualifiedName symbol'+ let symbolToUse :: String+ symbolToUse = fromMaybe (head qnames) (Safe.headMay qnames_with_qualified_printing) -- FIXME dodgy use of 'head' - -- The module maybeExtraModule might be hidden. Check this.- extraIsHidden <- case maybeExtraModule of Just x -> isInHiddenPackage x- Nothing -> return False- GhcMonad.liftIO $ putStrLn $ "extraIsHidden: " ++ show extraIsHidden+ GhcMonad.liftIO $ print ("symbolToUse", symbolToUse) - let maybeExtraModule' = if extraIsHidden- then []- else if isJust maybeExtraModule- then [fromJust maybeExtraModule]- else []+ -- Possible extra modules...+ let extraModules :: [HaskellModule]+ extraModules = case Safe.headMay parsedPackagesAndQualNames of+ Just (Right (_, x)) -> case moduleOfQualifiedName x of Just x' -> [ HaskellModule { modName = x'+ , modQualifier = Nothing+ , modIsImplicit = False+ , modHiding = []+ , modImportedAs = Nothing+ , modSpecifically = []+ }+ ]+ Nothing -> []+ _ -> [] - let haskellModuleNames' = if symbol == symbol' then haskellModuleNames else haskellModuleNames ++ maybeExtraModule'+ GhcMonad.liftIO $ print extraModules - GhcMonad.liftIO $ putStrLn $ "maybeExtraModule: " ++ show maybeExtraModule- GhcMonad.liftIO $ putStrLn $ "maybeExtraModule': " ++ show maybeExtraModule'- GhcMonad.liftIO $ putStrLn $ "haskellModuleNames': " ++ show haskellModuleNames'+ -- Try to use the qnames_with_qualified_printing case, which has something like "base-4.8.2.0:GHC.Base.map",+ -- which will be more accurate to filter on. - let smatches = specificallyMatches symbol (map toHaskellModule textualImports)- GhcMonad.liftIO $ putStrLn $ "smatches: " ++ show smatches+ exports <- mapM (getModuleExports (GhcOptions ghcOpts0) ghcpkgOptions) (haskellModules0 ++ extraModules) - let symbol'' = if null smatches- then symbol'- else modName (head smatches) ++ "." ++ symbol+ -- Sometimes the modules in extraModules might be hidden or weird ones like GHC.Base that we can't+ -- load, so filter out the successfully loaded ones.+ let successes :: [(HaskellModule, Maybe ([String], String))]+ successes = filter (isJust . snd) (zip (haskellModules0 ++ extraModules) exports) - -- Sometimes our attempt to resolve symbol to symbol'' fails, e.g. in a Yesod 1.4 project- -- I had "Database.Persist.Sql.createPoolConfig" which resolved to "Database.Persist.Class.PersistConfig.createPoolConfig".- -- So here we try with the original symbol provided by the user (which might have been a fully qualified name) and then- -- our attempt at resolving it. So many corner cases :(- r1 <- rest ghcOpts0 ghcpkgOptions allGhcOpts targetFile targetModule smatches haskellModuleNames' haskellModules symbol symbol- r2 <- rest ghcOpts0 ghcpkgOptions allGhcOpts targetFile targetModule smatches haskellModuleNames' haskellModules symbol symbol''+ bubble :: (HaskellModule, Maybe ([FullyQualifiedName], String)) -> Maybe (HaskellModule, ([FullyQualifiedName], String))+ bubble (h, Just x) = Just (h, x)+ bubble (_, Nothing) = Nothing - return $ case (r1, r2) of- (Right r1', _) -> Right r1'- (Left _, Right r2') -> Right r2'- (Left l1, _) -> Left l1- (_, Left l2) -> Left l2+ successes' :: [(HaskellModule, ([String], String))]+ successes' = mapMaybe bubble successes -rest ghcOpts0 ghcpkgOptions allGhcOpts targetFile targetModule smatches haskellModuleNames' haskellModules symbol symbol'' = do+ upToNow = map (\(m, (e, p)) -> ModuleExports+ { mName = modName m+ , mPackageName = p+ , mInfo = m+ , qualifiedExports = e+ }) successes' - GhcMonad.liftIO $ putStrLn $ "symbol'': " ++ symbol''+ GhcMonad.liftIO $ forM_ upToNow $ \x -> putStrLn $ pprModuleExports x - let allJust (a, b, c, d) = isJust a && isJust b && isJust c && isJust d+ -- Get all "as" imports.+ let asImports :: [String]+ asImports = mapMaybe (modImportedAs . mInfo) upToNow - -- Then this does a runGhc as well.- final1 <- lookupSymbol (GhcOptions ghcOpts0) targetFile targetModule symbol'' haskellModuleNames'+ -- Can a user do "import xxx as Foo.Bar"??? Check this. - final1' <- GhcMonad.liftIO $ concatMapM (findHaddockModule symbol'' smatches allGhcOpts ghcpkgOptions) final1- GhcMonad.liftIO $ putStrLn $ "final1': " ++ show final1'+ let mySymbol = case moduleOfQualifiedName symbol of+ Nothing -> MySymbolSysQualified symbolToUse+ Just x -> if x `elem` asImports+ then MySymbolUserQualified symbol+ else MySymbolSysQualified symbolToUse - -- Remove any modules that have this name hidden.- -- e.g. import Data.List hiding (map)- let final1'' = filter (\(a,_,_,_) -> case a of Just a' -> not $ any (isHidden symbol a') haskellModules- Nothing -> False) final1'- GhcMonad.liftIO $ putStrLn $ "final1'': " ++ show final1''- GhcMonad.liftIO $ putStrLn $ show (symbol, haskellModules)+ GhcMonad.liftIO $ print mySymbol - let final2 = filter allJust final1''- final3 <- GhcMonad.liftIO $ mapM matchToUrl final2+ let upToNow0 = refineAs mySymbol upToNow+ GhcMonad.liftIO $ putStrLn "upToNow0"+ GhcMonad.liftIO $ forM_ upToNow0 $ \x -> putStrLn $ pprModuleExports x - GhcMonad.liftIO $ putStrLn "last bits 5..."- if null final3- then do yyy''' <- actualFinalCase ghcOpts0 ghcpkgOptions targetFile targetModule symbol haskellModuleNames'- if null yyy'''- then return $ Left $ "No matches found."- else return $ Right yyy'''- else return $ Right final3+ let upToNow1 = refineRemoveHiding symbolToUse upToNow0+ GhcMonad.liftIO $ putStrLn "upToNow1"+ GhcMonad.liftIO $ forM_ upToNow1 $ \x -> putStrLn $ pprModuleExports x + let upToNow2 = refineExportsIt symbolToUse upToNow1+ GhcMonad.liftIO $ putStrLn "upToNow2"+ GhcMonad.liftIO $ forM_ upToNow2 $ \x -> putStrLn $ pprModuleExports x++ let upToNow3 = refineLeadingDot mySymbol upToNow2+ GhcMonad.liftIO $ putStrLn "upToNow3"+ GhcMonad.liftIO $ forM_ upToNow3 $ \x -> putStrLn $ pprModuleExports x++ upToNow4 <- refineVisibleExports allGhcOpts ghcpkgOptions upToNow3+ GhcMonad.liftIO $ putStrLn "upToNow4"+ GhcMonad.liftIO $ forM_ upToNow4 $ \x -> putStrLn $ pprModuleExports x++ let lastMatch3 = getLastMatch upToNow3+ lastMatch4 = getLastMatch upToNow4+ lastMatch = Safe.headMay $ catMaybes [lastMatch4, lastMatch3]++ GhcMonad.liftIO $ print $ "last match: " ++ show lastMatch++ -- "last match: Just (ModuleExports {mName = \"Control.Monad\", mInfo = HaskellModule {modName = \"Control.Monad\", modQualifier = Nothing, modIsImplicit = False, modHiding = [], modImportedAs = Nothing, modSpecifically = [\"forM_\",\"liftM\",\"filterM\",\"when\",\"unless\"]}, qualifiedExports = [\"base-4.8.2.0:GHC.Base.when\"]})"++ let matchedModule :: String+ matchedModule = case mName <$> lastMatch of+ Just mod -> mod+ _ -> error $ "No nice match in lastMatch for module: " ++ show lastMatch++ let matchedPackageName :: String+ matchedPackageName = case mPackageName <$> lastMatch of+ Just p -> p+ _ -> error $ "No nice match in lastMatch for package name: " ++ show lastMatch++ haddock <- GhcMonad.liftIO $ (maybe (return Nothing) (ghcPkgHaddockUrl allGhcOpts ghcpkgOptions) . Just) matchedPackageName++ GhcMonad.liftIO $ putStrLn $ "at the end now: " ++ show (matchedModule, moduleNameToHtmlFile matchedModule, matchedPackageName, haddock)++ url <- GhcMonad.liftIO $ matchToUrl (Just matchedModule, haddock, Just matchedModule, Just $ moduleNameToHtmlFile matchedModule)++ return $ Right url+ -- | Top level function; use this one from src/Main.hs. haddockUrl :: Options -> FilePath -> String -> String -> Int -> Int -> IO String haddockUrl opt file modstr symbol lineNr colNr = do@@ -931,13 +1221,8 @@ let ghcopts = GhcOptions $ ghcOpts opt let ghcpkgopts = GhcPkgOptions $ ghcPkgOpts opt - res <- (guessHaddockUrl file modstr symbol lineNr colNr ghcopts ghcpkgopts)- -- `gcatch` (\(s :: SourceError) -> return $ Left $ "guessHaddockUrl failed with a SourceError... " ++ show s)- -- `gcatch` (\(g :: GhcApiError) -> return $ Left $ "guessHaddockUrl failed with a GhcApiError... " ++ show g)- -- `gcatch` (\(se :: SomeException) -> return $ Left $ "guessHaddockUrl failed with a SomeException... " ++ show se)+ res <- guessHaddockUrl file modstr symbol lineNr colNr ghcopts ghcpkgopts+ print ("res", show res) - case res of Right x -> return $ (if length x > 1 then "WARNING: Multiple matches! Showing them all.\n" else "")- ++ (concat $ map (\z -> "SUCCESS: " ++ z ++ "\n") (reverse x)) -- Why reverse? To show the first one last, which the vim plugin will get.- -- This is flaky but will make it behave as earlier versions did, which used- -- Safe.headMay to get the first result.+ case res of Right x -> return $ "SUCCESS: " ++ x ++ "\n" Left err -> return $ "FAIL: " ++ show err ++ "\n"
README.md view
@@ -4,75 +4,48 @@ Example: on the file [src/Main.hs](https://github.com/carlohamalainen/ghc-imported-from/blob/master/src/Main.hs), - ghc-imported-from haddock-url src/Main.hs Main getArgs 69 13+ ghc-imported-from src/Main.hs Main strOption 18 17 says - SUCCESS: file:///home/carlo/opt/ghc-7.6.3_build/share/doc/ghc/html/libraries/base-4.6.0.1/System-Environment.html+ SUCCESS: file:///home/carlo/.stack/snapshots/x86_64-linux/lts-5.8/7.10.3/doc/optparse-applicative-0.12.1.0/Options-Applicative-Builder.html -since the usage of ```getArgs``` at line 160, column 13, is from the ```System.Environment``` module.+since the usage of ```strOption``` at line 18, column 17, is from the ```Options.Applicative.Builder``` module. -Difficulties arise because some symbols are exported from a certain+Difficulties arise in resolving names 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.--## Beware--You may have to run-- cabal build--or-- cabal repl--in a project directory to sort out some of the ```dist/build/autogen```-files. At the moment ```ghc-imported-from``` has no functionality to-do this boot process automatically. To run ```cabal repl``` you might need-the latest Cabal from [https://github.com/haskell/cabal](https://github.com/haskell/cabal).--If you see-- <command line>: cannot satisfy -package hspec- (use -v for more information)--then you may need the hspec and/or doctest packages:-- cabal install hspec doctest--Feedback and pull requests most welcome!--## Install+## Using with Stack -### ghc-imported-from+[Stack](http://docs.haskellstack.org/en/stable/README/) makes everything easier. -Install into ```~/.cabal```:+Build ghc-imported-from: git clone https://github.com/carlohamalainen/ghc-imported-from cd ghc-imported-from- cabal install+ stack build -Or, install into a sandbox:+then add - git clone https://github.com/carlohamalainen/ghc-imported-from- cd ghc-imported-from- ./build_in_sandbox.sh+ `pwd`/.stack-work/install/x86_64-linux/lts-5.8/7.10.3/bin -Either way, ensure that ```ghc-imported-from``` and ```fake-ghc-for-ghc-imported-from``` are in the current PATH.+or similar to your ```$PATH```. -### Tests+Then in a project that you are working on: -Run the tests using cabal:+ cd my-project+ stack build+ stack haddock # Must do this!+ ghc-imported-from some/file/Blah.hs Blah f 100 3 - cabal test+### Tests -If the tests hang, check that your version of Cabal/cabal-install has this-fix: https://github.com/haskell/cabal/issues/1810+Run the tests using Stack:++ stack test ### ghcimportedfrom-vim
changelog.md view
@@ -1,3 +1,8 @@+2016-03-26 v0.3.0.0++* New heuristics for resolving symbols.+* Compatability with Stack!+ 2016-01-20 v0.2.1.1 * Builds against ghc-mod-5.5.0.0.
ghc-imported-from.cabal view
@@ -1,5 +1,5 @@ name: ghc-imported-from-version: 0.2.1.1+version: 0.3.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.@@ -41,6 +41,7 @@ , transformers , parsec , optparse-applicative+ , haddock-api if impl(ghc < 7.7) Build-Depends: Cabal >= 1.10 && < 1.17 else@@ -79,6 +80,7 @@ , parsec , optparse-applicative , hspec+ , haddock-api if impl(ghc < 7.7) Build-Depends: Cabal >= 1.10 && < 1.17@@ -113,6 +115,7 @@ , parsec , optparse-applicative , hspec+ , haddock-api if impl(ghc < 7.7) Build-Depends: Cabal >= 1.10 && < 1.17 else