ghc-imported-from 0.3.0.0 → 0.3.0.1
raw patch · 7 files changed
+324/−316 lines, 7 filesdep +bytestringdep +hspec-discoverdep +process-streaming
Dependencies added: bytestring, hspec-discover, process-streaming
Files
- Language/Haskell/GhcImportedFrom.hs +270/−283
- changelog.md +4/−0
- ghc-imported-from.cabal +15/−5
- src/fake-ghc-for-ghc-imported-from.hs +0/−1
- stack.yaml +9/−0
- test/Dir.hs +0/−25
- test/ImportedFromSpec.hs +26/−2
Language/Haskell/GhcImportedFrom.hs view
@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : GhcImportedFrom--- Copyright : Carlo Hamalainen 2013, 2014+-- Copyright : Carlo Hamalainen 2013-2016 -- License : BSD3 -- -- Maintainer : carlo@carlo-hamalainen.net@@ -50,11 +50,6 @@ import Control.Applicative 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()@@ -64,8 +59,6 @@ import GHC.Paths (libdir) import GHC.SYB.Utils() import HscTypes-import Module-import Name import Outputable import RdrName import System.Directory@@ -74,10 +67,10 @@ import System.IO import System.Process import TcRnTypes()-import HsImpExp-import HsTypes-import Type-import HsPat+import System.Process.Streaming+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.ByteString.Internal (w2c) import qualified GhcMonad import qualified MonadUtils()@@ -96,7 +89,7 @@ import Language.Haskell.GhcMod.Monad ( runGmOutT ) import qualified Language.Haskell.GhcMod.Types as GhcModTypes -import Language.Haskell.GhcMod.Types (IOish(..))+import Language.Haskell.GhcMod.Types (IOish) import Language.Haskell.GhcMod.Monad.Types (GhcModLog(..), GmOut(..)) import Control.Monad.Trans.Journal (runJournalT) @@ -110,24 +103,56 @@ import qualified Documentation.Haddock as Haddock -import Debug.Trace- import qualified DynFlags() #if __GLASGOW_HASKELL__ >= 708 import DynFlags ( unsafeGlobalDynFlags )+tdflags :: DynFlags tdflags = unsafeGlobalDynFlags #else import DynFlags ( tracingDynFlags )+tdflags :: DynFlags tdflags = tracingDynFlags #endif -trace' :: Show x => String -> x -> b -> b-trace' m x = trace (m ++ ">>> " ++ show x)+type GHCOption = String -trace'' :: Outputable x => String -> x -> b -> b-trace'' m x = trace (m ++ ">>> " ++ showSDoc tdflags (ppr x))+type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@. +type Symbol = String -- ^ A symbol, possibly qualified, e.g. @bar@ or @Foo.bar@.++newtype GhcOptions+ -- | List of user-supplied GHC options, refer to @tets@ subdirectory for example usage. Note that+ -- GHC API and ghc-pkg have inconsistencies in the naming of options, see <http://www.vex.net/~trebla/haskell/sicp.xhtml> for more details.+ = GhcOptions [String] deriving (Show)++instance Monoid GhcOptions where+ mempty = GhcOptions []+ (GhcOptions g) `mappend` (GhcOptions h) = GhcOptions $ g ++ h++newtype GhcPkgOptions+ -- | List of user-supplied ghc-pkg options.+ = GhcPkgOptions [String] deriving (Show)++data HaskellModule+ -- | Information about an import of a Haskell module.+ = HaskellModule { modName :: String+ , modQualifier :: Maybe String+ , modIsImplicit :: Bool+ , modHiding :: [String]+ , modImportedAs :: Maybe String+ , modSpecifically :: [String]+ } deriving (Show, Eq)+++-- trace' :: Show x => String -> x -> b -> b+-- trace' m x = trace (m ++ ">>> " ++ show x)++-- trace'' :: Outputable x => String -> x -> b -> b+-- trace'' m x = trace (m ++ ">>> " ++ showSDoc tdflags (ppr x))++-- | Evaluate IO actions in sequence, returning the first that+-- succeeds. shortcut :: [IO (Maybe a)] -> IO (Maybe a) shortcut [] = return Nothing shortcut (a:as) = do@@ -137,141 +162,125 @@ a''@(Just _) -> return a'' Nothing -> shortcut as -type GHCOption = String+executeFallibly' :: String -> [String] -> IO (Maybe (String, String))+executeFallibly' cmd args = do+ x <- executeFallibly (pipeoe intoLazyBytes intoLazyBytes) (proc cmd args) -getStackSnapshotPkgDb :: IO (Maybe String)-getStackSnapshotPkgDb = do- putStrLn "getStackSnapshotPkgDb ..."+ return $ case x of+ Left e -> Nothing+ Right (_, (a, b)) -> Just $ (b2s a, b2s b) - let p = (proc "stack" ["path", "--snapshot-pkg-db"]){ std_in = CreatePipe- , std_out = CreatePipe- , std_err = CreatePipe- }+ where - (Just _, Just hout, Just _, _) <- createProcess p+ b2s = map w2c . B.unpack . BL.toStrict - ineof <- hIsEOF hout+-- | Use "stack path" to get the snapshot package db location.+getStackSnapshotPkgDb :: IO (Maybe String)+getStackSnapshotPkgDb = do+ putStrLn "getStackSnapshotPkgDb ..." - x <- if ineof- then return ""- else (unwords . words) <$> hGetLine hout+ x <- join <$> (fmap (fmap unwords . fmap words . Safe.headMay . lines) . fmap snd) <$> executeFallibly' "stack" ["path", "--snapshot-pkg-db"] - return $ if x == "" then Nothing else Just x+ return $ case x of+ Nothing -> Nothing+ Just "" -> Nothing+ Just x' -> Just x' +-- | Use "stack path" to get the local package db location. 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+ x <- join <$> (fmap (fmap unwords . fmap words . Safe.headMay . lines) . fmap snd) <$> executeFallibly' "stack" ["path", "--local-pkg-db"] - return $ if x == "" then Nothing else Just x+ return $ case x of+ Nothing -> Nothing+ Just "" -> Nothing+ Just x' -> Just x' +-- | Use "stack ghci" with our fake ghc binary to get all the GHC options related+-- to the local Stack configuration (if present). getGhcOptionsViaStack :: IO (Maybe [String]) getGhcOptionsViaStack = do putStrLn "getGhcOptionsViaStack..." - stackSnapshotPkgDb <- (fmap ("-package-db " ++)) <$> getStackSnapshotPkgDb :: IO (Maybe String)- stackLocalPkgDb <- (fmap ("-package-db " ++)) <$> getStackLocalPkgDb :: IO (Maybe String)+ 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+ x <- executeFallibly' "stack" ["ghci", "--with-ghc=fake-ghc-for-ghc-imported-from"] - let result' = filter ("--interactive" `isPrefixOf`) . lines $ result+ let result = case x of+ Nothing -> []+ Just (_, x') -> filter ("--interactive" `isPrefixOf`) . lines $ x' - return $ case length result' of- 1 -> Just $ (filterOpts $ words $ head result') ++ [stackSnapshotPkgDb', stackLocalPkgDb']- _ -> Nothing+ return $ case result of+ [r] -> Just $ filterOpts (words r) ++ [stackSnapshotPkgDb', stackLocalPkgDb']+ _ -> Nothing +-- | Use "cabal repl" with our fake ghc binary to get all the GHC options related+-- to the local cabal sandbox (if present). getGhcOptionsViaCabalRepl :: IO (Maybe [String]) getGhcOptionsViaCabalRepl = do 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- }-- 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 - FIXME change this to an error or something?- else do rest <- readRestOfHandle hout- return $ firstLine ++ "\n" ++ rest+ x <- executeFallibly' "cabal" ["repl", "--with-ghc=fake-ghc-for-ghc-imported-from"] - let result' = filter ("--interactive" `isPrefixOf`) . lines $ result+ let result = case x of+ Nothing -> []+ Just (_, x') -> filter ("--interactive" `isPrefixOf`) . lines $ x' - case length result' of 1 -> return $ Just $ filterOpts $ words $ head result'- _ -> return Nothing+ return $ case result of+ [r] -> Just $ filterOpts (words r)+ _ -> Nothing +-- | GHC options that we don't use when partially compiling the source module. filterOpts :: [String] -> [String] filterOpts xs = filter (\x -> x /= "--interactive" && x /= "-fbuilding-cabal-package" && x /= "-Wall") $ dropModuleNames xs -dropModuleNames :: [String] -> [String]-dropModuleNames = filter parseHelper+ where -parseHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String-parseHaskellModuleName = do- c <- TP.upper- cs <- TP.many (TP.choice [TP.lower, TP.upper, TP.char '_', TP.digit])- return (c:cs)+ dropModuleNames :: [String] -> [String]+ dropModuleNames = filter parseHelper -parseDottedHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String-parseDottedHaskellModuleName = TP.char '.' >> parseHaskellModuleName+ parseHelper :: String -> Bool+ parseHelper s = case TP.parse (parseFullHaskellModuleName <* TP.eof) "" s of Right _ -> False+ Left _ -> True -parseFullHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String-parseFullHaskellModuleName = do- h <- parseHaskellModuleName- rest <- many parseDottedHaskellModuleName+ parseFullHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String+ parseFullHaskellModuleName = do+ h <- parseHaskellModuleName+ rest <- many parseDottedHaskellModuleName - return $ intercalate "." (h:rest)+ return $ intercalate "." (h:rest) -parseHelper :: String -> Bool-parseHelper s = case TP.parse (parseFullHaskellModuleName <* TP.eof) "" s of Right _ -> False- Left _ -> True+ parseHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String+ parseHaskellModuleName = do+ c <- TP.upper+ cs <- TP.many (TP.choice [TP.lower, TP.upper, TP.char '_', TP.digit])+ return (c:cs) -parsePackageAndQualName = TP.choice [TP.try parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash]+ parseDottedHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String+ parseDottedHaskellModuleName = TP.char '.' >> parseHaskellModuleName --- 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)+parsePackageAndQualName :: forall u. TP.ParsecT String u Identity (String, String)+parsePackageAndQualName = TP.choice [TP.try parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash] where + -- 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+ qName <- parsePackageFinalQualName++ return (packageName, qName)+ parsePackageName :: TP.ParsecT String u Data.Functor.Identity.Identity String parsePackageName = TP.anyChar `TP.manyTill` TP.char ':' @@ -284,9 +293,9 @@ parsePackageAndQualNameWithHash = do packageName <- parsePackageName _ <- parsePackageHash- qualName <- parsePackageFinalQualName+ qName <- parsePackageFinalQualName - return (packageName, qualName)+ return (packageName, qName) where @@ -299,38 +308,60 @@ parsePackageFinalQualName :: TP.ParsecT String u Data.Functor.Identity.Identity String parsePackageFinalQualName = TP.many1 TP.anyChar -getGhcOptionsViaCabalReplOrEmpty :: IO [String]-getGhcOptionsViaCabalReplOrEmpty = fromMaybe [] <$> shortcut [getGhcOptionsViaStack, getGhcOptionsViaCabalRepl]--type QualifiedName = String -- ^ A qualified name, e.g. @Foo.bar@.--type Symbol = String -- ^ A symbol, possibly qualified, e.g. @bar@ or @Foo.bar@.--newtype GhcOptions- -- | List of user-supplied GHC options, refer to @tets@ subdirectory for example usage. Note that- -- GHC API and ghc-pkg have inconsistencies in the naming of options, see <http://www.vex.net/~trebla/haskell/sicp.xhtml> for more details.- = GhcOptions [String] deriving (Show)--newtype GhcPkgOptions- -- | List of user-supplied ghc-pkg options.- = GhcPkgOptions [String] deriving (Show)--data HaskellModule- -- | Information about an import of a Haskell module.- = HaskellModule { modName :: String- , modQualifier :: Maybe String- , modIsImplicit :: Bool- , modHiding :: [String]- , modImportedAs :: Maybe String- , modSpecifically :: [String]- } deriving (Show, Eq)+-- | Use "cabal repl" or "stack ghci" to try to get GHC options. Lots of things here, for+-- example:+--+-- --interactive -fbuilding-cabal-package -O0 -outputdir dist/build/rename-photos/rename-photos-tmp+-- -odir dist/build/rename-photos/rename-photos-tmp -hidir dist/build/rename-photos/rename-photos-tmp+-- -stubdir dist/build/rename-photos/rename-photos-tmp -i -idist/build/rename-photos/rename-photos-tmp+-- -i. -idist/build/autogen -Idist/build/autogen -Idist/build/rename-photos/rename-photos-tmp+-- -optP-include -optPdist/build/autogen/cabal_macros.h -dynload deploy+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/array_67iodizgJQIIxYVTp4emlA+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/base_HQfYBxpPvuw8OunzQu6JGM+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/binar_3uXFWMoAGBg0xKP9MHKRwi+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/rts+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/bytes_6VWy06pWzJq9evDvK2d4w6+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/conta_2C3ZI8RgPO2LBMidXKTvIU+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/deeps_6vMKxt5sPFR0XsbRWvvq59+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/direc_0hFG6ZxK1nk4zsyOqbNHfm+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/filep_Ey7a1in9roBAE8bUFJ5R9m+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/ghcpr_8TmvWUcS1U1IKHT0levwg3+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/integ_2aU3IZNMF9a7mQ0OzsZ0dS+-- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/mmorph-1.0.6-2Jm5FlYBlmjDhcU1ovZRKP+-- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/mtl-2.2.1-Aue4leSeVkpKLsfHIV51E8+-- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/parsec-3.1.9-EE5NO1mlYLh4J8mgDEshNv+-- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/pipes-4.1.8-77ihSQ5c6PS0Tlq86aN8G4+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/proce_52AgREEfSrnJLlkGV9YZZJ+-- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/text-1.2.2.0-5c7VCmRXJenGcMPs3kwpkI+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/time_FTheb6LSxyX1UABIbBXRfn+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/trans_GZTjP9K5WFq01xC9BAGQpF+-- -optl-Wl,-rpath,/scratch/sandboxes/camera-scripts/lib/x86_64-linux-ghc-7.10.3/transformers-compat-0.5.1.4-EfAx8JliEAN1Gu6x0L8GYr+-- -optl-Wl,-rpath,/opt/ghc/7.10.3/lib/ghc-7.10.3/unix_KZL8h98IqDM57kQSPo1mKx+-- -hide-all-packages+-- -no-user-package-db+-- -package-db /scratch/sandboxes/camera-scripts/x86_64-linux-ghc-7.10.3-packages.conf.d+-- -package-db dist/package.conf.inplace+-- -package-id base-4.8.2.0-0d6d1084fbc041e1cded9228e80e264d+-- -package-id bytestring-0.10.6.0-c60f4c543b22c7f7293a06ae48820437+-- -package-id containers-0.5.6.2-e59c9b78d840fa743d4169d4bea15592+-- -package-id directory-1.2.2.0-f8e14a9d121b76a00a0f669ee724a732+-- -package-id filepath-1.4.0.0-f97d1e4aebfd7a03be6980454fe31d6e+-- -package-id parsec-3.1.9-a68c5d78bf2a63f486c525b960f2dddd+-- -package-id pipes-4.1.8-394d3831f54f6d7e2c83d050d94ecb3a+-- -package-id process-1.2.3.0-78f206acb2330ea8066c6c19c87356f0+-- -package-id text-1.2.2.0-daec687352505adca80a15e023cbae5c+-- -package-id transformers-0.4.2.0-81450cd8f86b36eaa8fa0cbaf6efc3a3+-- -XHaskell98+-- ./renamePhotos.hs+getGhcOptionsViaCabalOrStack :: IO [String]+getGhcOptionsViaCabalOrStack = fromMaybe [] <$> shortcut [getGhcOptionsViaStack, getGhcOptionsViaCabalRepl] --- | Add user-supplied GHC options to those discovered via cabl repl.+-- | Add user-supplied GHC options. modifyDFlags :: [String] -> DynFlags -> IO ([GHCOption], DynFlags) modifyDFlags ghcOpts0 dflags0 = -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do- ghcOpts1 <- GhcMonad.liftIO getGhcOptionsViaCabalReplOrEmpty+ ghcOpts1 <- GhcMonad.liftIO getGhcOptionsViaCabalOrStack (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 (map SrcLoc.noLoc $ ghcOpts0 ++ ghcOpts1) @@ -368,7 +399,6 @@ -- ] -- -- See also 'toHaskellModule' and 'getSummary'.- getTextualImports :: GhcMonad m => GhcOptions -> FilePath -> String -> m ([GHCOption], [SrcLoc.Located (ImportDecl RdrName)]) getTextualImports ghcopts targetFile targetModuleName = do GhcMonad.liftIO $ putStrLn $ "getTextualImports: " ++ show (targetFile, targetModuleName)@@ -458,7 +488,6 @@ -- , modSpecifically = [] -- } -- ]- toHaskellModule :: SrcLoc.Located (GHC.ImportDecl GHC.RdrName) -> HaskellModule toHaskellModule idecl = HaskellModule name qualifier isImplicit hiding importedAs specifically where idecl' = SrcLoc.unLoc idecl@@ -469,9 +498,9 @@ importedAs = (showSDoc tdflags . ppr) <$> ideclAs idecl' 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.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 (showSDoc tdflags . ppr) names@@ -553,9 +582,8 @@ -- "h = Data.Map.Base.fromList [(\"x\", \"y\")]" -- "Data.Map.Base.fromList [(\"x\", \"y\")]" -- "Data.Map.Base.fromList"--qualifiedName :: GhcOptions -> FilePath -> String -> Int -> Int -> [String] -> Ghc [String]-qualifiedName ghcopts targetFile targetModuleName lineNr colNr importList = do+qualifiedName :: String -> Int -> Int -> [String] -> Ghc [String]+qualifiedName targetModuleName lineNr colNr 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)@@ -585,8 +613,8 @@ -- "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+qualifiedName' :: String -> Int -> Int -> String -> [String] -> Ghc [String]+qualifiedName' 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)@@ -638,7 +666,7 @@ ghcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String) ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m = shortcut [ stackGhcPkgFindModule m- , hcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m+ , hcPkgFindModule m , _ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m ] @@ -649,54 +677,39 @@ let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts putStrLn $ "ghc-pkg " ++ show opts - (_, Just hout, Just herr, _) <- createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe- , std_out = CreatePipe- , std_err = CreatePipe- }-- output <- readRestOfHandle hout- err <- readRestOfHandle herr-- putStrLn $ "_ghcPkgFindModule stdout: " ++ show output- putStrLn $ "_ghcPkgFindModule stderr: " ++ show err+ x <- executeFallibly' "ghc-pkg" opts - return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output+ case x of+ Nothing -> return Nothing+ Just (output, err) -> do putStrLn $ "_ghcPkgFindModule stdout: " ++ show output+ putStrLn $ "_ghcPkgFindModule stderr: " ++ show err+ return $ join $ (Safe.lastMay . words) <$> (Safe.lastMay . lines) output -- | 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+hcPkgFindModule :: String -> IO (Maybe String)+hcPkgFindModule 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+ x <- executeFallibly' "cabal" opts - return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output+ case x of+ Nothing -> return Nothing+ Just (output, err) -> do 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+ let opts = ["exec", "ghc-pkg", "find-module", m, "--", "--simple-output"] - return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output+ x <- executeFallibly' "stack" opts + case x of+ Nothing -> return Nothing+ Just (output, err) -> do 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 =@@ -711,122 +724,93 @@ let opts = ["field", p, "haddock-html"] ++ ["--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- }+ x <- executeFallibly' "ghc-pkg" opts - line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout- return $ Safe.lastMay $ words line+ case x of+ Nothing -> return Nothing+ Just (hout, _) -> return $ Safe.lastMay $ words $ reverse . dropWhile (== '\n') . reverse $ hout +readHaddockHtmlOutput :: FilePath -> [String] -> IO (Maybe String)+readHaddockHtmlOutput cmd opts = do+ x <- executeFallibly' cmd opts++ case x of+ Nothing -> return Nothing+ Just (hout, _) -> do let line = reverse . dropWhile (== '\n') . reverse $ 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 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+ readHaddockHtmlOutput "cabal" opts -- | 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------------+ readHaddockHtmlOutput "stack" opts ghcPkgHaddockInterface :: [String] -> GhcPkgOptions -> String -> IO (Maybe String) ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p =- shortcut [ stackGhcPkgHaddockInterface p- , cabalPkgHaddockInterface p- , _ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p+ shortcut [ stackGhcPkgHaddockInterface+ , cabalPkgHaddockInterface+ , _ghcPkgHaddockInterface ] where - _ghcPkgHaddockInterface :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)- _ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do+ _ghcPkgHaddockInterface :: IO (Maybe String)+ _ghcPkgHaddockInterface = 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- }+ x <- executeFallibly' "ghc-pkg" opts - line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout- return $ Safe.lastMay $ words line+ return $ case x of+ Nothing -> Nothing+ Just (hout, _) -> Safe.lastMay $ words $ reverse . dropWhile (== '\n') . reverse $ hout -- | Call cabal sandbox hc-pkg to find the haddock Interfaces.- cabalPkgHaddockInterface :: String -> IO (Maybe String)- cabalPkgHaddockInterface p = do+ cabalPkgHaddockInterface :: IO (Maybe String)+ cabalPkgHaddockInterface = 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- }+ x <- executeFallibly' "cabal" opts - line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout- print $ ("ZZZZZZZZZZZZZ", line)+ case x of+ Nothing -> return Nothing+ Just (hout, _) -> do let line = reverse . dropWhile (== '\n') . reverse $ hout+ print ("ZZZZZZZZZZZZZ", line) - return $ if "haddock-interfaces" `isInfixOf` line- then Safe.lastMay $ words line- else Nothing+ 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+ stackGhcPkgHaddockInterface :: IO (Maybe String)+ stackGhcPkgHaddockInterface = 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)+ x <- executeFallibly' "stack" opts - return $ if "haddock-interfaces" `isInfixOf` line- then Safe.lastMay $ words line- else Nothing+ case x of+ Nothing -> return Nothing+ Just (hout, _) -> do let line = reverse . dropWhile (== '\n') . reverse $ 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@@ -840,11 +824,11 @@ iface <- Haddock.readInterfaceFile Haddock.nameCacheFromGhc ifile case iface of- Left err -> GhcMonad.liftIO $ do putStrLn $ "Failed to read the Haddock interface file: " ++ ifile+ Left _ -> 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."+ 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'@@ -912,9 +896,9 @@ when (isNothing foundModule) $ error "foundModule is Nothing :(" when (isNothing base) $ error "base is Nothing :(" - let importedFrom' = fromJust importedFrom+ let -- importedFrom' = fromJust importedFrom haddock' = fromJust haddock- foundModule' = fromJust foundModule+ -- foundModule' = fromJust foundModule base' = fromJust base f = haddock' </> base'@@ -922,7 +906,7 @@ e <- doesFileExist f if e then return $ "file://" ++ f- else do putStrLn $ "Please reinstall packages using the flag '--enable-documentation' for 'cabal install.\n"+ else do putStrLn "Please reinstall packages using the flag '--enable-documentation' for 'cabal install.\n" error $ "Could not find " ++ f filterMatchingQualifiedImport :: String -> [HaskellModule] -> [HaskellModule]@@ -938,18 +922,18 @@ -> GhcPkgOptions -> HaskellModule -> Ghc (Maybe ([String], String))-getModuleExports (GhcOptions ghcOpts) ghcPkgOpts m = do- minfo <- ((findModule (mkModuleName $ modName m) Nothing) >>= getModuleInfo)- `gcatch` (\(e :: SourceError) -> return Nothing)+getModuleExports (GhcOptions gopts) ghcpkgOpts m = do+ minfo <- (findModule (mkModuleName $ modName m) Nothing >>= getModuleInfo)+ `gcatch` (\(_ :: SourceError) -> return Nothing) - p <- GhcMonad.liftIO $ ghcPkgFindModule ghcOpts ghcPkgOpts (modName m)+ p <- GhcMonad.liftIO $ ghcPkgFindModule gopts ghcpkgOpts (modName m) case (minfo, p) of (Nothing, _) -> return Nothing (_, Nothing) -> return Nothing (Just minfo', Just p') -> return $ Just (map (showSDocForUser tdflags reallyAlwaysQualify . ppr) $ modInfoExports minfo', p') -type UnqualifiedName = String -- ^ e.g. "Just"+-- 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" @@ -989,10 +973,10 @@ -- 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+refineRemoveHiding :: [ModuleExports] -> [ModuleExports]+refineRemoveHiding exports = map (\e -> e { qualifiedExports = f e }) exports where- f symbol export = filter (`notElem` hiding') thisExports+ f 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.@@ -1007,11 +991,11 @@ 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+ f sym export = filter (postfixMatch sym) thisExports where thisExports = qualifiedExports export -- Things that this module exports. refineLeadingDot :: MySymbol -> [ModuleExports] -> [ModuleExports]-refineLeadingDot (MySymbolUserQualified userQualSym) exports = exports+refineLeadingDot (MySymbolUserQualified _) exports = exports refineLeadingDot (MySymbolSysQualified symb) exports = map (\e -> e { qualifiedExports = f leadingDot e }) exports where leadingDot :: String@@ -1093,13 +1077,13 @@ -- 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 haskellModules = if null filterThings then haskellModules0 else filterThings 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+ qnames <- filter (not . (' ' `elem`)) <$> qualifiedName targetModule lineNr colNr haskellModuleNames GhcMonad.liftIO $ putStrLn $ "qualified names: " ++ show qnames - qnames_with_qualified_printing <- filter (not . (' ' `elem`)) <$> qualifiedName' (GhcOptions ghcOpts0) targetFile targetModule lineNr colNr symbol haskellModuleNames :: Ghc [String]+ qnames_with_qualified_printing <- filter (not . (' ' `elem`)) <$> qualifiedName' targetModule lineNr colNr symbol haskellModuleNames :: Ghc [String] GhcMonad.liftIO $ putStrLn $ "qualified names with qualified printing: " ++ show qnames_with_qualified_printing let parsedPackagesAndQualNames :: [Either TP.ParseError (String, String)]@@ -1108,7 +1092,10 @@ GhcMonad.liftIO $ putStrLn $ "qqqqqq1: " ++ show parsedPackagesAndQualNames let symbolToUse :: String- symbolToUse = fromMaybe (head qnames) (Safe.headMay qnames_with_qualified_printing) -- FIXME dodgy use of 'head'+ symbolToUse = case (qnames_with_qualified_printing, qnames) of+ (qq:_, _) -> qq -- We got a qualified name, with qualified printing. Qualified!+ ([], qn:_) -> qn -- No qualified names (oh dear) so fall back to qnames list.+ ([], []) -> error "Lists 'qnames' and 'qnames_with_qualified_printing' are both empty." GhcMonad.liftIO $ print ("symbolToUse", symbolToUse) @@ -1172,7 +1159,7 @@ GhcMonad.liftIO $ putStrLn "upToNow0" GhcMonad.liftIO $ forM_ upToNow0 $ \x -> putStrLn $ pprModuleExports x - let upToNow1 = refineRemoveHiding symbolToUse upToNow0+ let upToNow1 = refineRemoveHiding upToNow0 GhcMonad.liftIO $ putStrLn "upToNow1" GhcMonad.liftIO $ forM_ upToNow1 $ \x -> putStrLn $ pprModuleExports x @@ -1198,7 +1185,7 @@ let matchedModule :: String matchedModule = case mName <$> lastMatch of- Just mod -> mod+ Just modn -> modn _ -> error $ "No nice match in lastMatch for module: " ++ show lastMatch let matchedPackageName :: String
changelog.md view
@@ -1,3 +1,7 @@+2016-03-30 v0.3.0.1++* Bugfix: use process-streaming to avoid deadlock on Fedora 23.+ 2016-03-26 v0.3.0.0 * New heuristics for resolving symbols.
ghc-imported-from.cabal view
@@ -1,5 +1,5 @@ name: ghc-imported-from-version: 0.3.0.0+version: 0.3.0.1 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.@@ -11,7 +11,7 @@ -- copyright: category: Development build-type: Simple-extra-source-files: README.md changelog.md+extra-source-files: README.md changelog.md stack.yaml cabal-version: >=1.10 @@ -34,7 +34,9 @@ , monad-journal , filepath , safe+ , bytestring , process+ , process-streaming < 0.9.0.0 , directory , containers , mtl@@ -42,6 +44,8 @@ , parsec , optparse-applicative , haddock-api+ , hspec+ , hspec-discover if impl(ghc < 7.7) Build-Depends: Cabal >= 1.10 && < 1.17 else@@ -55,6 +59,7 @@ hs-source-dirs: src build-depends: base >=4.0 && <5 , process+ , process-streaming < 0.9.0.0 default-language: Haskell2010 executable ghc-imported-from@@ -72,15 +77,18 @@ , ghc-imported-from , filepath , safe+ , bytestring , process+ , process-streaming < 0.9.0.0 , directory , containers , mtl , transformers , parsec , optparse-applicative- , hspec , haddock-api+ , hspec+ , hspec-discover if impl(ghc < 7.7) Build-Depends: Cabal >= 1.10 && < 1.17@@ -96,8 +104,7 @@ Main-Is: Spec.hs Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0- Other-Modules: Dir- ImportedFromSpec+ Other-Modules: ImportedFromSpec Build-Depends: base >=4.0 && <5 , syb , ghc@@ -107,7 +114,9 @@ , monad-journal , filepath , safe+ , bytestring , process+ , process-streaming < 0.9.0.0 , directory , containers , mtl@@ -115,6 +124,7 @@ , parsec , optparse-applicative , hspec+ , hspec-discover , haddock-api if impl(ghc < 7.7) Build-Depends: Cabal >= 1.10 && < 1.17
src/fake-ghc-for-ghc-imported-from.hs view
@@ -10,7 +10,6 @@ -- 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)
+ stack.yaml view
@@ -0,0 +1,9 @@+flags: {}+packages:+- '.'+extra-deps:+- ghc-7.10.3+- conceit-0.3.2.0+- pipes-text-0.0.1.0+- process-streaming-0.7.2.2+resolver: lts-5.10
− test/Dir.hs
@@ -1,25 +0,0 @@--- copied from ghc-mod/test-module Dir where--import Control.Exception as E-import Data.List (isPrefixOf)-import System.Directory-import System.FilePath (addTrailingPathSeparator)--withDirectory_ :: FilePath -> IO a -> IO a-withDirectory_ dir action = bracket getCurrentDirectory- setCurrentDirectory- (\_ -> setCurrentDirectory dir >> action)--withDirectory :: FilePath -> (FilePath -> IO a) -> IO a-withDirectory dir action = bracket getCurrentDirectory- setCurrentDirectory- (\d -> setCurrentDirectory dir >> action d)--toRelativeDir :: FilePath -> FilePath -> FilePath-toRelativeDir dir file- | dir' `isPrefixOf` file = drop len file- | otherwise = file- where- dir' = addTrailingPathSeparator dir- len = length dir'
test/ImportedFromSpec.hs view
@@ -2,15 +2,39 @@ module ImportedFromSpec where -import Data.List (isSuffixOf, isInfixOf, isPrefixOf) import Language.Haskell.GhcImportedFrom import System.FilePath() import Test.Hspec -import Dir+import Control.Exception as E+import Data.List (isPrefixOf)+import System.Directory+import System.FilePath (addTrailingPathSeparator) +-------------------------------------------------------------------------------+-- withDirectory_, withDirectory, and toRelativeDir are copied+-- from ghc-mod.+withDirectory_ :: FilePath -> IO a -> IO a+withDirectory_ dir action = bracket getCurrentDirectory+ setCurrentDirectory+ (\_ -> setCurrentDirectory dir >> action)++withDirectory :: FilePath -> (FilePath -> IO a) -> IO a+withDirectory dir action = bracket getCurrentDirectory+ setCurrentDirectory+ (\d -> setCurrentDirectory dir >> action d)++toRelativeDir :: FilePath -> FilePath -> FilePath+toRelativeDir dir file+ | dir' `isPrefixOf` file = drop len file+ | otherwise = file+ where+ dir' = addTrailingPathSeparator dir+ len = length dir'+ 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.