diff --git a/Language/Haskell/GhcImportedFrom.hs b/Language/Haskell/GhcImportedFrom.hs --- a/Language/Haskell/GhcImportedFrom.hs +++ b/Language/Haskell/GhcImportedFrom.hs @@ -20,15 +20,11 @@ -- Latest development version: . module Language.Haskell.GhcImportedFrom ( - QualifiedName(..) - , Symbol(..) + QualifiedName + , Symbol , GhcOptions(..) , GhcPkgOptions(..) , HaskellModule(..) - , ghcOptionToGhcPKg - , getGhcOptionsViaGhcMod - , getGHCOptionsViaCradle - , getCompilerOptionsViaGhcMod , modifyDFlags , setDynamicFlags , getTextualImports @@ -50,6 +46,7 @@ , matchToUrl , guessHaddockUrl , haddockUrl + , getGhcOptionsViaCabalRepl -- Things from Language.Haskell.GhcImportedFrom.Types , Options (..) @@ -92,21 +89,52 @@ import Language.Haskell.GhcMod ( findCradle - , cradleCabalFile - , cradleCabalDir - , cradlePackageDbOpts - ) - -import Language.Haskell.GhcMod.Internal ( - cabalAllBuildInfo - , GHCOption - , parseCabalFile - , CompilerOptions (..) + , cradleRootDir + , Cradle(..) ) import Language.Haskell.GhcImportedFrom.UtilsFromGhcMod import Language.Haskell.GhcImportedFrom.Types + +#if __GLASGOW_HASKELL__ >= 708 +import DynFlags ( unsafeGlobalDynFlags ) +tdflags = unsafeGlobalDynFlags +#else +import DynFlags ( tracingDynFlags ) +tdflags = tracingDynFlags +#endif + +type GHCOption = String + +getGhcOptionsViaCabalRepl :: IO (Maybe [String]) +getGhcOptionsViaCabalRepl = do + (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 + + result <- if ineof + then return "" + else do firstLine <- hGetLine hout + if "GHCi" `isPrefixOf` firstLine + then return "DERP" -- stuffed up, should report error + else do rest <- readRestOfHandle hout + return $ firstLine ++ "\n" ++ rest + + let result' = filter ("--interactive" `isPrefixOf`) . lines $ result + + case length result' of 1 -> return $ Just $ filterOpts $ words $ head result' + _ -> return Nothing + + where filterOpts :: [String] -> [String] + filterOpts xs = filter (\x -> x /= "--interactive" && x /= "-fbuilding-cabal-package") $ dropModuleNames xs + + dropModuleNames :: [String] -> [String] + dropModuleNames xs = reverse $ dropWhile (not . ("-" `isPrefixOf`)) (reverse xs) + +getGhcOptionsViaCabalReplOrEmpty :: IO [String] +getGhcOptionsViaCabalReplOrEmpty = liftM (fromMaybe []) getGhcOptionsViaCabalRepl + type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@. type Symbol = String -- ^ A symbol, possibly qualified, e.g. @bar@ or @Foo.bar@. @@ -130,66 +158,20 @@ , modSpecifically :: [String] } deriving (Show, Eq) --- | Convert a GHC command line option to a @ghc-pkg@ command line option. This function --- is incomplete; it only handles a few cases at the moment. -ghcOptionToGhcPKg :: [String] -> [String] -ghcOptionToGhcPKg [] = [] -ghcOptionToGhcPKg (x:xs) = case x of "-no-user-package-db" -> "--no-user-package-db":ghcOptionToGhcPKg xs - "-package-db" -> ["--package-db", head xs] ++ ghcOptionToGhcPKg (tail xs) - _ -> error $ "Unknown GHC option: " ++ show (x:xs) -- FIXME Other cases? - --- | Use ghcmod's API to get the GHC options for a project. This uses 'findCradle', 'cradlePackageDbOpts', and 'GhcOptions'. -getGhcOptionsViaGhcMod :: IO GhcOptions -getGhcOptionsViaGhcMod = GhcOptions . cradlePackageDbOpts <$> findCradle - --- | Use ghcmod's API to get the GHC options for a project. This uses 'findCradle' and 'getGHCOptions.' -getGHCOptionsViaCradle :: IO [GHCOption] -getGHCOptionsViaCradle = do - c <- findCradle - pkgDesc <- GhcMonad.liftIO $ parseCabalFile $ fromJust $ cradleCabalFile c - let binfo = head $ cabalAllBuildInfo pkgDesc - getGHCOptions [] c (fromJust $ cradleCabalDir c) binfo - --- | 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. +-- | Add user-supplied GHC options to those discovered via cabl repl. modifyDFlags :: [String] -> DynFlags -> IO ([String], [GHCOption], DynFlags) modifyDFlags ghcOpts0 dflags0 = defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do - (GhcOptions ghcOpts1) <- GhcMonad.liftIO getGhcOptionsViaGhcMod - ghcOpts2 <- GhcMonad.liftIO getGHCOptionsViaCradle - - (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 + ghcOpts1 <- GhcMonad.liftIO getGhcOptionsViaCabalReplOrEmpty - -- 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) + (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 (map SrcLoc.noLoc $ ghcOpts0 ++ ghcOpts1) let dflags2 = dflags1 { hscTarget = HscInterpreted , ghcLink = LinkInMemory - , importPaths = iPaths } - dflags3 = addDevPkgs dflags2 coDepPkgs - - return (ghcOpts1, ghcOpts2, dflags3) + return ([], [], dflags2) -- | Set GHC options and run 'initPackages' in 'GhcMonad'. -- @@ -204,6 +186,7 @@ (ghcOpts1, ghcOpts2, dflags1) <- GhcMonad.liftIO $ modifyDFlags extraGHCOpts dflags0 void $ setSessionDynFlags dflags1 _ <- GhcMonad.liftIO $ Packages.initPackages dflags1 + return (ghcOpts1, ghcOpts2, dflags1) -- |Read the textual imports in a file. @@ -294,11 +277,11 @@ toHaskellModule :: SrcLoc.Located (GHC.ImportDecl GHC.RdrName) -> HaskellModule toHaskellModule idecl = HaskellModule name qualifier isImplicit hiding importedAs specifically where idecl' = SrcLoc.unLoc idecl - name = showSDoc tracingDynFlags (ppr $ GHC.ideclName idecl') + name = showSDoc tdflags (ppr $ GHC.ideclName idecl') isImplicit = GHC.ideclImplicit idecl' qualifier = unpackFS <$> GHC.ideclPkgQual idecl' hiding = map removeBrackets $ (catMaybes . parseHiding . GHC.ideclHiding) idecl' - importedAs = (showSDoc tracingDynFlags . ppr) <$> ideclAs idecl' + importedAs = (showSDoc tdflags . ppr) <$> ideclAs idecl' specifically = map removeBrackets $ (parseSpecifically . GHC.ideclHiding) idecl' removeBrackets :: [a] -> [a] @@ -306,7 +289,7 @@ removeBrackets x = (init . tail) x grabNames :: GHC.Located (GHC.IE GHC.RdrName) -> String - grabNames loc = showSDoc tracingDynFlags (ppr names) + grabNames loc = showSDoc tdflags (ppr names) where names = GHC.ieNames $ SrcLoc.unLoc loc parseHiding :: Maybe (Bool, [Located (IE RdrName)]) -> [Maybe String] @@ -334,7 +317,7 @@ -- Example: -- -- >>> x <- lookupSymbol "tests/data/data/Hiding.hs" "Hiding" "head" ["Prelude", "Safe", "System.Environment", "Data.List"] --- *GhcImportedFrom> putStrLn . (showSDoc tracingDynFlags) . ppr $ x +-- *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 @@ -448,7 +431,7 @@ es = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id] ps = listifySpans tcs (lineNr, colNr) :: [LPat Id] - let foo x = showSDoc tracingDynFlags $ ppr x + let foo x = showSDoc tdflags $ ppr x bs' = map foo bs es' = map foo es ps' = map foo ps @@ -464,14 +447,21 @@ then return "" else hGetContents h +optsForGhcPkg :: [String] -> [String] +optsForGhcPkg [] = [] +optsForGhcPkg ("-no-user-package-db":rest) = "--no-user-package-db" : optsForGhcPkg rest +optsForGhcPkg ("-package-db":pd:rest) = ("--package-db" ++ "=" ++ pd) : optsForGhcPkg rest +optsForGhcPkg ("-package-conf":pc:rest) = ("--package-conf" ++ "=" ++ pc) : optsForGhcPkg rest +optsForGhcPkg ("-no-user-package-conf":rest) = "--no-user-package-conf" : optsForGhcPkg rest +optsForGhcPkg (_:rest) = optsForGhcPkg rest + -- | Call @ghc-pkg find-module@ to determine that package that provides a module, e.g. @Prelude@ is defined -- in @base-4.6.0.1@. ghcPkgFindModule :: GhcPkgOptions -> String -> WriterT [String] IO (Maybe String) ghcPkgFindModule (GhcPkgOptions extraGHCPkgOpts) m = do - - (GhcOptions gopts) <- CMT.liftIO getGhcOptionsViaGhcMod :: WriterT [String] IO GhcOptions + gopts <- CMT.liftIO getGhcOptionsViaCabalReplOrEmpty - let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] ++ ghcOptionToGhcPKg gopts ++ extraGHCPkgOpts + let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] ++ optsForGhcPkg gopts ++ extraGHCPkgOpts myTell $ "ghc-pkg " ++ show opts (_, Just hout, Just herr, _) <- CMT.liftIO $ createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe @@ -481,17 +471,18 @@ output <- CMT.liftIO $ readRestOfHandle hout err <- CMT.liftIO $ readRestOfHandle herr - myTell $ "ghcPkgFindModule stdout: " ++ output - myTell $ "ghcPkgFindModule stderr: " ++ err + myTell $ "ghcPkgFindModule stdout: " ++ show output + myTell $ "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. ghcPkgHaddockUrl :: GhcPkgOptions -> String -> WriterT [String] IO (Maybe String) ghcPkgHaddockUrl (GhcPkgOptions extraGHCPkgOpts) p = do - (GhcOptions gopts) <- CMT.liftIO getGhcOptionsViaGhcMod :: WriterT [String] IO GhcOptions + gopts <- CMT.liftIO getGhcOptionsViaCabalReplOrEmpty - let opts = ["field", p, "haddock-html"] ++ ["--global", "--user"] ++ ghcOptionToGhcPKg gopts ++ extraGHCPkgOpts + let opts = ["field", p, "haddock-html"] ++ ["--global", "--user"] ++ optsForGhcPkg gopts ++ extraGHCPkgOpts myTell $ "ghc-pkg "++ show opts (_, Just hout, _, _) <- CMT.liftIO $ createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe @@ -583,23 +574,23 @@ -- Adapted from http://www.haskell.org/pipermail/haskell-cafe/2010-June/078702.html substringP :: String -> String -> Maybe Int substringP _ [] = Nothing - substringP sub str = if sub `isPrefixOf` str then Just 0 else fmap (+1) $ substringP sub (tail str) + 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 = x'' - where name' = showSDoc tracingDynFlags $ ppr name + where name' = showSDoc tdflags $ ppr name name'' = fromJust $ moduleOfQualifiedName name' -- FIXME dangerous fromJust x = concatMap symbolImportedFrom lookUp - x' = map (showSDoc tracingDynFlags . ppr) x + x' = map (showSDoc tdflags . ppr) x x'' = filter (name'' `isPrefixOf`) x' -- | Find the haddock module. Returns a 4-tuple consisting of: module that the symbol is imported -- from, haddock url, module, and module's HTML filename. findHaddockModule :: QualifiedName -> [HaskellModule] -> GhcPkgOptions -> (Name, [GlobalRdrElt]) -> WriterT [String] IO (Maybe String, Maybe String, Maybe String, Maybe String) findHaddockModule symbol'' smatches ghcPkgOpts (name, lookUp) = do - myTell $ "name: " ++ showSDoc tracingDynFlags (ppr name) + myTell $ "name: " ++ showSDoc tdflags (ppr name) let definedIn = nameModule name bpms = bestPrefixMatches name lookUp @@ -608,13 +599,13 @@ -- FIXME should really return *all* of these matches, not just the first one. We -- can't be certain that we're choosing the best one. Ditto for all other -- uses of head or Safe.headMay. - then if null bpms then Safe.headMay $ map (showSDoc tracingDynFlags . ppr) $ concatMap symbolImportedFrom lookUp + then if null bpms then Safe.headMay $ map (showSDoc tdflags . ppr) $ concatMap symbolImportedFrom lookUp else Safe.headMay bpms :: Maybe String - else (Just . (showSDoc tracingDynFlags . ppr) . mkModuleName . fromJust . moduleOfQualifiedName) symbol'' -- FIXME dangerous fromJust + else (Just . (showSDoc tdflags . ppr) . mkModuleName . fromJust . moduleOfQualifiedName) symbol'' -- FIXME dangerous fromJust - myTell $ "definedIn: " ++ showSDoc tracingDynFlags (ppr definedIn) + myTell $ "definedIn: " ++ showSDoc tdflags (ppr definedIn) myTell $ "bpms: " ++ show bpms - myTell $ "concat $ map symbolImportedFrom lookUp: " ++ showSDoc tracingDynFlags (ppr $ concatMap symbolImportedFrom lookUp) + myTell $ "concat $ map symbolImportedFrom lookUp: " ++ showSDoc tdflags (ppr $ concatMap symbolImportedFrom lookUp) myTell $ "importedFrom: " ++ show importedFrom @@ -652,7 +643,7 @@ if e then return $ "file://" ++ f else do myTell $ "f: " ++ show f myTell $ "foundModule: " ++ show foundModule' - return $ toHackageUrl f foundModule' (showSDoc tracingDynFlags (ppr importedFrom')) + return $ toHackageUrl f foundModule' (showSDoc tdflags (ppr importedFrom')) -- | Attempt to guess the Haddock url, either a local file path or url to @hackage.haskell.org@ @@ -665,7 +656,14 @@ -- SUCCESS: file:///home/carlo/opt/ghc-7.6.3_build/share/doc/ghc/html/libraries/base-4.6.0.1/Data-Maybe.html guessHaddockUrl :: FilePath -> String -> Symbol -> Int -> Int -> GhcOptions -> GhcPkgOptions -> WriterT [String] IO (Either String String) -guessHaddockUrl targetFile targetModule symbol lineNr colNr (GhcOptions ghcOpts0) ghcPkgOpts = do +guessHaddockUrl _targetFile targetModule symbol lineNr colNr (GhcOptions ghcOpts0) ghcPkgOpts = do + c <- CMT.liftIO findCradle + let currentDir = cradleCurrentDir c + workDir = cradleRootDir c + CMT.liftIO $ setCurrentDirectory workDir + + let targetFile = currentDir _targetFile + myTell $ "targetFile: " ++ targetFile myTell $ "targetModule: " ++ targetModule myTell $ "symbol: " ++ show symbol diff --git a/Language/Haskell/GhcImportedFrom/UtilsFromCabalInstall.hs b/Language/Haskell/GhcImportedFrom/UtilsFromCabalInstall.hs deleted file mode 100644 --- a/Language/Haskell/GhcImportedFrom/UtilsFromCabalInstall.hs +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : UtilsFromCabalInstall --- Copyright : Carlo Hamalainen 2014 --- License : BSD3 --- --- Maintainer : carlo@carlo-hamalainen.net --- Stability : experimental --- Portability : portable --- --- We need a function from cabal-install which is not exported. - -module Language.Haskell.GhcImportedFrom.UtilsFromCabalInstall where - -import Data.Word ( Word32 ) -import Numeric ( showHex ) -import Data.List ( foldl' ) -import Data.Char ( ord ) -import Data.Bits ( shiftL, shiftR, xor ) - --- Required for a temporary workaround for https://github.com/carlohamalainen/ghc-imported-from/issues/10 - --- https://github.com/haskell/cabal/blob/master/cabal-install/Distribution/Client/Sandbox.hs#L129 -sandboxBuildDir :: FilePath -> FilePath -sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash "" - where - sandboxDirHash = jenkins sandboxDir - - -- See http://en.wikipedia.org/wiki/Jenkins_hash_function - jenkins :: String -> Word32 - jenkins str = loop_finish $ foldl' loop 0 str - where - loop :: Word32 -> Char -> Word32 - loop hash key_i' = hash''' - where - key_i = toEnum . ord $ key_i' - hash' = hash + key_i - hash'' = hash' + (shiftL hash' 10) - hash''' = hash'' `xor` (shiftR hash'' 6) - - loop_finish :: Word32 -> Word32 - loop_finish hash = hash''' - where - hash' = hash + (shiftL hash 3) - hash'' = hash' `xor` (shiftR hash' 11) - hash''' = hash'' + (shiftL hash'' 15) 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 @@ -25,32 +25,10 @@ module Language.Haskell.GhcImportedFrom.UtilsFromGhcMod where -import Language.Haskell.GhcImportedFrom.UtilsFromCabalInstall - -import Control.Applicative import Data.Generics hiding (typeOf) import GHC import GHC.SYB.Utils -import System.Directory -import System.FilePath -import Packages - -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal -import Distribution.PackageDescription -import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..)) -import Distribution.Simple.Program (ghcProgram) -import Distribution.Simple.Program.Types (programName, programFindVersion) -import Distribution.Text as DistText -import Distribution.Verbosity (silent) - -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 @@ -60,114 +38,3 @@ -- ghcmod/Language/Haskell/GhcMod/Info.hs listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) - --- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs -getGHCOptions :: [GHCOption] -> Cradle -> String -> BuildInfo -> IO [GHCOption] -getGHCOptions ghcopts cradle cdir binfo = do - cabalCpp <- cabalCppOptions cdir - let cpps = map ("-optP" ++) $ cppOptions binfo ++ cabalCpp - - return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps - where - pkgDb = cradlePackageDbOpts cradle - lang = maybe "-XHaskell98" (("-X" ++) . DistText.display) $ defaultLanguage binfo - libDirs = map ("-L" ++) $ extraLibDirs binfo - exts = map (("-X" ++) . DistText.display) $ usedExtensions binfo - libs = map ("-l" ++) $ extraLibs binfo - --- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs --- modification: return $ if ... instead of if .. return --- Extra modification: add dist-sandbox-[hash] directory. -cabalCppOptions :: FilePath -> IO [String] -cabalCppOptions dir = do - let sandboxSubDir = sandboxBuildDir $ dir ".cabal-sandbox" - sandboxFullPath = dir sandboxSubDir - - opts1 <- makeOpt $ dir "dist/build/autogen/cabal_macros.h" - opts2 <- makeOpt $ sandboxFullPath "build/autogen/cabal_macros.h" - - return $ opts1 ++ opts2 - where - makeOpt :: FilePath -> IO [String] - makeOpt cabalMacroDotH = do - exist <- doesFileExist cabalMacroDotH - return $ if exist then ["-include", cabalMacroDotH] - else [] - --- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs -getGHCId :: IO CompilerId -getGHCId = CompilerId GHC <$> getGHC - --- ghc-mod/Language/Haskell/GhcMod/CabalApi.hs -getGHC :: IO Version -getGHC = do - mv <- programFindVersion ghcProgram silent (programName ghcProgram) - case mv of - Nothing -> throwIO $ userError "ghc not found" - Just v -> return v - --- 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 - sandboxSubDir = sandboxBuildDir $ wdir ".cabal-sandbox" - sandboxFullPath = wdir sandboxSubDir - - extdirs = map expand $ dirs ++ cabalBuildDirs ++ [sandboxFullPath "build", sandboxFullPath "build/autogen"]:: [FilePath] - - expand :: FilePath -> FilePath - 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/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.4 +version: 0.2.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. @@ -20,21 +20,20 @@ library exposed-modules: Language.Haskell.GhcImportedFrom other-modules: Language.Haskell.GhcImportedFrom.UtilsFromGhcMod - Language.Haskell.GhcImportedFrom.UtilsFromCabalInstall Language.Haskell.GhcImportedFrom.Types other-extensions: CPP, Rank2Types - build-depends: base >=4.6 && <4.7 - , syb >=0.4 && <0.5 - , ghc >=7.6 && <7.7 - , ghc-paths >=0.1 && <0.2 + build-depends: base >=4.6 && <4.8 + , syb + , ghc + , ghc-paths , ghc-syb-utils - , ghc-mod >= 3.1.5 && <= 3.1.5 + , ghc-mod , filepath , safe , process , directory - , containers >= 0.5.0.0 && <= 0.5.0.0 + , containers , mtl , transformers if impl(ghc < 7.7) @@ -44,23 +43,31 @@ default-language: Haskell2010 +executable fake-ghc-for-ghc-imported-from + main-is: fake-ghc-for-ghc-imported-from.hs + GHC-Options: -Wall + hs-source-dirs: src + build-depends: base >=4.6 && <4.8 + , process + default-language: Haskell2010 + executable ghc-imported-from main-is: Main.hs GHC-Options: -Wall other-modules: Paths_ghc_imported_from other-extensions: CPP, Rank2Types - build-depends: base >=4.6 && <4.7 - , syb >=0.4 && <0.5 - , ghc >=7.6 && <7.7 - , ghc-paths >=0.1 && <0.2 + build-depends: base >=4.6 && <4.8 + , syb + , ghc + , ghc-paths , ghc-syb-utils - , ghc-mod >= 3.1.5 + , ghc-mod , ghc-imported-from , filepath , safe , process , directory - , containers >= 0.5.0.0 && <= 0.5.0.0 + , containers , mtl , transformers , hspec @@ -81,17 +88,17 @@ Type: exitcode-stdio-1.0 Other-Modules: Dir ImportedFromSpec - Build-Depends: base >=4.6 && <4.7 - , syb >=0.4 && <0.5 - , ghc >=7.6 && <7.7 - , ghc-paths >=0.1 && <0.2 + Build-Depends: base >=4.6 && <4.8 + , syb + , ghc + , ghc-paths , ghc-syb-utils - , ghc-mod >= 3.1.5 + , ghc-mod , filepath , safe , process , directory - , containers >= 0.5.0.0 && <= 0.5.0.0 + , containers , mtl , transformers , hspec @@ -99,4 +106,3 @@ Build-Depends: Cabal >= 1.10 && < 1.17 else Build-Depends: Cabal >= 1.18 - diff --git a/src/fake-ghc-for-ghc-imported-from.hs b/src/fake-ghc-for-ghc-imported-from.hs new file mode 100644 --- /dev/null +++ b/src/fake-ghc-for-ghc-imported-from.hs @@ -0,0 +1,25 @@ +module Main where + +-- Fake ghc binary, used to extract the GHC command line options +-- via the "cabal repl" command. Thanks to Herbert Valerio Riedel +-- on haskell-cafe for the tip: +-- +-- http://www.haskell.org/pipermail/haskell-cafe/2014-May/114183.html + +-- If we are called with --numeric-version or --info then we lie and pretend +-- to be the system's current default ghc binary. Will this cause problems if +-- someone is using --with-ghc elsewhere to choose the ghc binary? + +import Data.List (unwords) +import System.Cmd (rawSystem) +import System.Environment (getArgs) + +main :: IO () +main = do + args <- getArgs + + if length args == 1 + then case head args of "--numeric-version" -> rawSystem "ghc" ["--numeric-version"] >> return () + "--info" -> rawSystem "ghc" ["--info"] >> return () + _ -> putStrLn $ unwords args + else putStrLn $ unwords args