diff --git a/Language/Haskell/GhcImportedFrom.hs b/Language/Haskell/GhcImportedFrom.hs --- a/Language/Haskell/GhcImportedFrom.hs +++ b/Language/Haskell/GhcImportedFrom.hs @@ -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" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 - - : 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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/ghc-imported-from.cabal b/ghc-imported-from.cabal --- a/ghc-imported-from.cabal +++ b/ghc-imported-from.cabal @@ -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