diff --git a/Language/Haskell/GhcImportedFrom.hs b/Language/Haskell/GhcImportedFrom.hs --- a/Language/Haskell/GhcImportedFrom.hs +++ b/Language/Haskell/GhcImportedFrom.hs @@ -117,7 +117,7 @@ then return "" else do firstLine <- hGetLine hout if "GHCi" `isPrefixOf` firstLine - then return "DERP" -- stuffed up, should report error + then return "DERP" -- stuffed up, should report error - FIXME change this to an error or something? else do rest <- readRestOfHandle hout return $ firstLine ++ "\n" ++ rest @@ -202,22 +202,20 @@ -- -- See also 'toHaskellModule' and 'getSummary'. -getTextualImports :: GhcOptions -> FilePath -> String -> IO [SrcLoc.Located (ImportDecl RdrName)] +getTextualImports :: GhcMonad m => GhcOptions -> FilePath -> String -> m [SrcLoc.Located (ImportDecl RdrName)] getTextualImports ghcopts targetFile targetModuleName = do - putStrLn $ "getTextualImports: " ++ show (targetFile, targetModuleName) + GhcMonad.liftIO $ putStrLn $ "getTextualImports: " ++ show (targetFile, targetModuleName) (ghcOpts1, ghcOpts2, modSum) <- getSummary ghcopts targetFile targetModuleName - putStrLn $ "getTextualImports: ghcOpts1: " ++ show ghcOpts1 - putStrLn $ "getTextualImports: ghcOpts2: " ++ show ghcOpts2 + GhcMonad.liftIO $ putStrLn $ "getTextualImports: ghcOpts1: " ++ show ghcOpts1 + GhcMonad.liftIO $ putStrLn $ "getTextualImports: ghcOpts2: " ++ show ghcOpts2 return $ ms_textual_imps modSum -- | Get the module summary for a particular file/module. The first and second components of the -- return value are @ghcOpts1@ and @ghcOpts2@; see 'setDynamicFlags'. -getSummary :: GhcOptions -> FilePath -> String -> IO ([String], [GHCOption], ModSummary) -getSummary ghcopts targetFile targetModuleName = - -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ - runGhc (Just libdir) $ do +getSummary :: GhcMonad m => GhcOptions -> FilePath -> String -> m ([String], [GHCOption], ModSummary) +getSummary ghcopts targetFile targetModuleName = do GhcMonad.liftIO $ putStrLn $ "getSummary, setting dynamic flags..." (ghcOpts1, ghcOpts2, _) <- getSessionDynFlags >>= setDynamicFlags ghcopts @@ -231,14 +229,19 @@ GhcMonad.liftIO $ putStrLn $ "getSummary, setting the context..." (setContext [(IIDecl . simpleImportDecl . mkModuleName) targetModuleName]) - `gcatch` (\(_ :: SourceError) -> GhcMonad.liftIO (putStrLn "getSummary: setContext failed with a SourceError, trying to continue anyway...")) - `gcatch` (\(_ :: GhcApiError) -> GhcMonad.liftIO (putStrLn "getSummary: setContext failed with a GhcApiError, trying to continue anyway...")) - `gcatch` (\(_ :: SomeException) -> GhcMonad.liftIO (putStrLn "getSummary: setContext failed with a SomeException, trying to continue anyway...")) + `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..." modSum <- getModSummary (mkModuleName targetModuleName) + -- graph <- GHC.depanal [] False + -- -- graph <- getModuleGraph + -- let graph_names = map (GHC.moduleNameString . GHC.ms_mod_name) graph + -- GhcMonad.liftIO $ print $ "graph_names: " ++ show graph_names + return (ghcOpts1, ghcOpts2, modSum) -- |Convenience function for converting an 'GHC.ImportDecl' to a 'HaskellModule'. @@ -333,42 +336,52 @@ -- imported from `Data.List' at tests/data/data/Hiding.hs:5:1-29 -- (and originally defined in `base:GHC.List')])] -lookupSymbol :: GhcOptions -> FilePath -> String -> String -> [String] -> IO [(Name, [GlobalRdrElt])] -lookupSymbol ghcopts targetFile targetModuleName qualifiedSymbol importList = - -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ - runGhc (Just libdir) $ do - _ <- getSessionDynFlags >>= setDynamicFlags ghcopts - - target <- guessTarget targetFile Nothing - setTargets [target] - _ <- load LoadAllTargets +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` (\(_ :: SourceError) -> do GhcMonad.liftIO $ putStrLn "lookupSymbol: setContext failed with a SourceError, trying to continue anyway..." + `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` (\(_ :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn "lookupSymbol: setContext failed with a GhcApiError, trying to continue anyway..." + `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` (\(_ :: SomeException) -> do GhcMonad.liftIO $ putStrLn "lookupSymbol: setContext failed with a SomeException, trying to continue anyway..." + `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 - -- Beware that parseName expects an unambiguous symbol otherwise it causes a - -- GHC panic. A fully qualified name should suffice. Is there a way to - -- catch this exception? - names <- parseName qualifiedSymbol + 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 @@ -407,7 +420,7 @@ -- -- >>> moduleOfQualifiedName "Foo.bar" -- Just "Foo" --- >>> moduleOfQualifiedName "bar" +-- >>> moduleOfQualifiedName "Foo" -- Nothing moduleOfQualifiedName :: QualifiedName -> Maybe String moduleOfQualifiedName qn = if null bits @@ -426,20 +439,15 @@ -- "Data.Map.Base.fromList [(\"x\", \"y\")]" -- "Data.Map.Base.fromList" -qualifiedName :: GhcOptions -> FilePath -> String -> Int -> Int -> [String] -> IO [String] -qualifiedName ghcopts targetFile targetModuleName lineNr colNr importList = - -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ - runGhc (Just libdir) $ do - _ <- getSessionDynFlags >>= setDynamicFlags ghcopts - - target <- guessTarget targetFile Nothing - setTargets [target] - _ <- load LoadAllTargets - +qualifiedName :: GhcOptions -> FilePath -> String -> Int -> Int -> [String] -> Ghc [String] +qualifiedName ghcopts targetFile targetModuleName lineNr colNr importList = do (setContext $ map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)) - `gcatch` (\(_ :: SourceError) -> GhcMonad.liftIO $ putStrLn "qualifiedName: setContext failed with a SourceError, trying to continue anyway...") - `gcatch` (\(_ :: GhcApiError) -> GhcMonad.liftIO $ putStrLn "qualifiedName: setContext failed with a GhcApiError, trying to continue anyway...") - `gcatch` (\(_ :: SomeException) -> GhcMonad.liftIO $ putStrLn "qualifiedName: setContext failed with a SomeException, trying to continue anyway...") + `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 @@ -607,20 +615,23 @@ -- | Find the haddock module. Returns a 4-tuple consisting of: module that the symbol is imported -- from, haddock url, module, and module's HTML filename. -findHaddockModule :: QualifiedName -> [HaskellModule] -> GhcPkgOptions -> (Name, [GlobalRdrElt]) -> IO (Maybe String, Maybe String, Maybe String, Maybe String) +findHaddockModule :: QualifiedName -> [HaskellModule] -> GhcPkgOptions -> (Name, [GlobalRdrElt]) -> IO [(Maybe String, Maybe String, Maybe String, Maybe String)] findHaddockModule symbol'' smatches ghcpkgOpts (name, lookUp) = do + -- FIXME this is messy - the code below has a dodgy fromJust... + 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 Safe.headMay $ concatMap symbolImportedFrom lookUp :: Maybe ModuleName - -- FIXME should really return *all* of these matches, not just the first one. We - -- can't be certain that we're choosing the best one. Ditto for all other - -- uses of head or Safe.headMay. - then if null bpms then Safe.headMay $ map (showSDoc tdflags . ppr) $ concatMap symbolImportedFrom lookUp - else Safe.headMay bpms :: Maybe String - else (Just . (showSDoc tdflags . ppr) . mkModuleName . fromJust . moduleOfQualifiedName) symbol'' -- FIXME dangerous fromJust + then if null bpms then map (showSDoc tdflags . ppr) $ concatMap symbolImportedFrom lookUp + else catMaybes $ return $ Safe.headMay bpms + else return $ ((showSDoc tdflags . ppr) . mkModuleName . fromJust . moduleOfQualifiedName) symbol'' -- FIXME dangerous fromJust putStrLn $ "definedIn: " ++ showSDoc tdflags (ppr definedIn) putStrLn $ "bpms: " ++ show bpms @@ -629,24 +640,32 @@ putStrLn $ "importedFrom: " ++ show importedFrom - foundModule <- maybe (return Nothing) (ghcPkgFindModule ghcpkgOpts) importedFrom - putStrLn $ "ghcPkgFindModule result: " ++ show foundModule + forM importedFrom $ \impfrom -> do + let impfrom' = Just impfrom + foundModule <- maybe (return Nothing) (ghcPkgFindModule ghcpkgOpts) impfrom' + putStrLn $ "ghcPkgFindModule result: " ++ show foundModule - let base = moduleNameToHtmlFile <$> importedFrom + let base = moduleNameToHtmlFile <$> impfrom' - putStrLn $ "base: : " ++ show base + putStrLn $ "base: : " ++ show base - -- haddock <- fmap (filter ('"' /=)) <$> maybe (return Nothing) (ghcPkgHaddockUrl ghcPkgOpts) foundModule - haddock <- maybe (return Nothing) (ghcPkgHaddockUrl ghcpkgOpts) foundModule + haddock <- maybe (return Nothing) (ghcPkgHaddockUrl ghcpkgOpts) foundModule - putStrLn $ "haddock: " ++ show haddock - putStrLn $ "foundModule: " ++ show foundModule + putStrLn $ "haddock: " ++ show haddock + putStrLn $ "foundModule1: " ++ show foundModule - return (importedFrom, haddock, foundModule, base) + 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 + 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 :(" + let importedFrom' = fromJust importedFrom haddock' = fromJust haddock foundModule' = fromJust foundModule @@ -658,10 +677,70 @@ if e then return $ "file://" ++ f else do putStrLn $ "f: " ++ show f - putStrLn $ "foundModule: " ++ show foundModule' - return $ toHackageUrl f foundModule' (showSDoc tdflags (ppr importedFrom')) + putStrLn $ "foundModule2: " ++ show foundModule' + putStrLn $ "calling toHackageUrl with params: " ++ show (f, foundModule', importedFrom') + return $ toHackageUrl f foundModule' importedFrom' +-- | 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) + +isHidden :: String -> String -> HaskellModule -> Bool +isHidden symbol mname (HaskellModule name qualifier isImplicit hiding importedAs specifically) = mname == name && isNothing importedAs && symbol `elem` hiding + +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) + + +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 + +actualFinalCase ghcOpts0 ghcpkgOptions targetFile targetModule symbol haskellModuleNames' = do + -- This is getting ridiculous... + GhcMonad.liftIO $ putStrLn "last bits 1..." + zzz <- finalCase ghcOpts0 targetFile targetModule symbol haskellModuleNames' + GhcMonad.liftIO $ putStrLn "last bits 2..." + yyy <- forM zzz $ \r -> do p <- GhcMonad.liftIO $ ghcPkgFindModule ghcpkgOptions r + GhcMonad.liftIO $ print $ "forM_ last bits: " ++ show p + case p of Nothing -> return [] + (Just _) -> return [(r, fromJust p)] + + let yyy' = concat yyy + + 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 (GhcPkgOptions ghcOpts0) 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 + + GhcMonad.liftIO $ putStrLn $ "yyy'': " ++ show yyy'' + + GhcMonad.liftIO $ putStrLn "last bits 4..." + let yyy''' = catMaybes yyy'' + GhcMonad.liftIO $ print $ "yyy''': " ++ (show yyy''') + + return yyy''' + -- | 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. -- @@ -671,7 +750,7 @@ -- (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 <- findCradle let currentDir = cradleCurrentDir cradle @@ -689,50 +768,89 @@ putStrLn $ "ghcOpts0: " ++ show ghcOpts0 putStrLn $ "ghcpkgOptions: " ++ show ghcpkgOptions - textualImports <- getTextualImports (GhcOptions ghcOpts0) targetFile targetModule + -- Put a runGhc up here, then change the types further down??? + runGhc (Just libdir) $ do + textualImports <- getTextualImports (GhcOptions ghcOpts0) targetFile targetModule - let haskellModuleNames = map (modName . toHaskellModule) textualImports - putStrLn $ "haskellModuleNames: " ++ show haskellModuleNames + let haskellModules0 = map toHaskellModule textualImports + haskellModuleNames0 = map modName haskellModules0 + GhcMonad.liftIO $ putStrLn $ "haskellModuleNames0: " ++ show haskellModuleNames0 + GhcMonad.liftIO $ putStrLn $ "haskellModuleNames0 (full detail): " ++ show haskellModules0 - qnames <- filter (not . (' ' `elem`)) <$> qualifiedName (GhcOptions ghcOpts0) targetFile targetModule lineNr colNr haskellModuleNames + -- If symbol is something like DM.lookup, then restrict haskellModuleNames to the + -- one that has modImportedAs == Just "DM". + let filterThings = filterMatchingQualifiedImport symbol haskellModules0 + let haskellModules = if null filterThings then haskellModules0 else filterThings + let haskellModuleNames = if null filterThings then map modName haskellModules0 else map modName filterThings - putStrLn $ "qualified names: " ++ show qnames + qnames <- filter (not . (' ' `elem`)) <$> qualifiedName (GhcOptions ghcOpts0) targetFile targetModule lineNr colNr haskellModuleNames - let matchingAsImport = expandMatchingAsImport symbol (map toHaskellModule textualImports) - putStrLn $ "matchingAsImport: " ++ show matchingAsImport + GhcMonad.liftIO $ putStrLn $ "qualified names: " ++ show qnames - let postMatches = filter (postfixMatch symbol) qnames :: [String] - symbol' = fromMaybe (if null postMatches then symbol else minimumBy (compare `on` length) postMatches) matchingAsImport + let matchingAsImport = expandMatchingAsImport symbol (map toHaskellModule textualImports) + GhcMonad.liftIO $ putStrLn $ "matchingAsImport: " ++ show matchingAsImport - putStrLn $ "postMatches: " ++ show postMatches - putStrLn $ "symbol': " ++ symbol' + let postMatches = filter (postfixMatch symbol) qnames :: [String] + symbol' = fromMaybe (if null postMatches then symbol else minimumBy (compare `on` length) postMatches) matchingAsImport - let maybeExtraModule = moduleOfQualifiedName symbol' - haskellModuleNames' = if symbol == symbol' then haskellModuleNames else haskellModuleNames ++ [fromJust maybeExtraModule] + GhcMonad.liftIO $ putStrLn $ "postMatches: " ++ show postMatches + GhcMonad.liftIO $ putStrLn $ "symbol': " ++ symbol' - putStrLn $ "maybeExtraModule: " ++ show maybeExtraModule - putStrLn $ "haskellModuleNames': " ++ show haskellModuleNames' + let maybeExtraModule = moduleOfQualifiedName symbol' - let smatches = specificallyMatches symbol (map toHaskellModule textualImports) - putStrLn $ "smatches: " ++ show smatches + -- 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 - let symbol'' = if null smatches - then symbol' - else modName (head smatches) ++ "." ++ symbol + let maybeExtraModule' = if extraIsHidden + then [] + else if isJust maybeExtraModule + then [fromJust maybeExtraModule] + else [] - putStrLn $ "symbol'': " ++ symbol'' + let haskellModuleNames' = if symbol == symbol' then haskellModuleNames else haskellModuleNames ++ maybeExtraModule' - let allJust (a, b, c, d) = isJust a && isJust b && isJust c && isJust d + GhcMonad.liftIO $ putStrLn $ "maybeExtraModule: " ++ show maybeExtraModule + GhcMonad.liftIO $ putStrLn $ "maybeExtraModule': " ++ show maybeExtraModule' + GhcMonad.liftIO $ putStrLn $ "haskellModuleNames': " ++ show haskellModuleNames' - final1 <- lookupSymbol (GhcOptions ghcOpts0) targetFile targetModule symbol'' haskellModuleNames' - final2 <- filter allJust <$> mapM (findHaddockModule symbol'' smatches ghcpkgOptions) final1 - final3 <- mapM matchToUrl final2 + let smatches = specificallyMatches symbol (map toHaskellModule textualImports) + GhcMonad.liftIO $ putStrLn $ "smatches: " ++ show smatches - return (if null final3 then Left "No matches found." - else Right $ head final3) + let symbol'' = if null smatches + then symbol' + else modName (head smatches) ++ "." ++ symbol + GhcMonad.liftIO $ putStrLn $ "symbol'': " ++ symbol'' + let allJust (a, b, c, d) = isJust a && isJust b && isJust c && isJust d + + -- Then this does a runGhc as well. + final1 <- lookupSymbol (GhcOptions ghcOpts0) targetFile targetModule symbol'' haskellModuleNames' + + final1' <- GhcMonad.liftIO $ concatMapM (findHaddockModule symbol'' smatches ghcpkgOptions) final1 + GhcMonad.liftIO $ putStrLn $ "final1': " ++ show final1' + + -- 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) + + let final2 = filter allJust final1'' + final3 <- GhcMonad.liftIO $ mapM matchToUrl final2 + + 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 + -- | 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 @@ -741,11 +859,12 @@ let ghcpkgopts = GhcPkgOptions $ ghcPkgOpts opt res <- (guessHaddockUrl file modstr symbol lineNr colNr ghcopts ghcpkgopts) - `gcatch` (\(_ :: SourceError) -> return $ Left "guessHaddockUrl failed with a SourceError") - `gcatch` (\(_ :: GhcApiError) -> return $ Left "guessHaddockUrl failed with a GhcApiError") - `gcatch` (\(_ :: SomeException) -> return $ Left "guessHaddockUrl failed with a SomeException") - - return $ case res of Right x -> "SUCCESS: " ++ x ++ "\n" - Left err -> "FAIL: " ++ show err ++ "\n" - + -- `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) + 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. + Left err -> return $ "FAIL: " ++ show err ++ "\n" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -63,8 +63,20 @@ cd ghc-imported-from ./build_in_sandbox.sh -Either way, ensure that ```ghc-imported-from``` is in the current PATH. +Either way, ensure that ```ghc-imported-from``` and ```fake-ghc-for-ghc-imported-from``` are in the current PATH. +### Tests + +Run the tests using cabal: + + cabal test --show-details=streaming + +As of 2014-05-18 just running ```cabal test``` seems to run the +tests and then hang (waiting on a PID). This seems to be the problem: +https://github.com/haskell/cabal/issues/1810 + +Running with ```--show-details=streaming``` seems to work ok. + ### ghcimportedfrom-vim Follow the instructions at @@ -78,3 +90,19 @@ Or watch the screencast (be sure to set 720p HD and then fullscreen): [http://www.youtube.com/watch?v=VVc8uupYJGs](http://www.youtube.com/watch?v=VVc8uupYJGs) + +## Notes + +```ghc-imported-from``` uses both GHC and ghc-pkg, which +accept arguments in differing formats. For example GHC takes +```-package-db``` while ghc-pkg takes ```--package-db=```. For more +details: http://www.vex.net/~trebla/haskell/sicp.xhtml + +## Debugging + +To see the GHC options that have been automatically detected, change into your project's directory and run: + + $ cd ~/ghc-imported-from + $ cabal repl --with-ghc=fake-ghc-for-ghc-imported-from + Preprocessing library ghc-imported-from-0.2.0.2... + --interactive -fbuilding-cabal-package -O0 -outputdir dist/build -odir dist/build -hidir dist/build -stubdir dist/build -i -idist/build -i. -idist/build/autogen -Idist/build/autogen -Idist/build -optP-include -optPdist/build/autogen/cabal_macros.h -package-name ghc-imported-from-0.2.0.2 -hide-all-packages -no-user-package-db -package-db /home/user/ghc-imported-from/.cabal-sandbox/x86_64-linux-ghc-7.6.3-packages.conf.d -package-db dist/package.conf.inplace -package-id Cabal-1.16.0-c6e09e008cd04cf255c1ce0c59aba905 -package-id base-4.6.0.1-8aa5d403c45ea59dcd2c39f123e27d57 -package-id containers-0.5.0.0-ab1dae9a94cd3cc84e7b2805636ebfa2 -package-id directory-1.2.0.1-91a788fd88acd7f149f0f10f5f1e23f2 -package-id filepath-1.3.0.1-b12cbe18566fe1532a1fda4c85e31cbe -package-id ghc-7.6.3-18957ddbb817289f604552aa2da2e879 -package-id ghc-mod-4.1.0-a87501f2667239b3f0bef3e0f3753496 -package-id ghc-paths-0.1.0.9-3817f31ae510ed3b58554933ea527b74 -package-id ghc-syb-utils-0.2.1.2-bf72c1e71339c52f0af404a12449c9d2 -package-id mtl-2.2.0.1-ef91e0abcf7a4fb581ecb7fe83cdcba1 -package-id process-1.1.0.2-76e05340eb66705981411022731ca84a -package-id safe-0.3.4-ba52ca348aecad429ba90450e3aba4c4 -package-id syb-0.4.1-9469ffdd9c6a7ebbf035421c915a08ee -package-id transformers-0.4.1.0-42810d723884ebf2a2dd638e5b22e523 -XHaskell2010 Language.Haskell.GhcImportedFrom Language.Haskell.GhcImportedFrom.UtilsFromGhcMod Language.Haskell.GhcImportedFrom.Types -Wall diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +2014-05-16 v0.2.0.3 + +* Fixed test cases. +* Added alternative heuristic for lookup. + 2014-05-16 v0.2.0.2 * Catch GHC panics. 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.0.2 +version: 0.2.0.3 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. @@ -19,6 +19,7 @@ test/data/*.hs library + GHC-Options: -Wall -O2 exposed-modules: Language.Haskell.GhcImportedFrom other-modules: Language.Haskell.GhcImportedFrom.UtilsFromGhcMod Language.Haskell.GhcImportedFrom.Types @@ -46,7 +47,7 @@ executable fake-ghc-for-ghc-imported-from main-is: fake-ghc-for-ghc-imported-from.hs - GHC-Options: -Wall + GHC-Options: -Wall -O2 hs-source-dirs: src build-depends: base >=4.6 && <4.8 , process @@ -54,7 +55,7 @@ executable ghc-imported-from main-is: Main.hs - GHC-Options: -Wall + GHC-Options: -Wall -O2 other-modules: Paths_ghc_imported_from other-extensions: CPP, Rank2Types build-depends: base >=4.6 && <4.8 @@ -83,7 +84,7 @@ Test-Suite spec Default-Language: Haskell2010 - GHC-Options: -Wall + GHC-Options: -Wall -O2 Main-Is: Spec.hs Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 diff --git a/test/ImportedFromSpec.hs b/test/ImportedFromSpec.hs --- a/test/ImportedFromSpec.hs +++ b/test/ImportedFromSpec.hs @@ -12,6 +12,9 @@ isRight :: forall a b. Either a b -> Bool isRight = either (const False) (const True) +-- Instead of shouldSatisfy isRight, these should check for the right module/package +-- name turning up in the results. + spec :: Spec spec = do describe "checkImportedFrom" $ do @@ -62,15 +65,16 @@ it "can look up map" $ do withDirectory_ "test/data" $ do - res <- guessHaddockUrl "Hiding.hs" "Hiding" "map" 12 5 (GhcOptions []) (GhcPkgOptions []) + res <- guessHaddockUrl "Hiding.hs" "Hiding" "map" 14 5 (GhcOptions []) (GhcPkgOptions []) res `shouldSatisfy` isRight it "can look up head" $ do withDirectory_ "test/data" $ do - res <- guessHaddockUrl "Hiding.hs" "Hiding" "head" 12 5 (GhcOptions []) (GhcPkgOptions []) + res <- guessHaddockUrl "Hiding.hs" "Hiding" "head" 16 5 (GhcOptions []) (GhcPkgOptions []) res `shouldSatisfy` isRight it "can look up when" $ do withDirectory_ "test/data" $ do res <- guessHaddockUrl "When.hs" "When" "when" 15 5 (GhcOptions []) (GhcPkgOptions []) res `shouldSatisfy` isRight +