diff --git a/Language/Haskell/GhcImportedFrom.hs b/Language/Haskell/GhcImportedFrom.hs --- a/Language/Haskell/GhcImportedFrom.hs +++ b/Language/Haskell/GhcImportedFrom.hs @@ -28,6 +28,7 @@ , ghcOptionToGhcPKg , getGhcOptionsViaGhcMod , getGHCOptionsViaCradle + , getCompilerOptionsViaGhcMod , modifyDFlags , setDynamicFlags , getTextualImports @@ -48,6 +49,12 @@ , findHaddockModule , matchToUrl , guessHaddockUrl + , haddockUrl + + -- Things from Language.Haskell.GhcImportedFrom.Types + , Options (..) + , defaultOptions + , LineSeparator (..) ) where import Control.Applicative @@ -83,10 +90,22 @@ import qualified SrcLoc import qualified Safe -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal +import Language.Haskell.GhcMod ( + findCradle + , cradleCabalFile + , cradleCabalDir + , cradlePackageDbOpts + ) +import Language.Haskell.GhcMod.Internal ( + cabalAllBuildInfo + , GHCOption + , parseCabalFile + , CompilerOptions (..) + ) + import Language.Haskell.GhcImportedFrom.UtilsFromGhcMod +import Language.Haskell.GhcImportedFrom.Types type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@. @@ -131,6 +150,13 @@ let binfo = head $ cabalAllBuildInfo pkgDesc getGHCOptions [] c (fromJust $ cradleCabalDir c) binfo +-- | Get compiler options using ghc-mod's API. +getCompilerOptionsViaGhcMod :: [GHCOption] -> IO CompilerOptions +getCompilerOptionsViaGhcMod ghcOpts0 = do + cradle <- findCradle + pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle + getCompilerOptions ghcOpts0 cradle pkgDesc + -- | Add user-supplied GHC options to those discovered via ghc-mod. modifyDFlags :: [String] -> DynFlags -> IO ([String], [GHCOption], DynFlags) modifyDFlags ghcOpts0 dflags0 = @@ -139,20 +165,32 @@ (GhcOptions ghcOpts1) <- GhcMonad.liftIO getGhcOptionsViaGhcMod ghcOpts2 <- GhcMonad.liftIO getGHCOptionsViaCradle + (CompilerOptions compGhcOpts iPaths coDepPkgs) <- GhcMonad.liftIO $ getCompilerOptionsViaGhcMod ghcOpts0 + + -- FIXME Need to log this info. + -- GhcMonad.liftIO $ putStrLn $ "compGhcOpts: " ++ show compGhcOpts + -- GhcMonad.liftIO $ putStrLn $ "iPaths: " ++ show iPaths + -- GhcMonad.liftIO $ putStrLn $ "coDepPkgs: " ++ show coDepPkgs + -- FIXME need to add ghcOpts1 and ghcOpts2 to the WriterT, but here -- we are inside the GhcMonad, so need to do some transformer stuff. -- Instead we laboriously return ghcOpts1 and ghcOpts2 up the call chain. -- GhcMonad.liftIO $ putStrLn $ "ghcOpts1: " ++ show ghcOpts1 -- GhcMonad.liftIO $ putStrLn $ "ghcOpts2: " ++ show ghcOpts2 - (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 (map SrcLoc.noLoc $ ghcOpts1 ++ ghcOpts2 ++ ghcOpts0) + -- FIXME Can probably remove the ghcOpts1 and ghcOpts2 stuff which + -- is superceded by the functionality of getCompilerOptionsViaGhcMod. + (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 (map SrcLoc.noLoc $ ghcOpts1 ++ ghcOpts2 ++ ghcOpts0 ++ compGhcOpts) let dflags2 = dflags1 { hscTarget = HscInterpreted , ghcLink = LinkInMemory + , importPaths = iPaths } - return (ghcOpts1, ghcOpts2, dflags2) + dflags3 = addDevPkgs dflags2 coDepPkgs + return (ghcOpts1, ghcOpts2, dflags3) + -- | Set GHC options and run 'initPackages' in 'GhcMonad'. -- -- Typical use: @@ -634,6 +672,9 @@ myTell $ "line nr: " ++ show lineNr myTell $ "col nr: " ++ show colNr + myTell $ "ghcOpts0: " ++ show ghcOpts0 + myTell $ "ghcPkgOpts: " ++ show ghcPkgOpts + textualImports <- getTextualImports (GhcOptions ghcOpts0) targetFile targetModule let haskellModuleNames = map (modName . toHaskellModule) textualImports @@ -676,3 +717,18 @@ return (if null final3 then Left "No matches found." else Right $ head 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 + + let ghcopts = GhcOptions $ ghcOpts opt + let ghcpkgopts = GhcPkgOptions $ ghcPkgOpts opt + + (res, logMessages) <- runWriterT $ guessHaddockUrl file modstr symbol lineNr colNr ghcopts ghcpkgopts + + return $ case res of Right x -> unlines logMessages ++ "SUCCESS: " ++ x ++ "\n" + Left err -> "FAIL: " ++ show err ++ "\n" + + diff --git a/Language/Haskell/GhcImportedFrom/Types.hs b/Language/Haskell/GhcImportedFrom/Types.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcImportedFrom/Types.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- Adapted from ghc-mod/Language/Haskell/GhcMod/Types.hs + +module Language.Haskell.GhcImportedFrom.Types where + +-- FIXME We don't support LineSeparator; might be handy for +-- Windows (?) with CRLF encoding? +newtype LineSeparator = LineSeparator String deriving (Show) + +data Options = Options { + ghcOpts :: [String] + , ghcPkgOpts :: [String] + , lineSeparator :: LineSeparator + } deriving (Show) + +defaultOptions :: Options +defaultOptions = Options { + ghcOpts = [] + , ghcPkgOpts = [] + , lineSeparator = LineSeparator "\0" + } diff --git a/Language/Haskell/GhcImportedFrom/UtilsFromGhcMod.hs b/Language/Haskell/GhcImportedFrom/UtilsFromGhcMod.hs --- a/Language/Haskell/GhcImportedFrom/UtilsFromGhcMod.hs +++ b/Language/Haskell/GhcImportedFrom/UtilsFromGhcMod.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE Rank2Types, OverloadedStrings #-} +{-# LANGUAGE Rank2Types, OverloadedStrings, CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : UtilsFromGhcMod @@ -19,6 +20,8 @@ -- * -- -- Hopefully this is ok since ghc-mod and this project are both licensed BSD3. +-- If this package ever stabilises I may send a pull request to ghc-mod asking +-- for some of these functions to be exported, perhaps in Language.Haskell.GhcMod.Internal. module Language.Haskell.GhcImportedFrom.UtilsFromGhcMod where @@ -42,6 +45,10 @@ import Control.Exception (throwIO) +import Data.Set (fromList, toList) + +import DynFlags + -- ghcmod/Language/Haskell/GhcMod/Info.hs listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs @@ -86,3 +93,64 @@ case mv of Nothing -> throwIO $ userError "ghc not found" Just v -> return v + +-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs +getCompilerOptions :: [GHCOption] -> Cradle -> PackageDescription -> IO CompilerOptions +getCompilerOptions ghcopts cradle pkgDesc = do + gopts <- getGHCOptions ghcopts cradle cdir $ head buildInfos + return $ CompilerOptions gopts idirs depPkgs + where + wdir = cradleCurrentDir cradle + Just cdir = cradleCabalDir cradle + Just cfile = cradleCabalFile cradle + buildInfos = cabalAllBuildInfo pkgDesc + idirs = includeDirectories cdir wdir $ cabalSourceDirs buildInfos + depPkgs = removeThem problematicPackages $ removeMe cfile $ cabalDependPackages buildInfos + +-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs +removeMe :: FilePath -> [Package] -> [Package] +removeMe cabalfile = filter (/= me) + where + me = dropExtension $ takeFileName cabalfile + +-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs +removeThem :: [Package] -> [Package] -> [Package] +removeThem badpkgs = filter (`notElem` badpkgs) + +-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs +problematicPackages :: [Package] +problematicPackages = [ + "base-compat" -- providing "Prelude" + ] + +-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs +cabalBuildDirs :: [FilePath] +cabalBuildDirs = ["dist/build", "dist/build/autogen"] + +-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs +includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath] +includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir]) + where + extdirs = map expand $ dirs ++ cabalBuildDirs + expand "." = cdir + expand subdir = cdir subdir + +-- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs +uniqueAndSort :: [String] -> [String] +uniqueAndSort = toList . fromList + +-- ghc-mod/Language/Haskell/GhcMod/Gap.hs +addDevPkgs :: DynFlags -> [Package] -> DynFlags +addDevPkgs df [] = df +addDevPkgs df pkgs = df'' + where +#if __GLASGOW_HASKELL__ >= 707 + df' = gopt_set df Opt_HideAllPackages +#else + df' = dopt_set df Opt_HideAllPackages +#endif + df'' = df' { + packageFlags = map ExposePackage pkgs ++ packageFlags df + } + + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,17 +1,16 @@ -ghc-imported-from -================= +# ghc-imported-from For a given Haskell source file, determine the path to the Haddock documentation for a symbol at a particular line/col location. -Example: on the file [Muddle.hs](https://github.com/carlohamalainen/ghc-imported-from/blob/master/tests/Muddle.hs), +Example: on the file [src/Main.hs](https://github.com/carlohamalainen/ghc-imported-from/blob/master/src/Main.hs), - ../.cabal-sandbox/bin/ghc-imported-from Muddle.hs Muddle Maybe 11 11 + ghc-imported-from haddock-url src/Main.hs Main getArgs 160 13 says - SUCCESS: /home/carlo/opt/ghc-7.6.3_build/share/doc/ghc/html/libraries/base-4.6.0.1/Data-Maybe.html + SUCCESS: file:///home/carlo/opt/ghc-7.6.3_build/share/doc/ghc/html/libraries/base-4.6.0.1/System-Environment.html -since the usage of ```Maybe``` at line 11, column 11, is from the ```Data.Maybe``` module. +since the usage of ```getArgs``` at line 160, column 13, is from the ```System.Environment``` module. Difficulties arise because some symbols are exported from a certain package but defined in another, for example ```String``` is defined in @@ -22,6 +21,32 @@ 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 ### ghc-imported-from @@ -53,9 +78,3 @@ Or watch the screencast (be sure to set 720p HD and then fullscreen): [http://www.youtube.com/watch?v=VVc8uupYJGs](http://www.youtube.com/watch?v=VVc8uupYJGs) - -## Beware - -If you use Cabal sandboxes, you'll have to hardcode the path to the package config file. This is a known issue: [https://github.com/carlohamalainen/ghc-imported-from/issues/3](https://github.com/carlohamalainen/ghc-imported-from/issues/3) - -Feedback and pull requests most welcome! diff --git a/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.1.0.1 +version: 0.1.0.2 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. @@ -20,6 +20,7 @@ library exposed-modules: Language.Haskell.GhcImportedFrom other-modules: Language.Haskell.GhcImportedFrom.UtilsFromGhcMod + Language.Haskell.GhcImportedFrom.Types other-extensions: CPP, Rank2Types build-depends: base >=4.6 && <4.7 @@ -45,7 +46,7 @@ executable ghc-imported-from main-is: Main.hs GHC-Options: -Wall - -- other-modules: + other-modules: Paths_ghc_imported_from other-extensions: CPP, Rank2Types build-depends: base >=4.6 && <4.7 , syb >=0.4 && <0.5 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,39 +1,114 @@ +{-# LANGUAGE DeriveDataTypeable #-} + import Language.Haskell.GhcImportedFrom import Data.List import Data.Maybe +import Data.Version ( showVersion ) import System.Environment -import System.IO() +import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) +import System.Console.GetOpt +import System.Exit + +import Control.Exception +import Data.Typeable + import Control.Monad (forM_) import Control.Monad.Writer -main :: IO () -main = do - args <- getArgs +import Paths_ghc_imported_from - -- quick and dirty argument parsing, no error checking - let targetFile = args !! 0 - targetModule = args !! 1 - symbol = args !! 2 - lineNo = (read $ args !! 3) :: Int - colNo = (read $ args !! 4) :: Int - rest = drop 5 args +-- FIXME adapt these to ghc-imported-from +data GHCImportedFromError = SafeList + | TooManyArguments String + | NoSuchCommand String + | CmdArg [String] + | FileNotExist String deriving (Show, Typeable) - -- assert: rest !! 0 == "--ghc-options" +instance Exception GHCImportedFromError - let n = fromJust $ elemIndex "--ghc-pkg-options" rest +ghcOptHelp :: String +ghcOptHelp = " [--ghc-option GHC_opt1 --ghc-option GHC_opt2 ...] " - -- assert: rest !! n == "--ghc-pkg-options" +ghcPkgOptHelp :: String +ghcPkgOptHelp = " [--ghc-pkg-option ghc_pkg_opt1 --ghc-pkg-option ghc_pkg_opt2 ...] " - let ghcopts = GhcOptions $ tail $ take n rest - let ghcpkgopts = GhcPkgOptions $ drop (n + 1) rest +usage :: String +usage = "ghc-imported-from version " ++ showVersion version ++ "\n" + ++ "Usage:\n" + ++ "\t ghc-imported-from haddock-url" ++ ghcOptHelp ++ ghcPkgOptHelp ++ " \n" + ++ "\t ghc-imported-from help\n" + ++ "\nExample: ghc-imported-from haddock-url src/Main.hs Main getArgs 160 13\n" - print ghcopts - print ghcpkgopts +parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) +parseArgs spec argv + = case getOpt Permute spec argv of + (o,n,[] ) -> (foldr id defaultOptions o, n) + (_,_,errs) -> throw (CmdArg errs) - (res, logMessages) <- runWriterT $ guessHaddockUrl targetFile targetModule symbol lineNo colNo ghcopts ghcpkgopts +argspec :: [OptDescr (Options -> Options)] +argspec = [ Option "g" ["ghc-options"] + (ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghc-options") + "GHC options" + , Option "p" ["ghc-pkg-options"] + (ReqArg (\g opts -> opts { ghcPkgOpts = g : ghcPkgOpts opts }) "ghc-pkg-options") + "ghc-pkg options" + -- , Option "b" ["boundary"] + -- (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep") + -- "specify line separator (default is Nul string)" + ] - case res of Right x -> do forM_ logMessages putStrLn - putStrLn $ "SUCCESS: " ++ x - Left err -> putStrLn $ "FAIL: " ++ show err +main :: IO () +main = flip catches handlers $ do +-- #if __GLASGOW_HASKELL__ >= 611 + hSetEncoding stdout utf8 +-- #endif + args <- getArgs + let (opt,cmdArg) = parseArgs argspec args + + -- print opt + -- print cmdArg + + let cmdArg0 = cmdArg !. 0 + cmdArg1 = cmdArg !. 1 + cmdArg2 = cmdArg !. 2 + cmdArg3 = cmdArg !. 3 + cmdArg4 = cmdArg !. 4 + cmdArg5 = cmdArg !. 5 + remainingArgs = tail cmdArg + nArgs n f = if length remainingArgs == n + then f + else throw (TooManyArguments cmdArg0) + + res <- case cmdArg0 of + "haddock-url" -> nArgs 5 $ haddockUrl opt cmdArg1 cmdArg2 cmdArg3 (read cmdArg4) (read cmdArg5) + "help" -> return $ usageInfo usage argspec + cmd -> throw (NoSuchCommand cmd) + putStr res + + where + handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] + handleThenExit handler = \e -> handler e >> exitFailure + handler1 :: ErrorCall -> IO () + handler1 = print -- for debug + handler2 :: GHCImportedFromError -> IO () + handler2 SafeList = printUsage + handler2 (TooManyArguments cmd) = do + hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments" + printUsage + handler2 (NoSuchCommand cmd) = do + hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" + printUsage + handler2 (CmdArg errs) = do + mapM_ (hPutStr stderr) errs + printUsage + handler2 (FileNotExist file) = do + hPutStrLn stderr $ "\"" ++ file ++ "\" not found" + printUsage + printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec + + xs !. idx + | length xs <= idx = throw SafeList + | otherwise = xs !! idx +