module Language.Haskell.GhcImportedFrom (
QualifiedName
, Symbol
, GhcOptions(..)
, GhcPkgOptions(..)
, HaskellModule(..)
, modifyDFlags
, setDynamicFlags
, getTextualImports
, getSummary
, toHaskellModule
, symbolImportedFrom
, postfixMatch
, moduleOfQualifiedName
, qualifiedName
, ghcPkgFindModule
, ghcPkgHaddockUrl
, moduleNameToHtmlFile
, matchToUrl
, guessHaddockUrl
, haddockUrl
, getGhcOptionsViaCabalRepl
, Options (..)
, defaultOptions
, LineSeparator (..)
) where
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()
import Desugar()
import FastString
import GHC
import GHC.Paths (libdir)
import GHC.SYB.Utils()
import HscTypes
import Module
import Name
import Outputable
import RdrName
import System.Directory
import System.Environment()
import System.FilePath
import System.IO
import System.Process
import TcRnTypes()
import HsImpExp
import HsTypes
import Type
import HsPat
import qualified GhcMonad
import qualified MonadUtils()
import qualified Packages
import qualified SrcLoc
import qualified Safe
import Language.Haskell.GhcMod (
findCradle
, cradleRootDir
, Cradle(..)
)
import qualified Data.Map as M
import Language.Haskell.GhcMod.Monad ( runGmOutT )
import qualified Language.Haskell.GhcMod.Types as GhcModTypes
import Language.Haskell.GhcMod.Types (IOish(..))
import Language.Haskell.GhcMod.Monad.Types (GhcModLog(..), GmOut(..))
import Control.Monad.Trans.Journal (runJournalT)
import Language.Haskell.GhcImportedFrom.UtilsFromGhcMod
import Language.Haskell.GhcImportedFrom.Types
import Control.Exception (SomeException)
import qualified Text.Parsec as TP
import Data.Functor.Identity
import qualified Documentation.Haddock as Haddock
import Debug.Trace
import qualified DynFlags()
#if __GLASGOW_HASKELL__ >= 708
import DynFlags ( unsafeGlobalDynFlags )
tdflags = unsafeGlobalDynFlags
#else
import DynFlags ( tracingDynFlags )
tdflags = tracingDynFlags
#endif
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))
shortcut :: [IO (Maybe a)] -> IO (Maybe a)
shortcut [] = return Nothing
shortcut (a:as) = do
a' <- a
case a' of
a''@(Just _) -> return a''
Nothing -> shortcut as
type GHCOption = String
getStackSnapshotPkgDb :: IO (Maybe String)
getStackSnapshotPkgDb = do
putStrLn "getStackSnapshotPkgDb ..."
let p = (proc "stack" ["path", "--snapshot-pkg-db"]){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
(Just _, Just hout, Just _, _) <- createProcess p
ineof <- hIsEOF hout
x <- if ineof
then return ""
else (unwords . words) <$> hGetLine hout
return $ if x == "" then Nothing else Just x
getStackLocalPkgDb :: IO (Maybe String)
getStackLocalPkgDb = do
putStrLn "getStackLocalPkgDb ..."
let p = (proc "stack" ["path", "--local-pkg-db"]){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
(Just _, Just hout, Just _, _) <- createProcess p
ineof <- hIsEOF hout
x <- if ineof
then return ""
else (unwords . words) <$> hGetLine hout
return $ if x == "" then Nothing else Just x
getGhcOptionsViaStack :: IO (Maybe [String])
getGhcOptionsViaStack = do
putStrLn "getGhcOptionsViaStack..."
stackSnapshotPkgDb <- (fmap ("-package-db " ++)) <$> getStackSnapshotPkgDb :: IO (Maybe String)
stackLocalPkgDb <- (fmap ("-package-db " ++)) <$> getStackLocalPkgDb :: IO (Maybe String)
case (stackSnapshotPkgDb, stackLocalPkgDb) of
(Nothing, _) -> return Nothing
(_, Nothing) -> return Nothing
(Just stackSnapshotPkgDb', Just stackLocalPkgDb') -> do
let p = (proc "stack" ["ghci", "--with-ghc=fake-ghc-for-ghc-imported-from"]){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
(Just _, Just hout, Just _, _) <- createProcess p
ineof <- hIsEOF hout
result <- if ineof
then return ""
else do firstLine <- hGetLine hout
if "GHCi" `isPrefixOf` firstLine
then error "Accidentally started an interactive session with 'stack ghci'?"
else readRestOfHandle hout
let result' = filter ("--interactive" `isPrefixOf`) . lines $ result
return $ case length result' of
1 -> Just $ (filterOpts $ words $ head result') ++ [stackSnapshotPkgDb', stackLocalPkgDb']
_ -> Nothing
getGhcOptionsViaCabalRepl :: IO (Maybe [String])
getGhcOptionsViaCabalRepl = do
putStrLn "getGhcOptionsViaCabalRepl..."
(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"
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
filterOpts :: [String] -> [String]
filterOpts xs = filter (\x -> x /= "--interactive" && x /= "-fbuilding-cabal-package" && x /= "-Wall") $ dropModuleNames xs
dropModuleNames :: [String] -> [String]
dropModuleNames = filter parseHelper
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)
parseDottedHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String
parseDottedHaskellModuleName = TP.char '.' >> parseHaskellModuleName
parseFullHaskellModuleName :: TP.ParsecT String u Data.Functor.Identity.Identity String
parseFullHaskellModuleName = do
h <- parseHaskellModuleName
rest <- many parseDottedHaskellModuleName
return $ intercalate "." (h:rest)
parseHelper :: String -> Bool
parseHelper s = case TP.parse (parseFullHaskellModuleName <* TP.eof) "" s of Right _ -> False
Left _ -> True
parsePackageAndQualName = TP.choice [TP.try parsePackageAndQualNameWithHash, parsePackageAndQualNameNoHash]
parsePackageAndQualNameNoHash :: TP.ParsecT String u Data.Functor.Identity.Identity (String, String)
parsePackageAndQualNameNoHash = do
packageName <- parsePackageName
qualName <- parsePackageFinalQualName
return (packageName, qualName)
where
parsePackageName :: TP.ParsecT String u Data.Functor.Identity.Identity String
parsePackageName = TP.anyChar `TP.manyTill` TP.char ':'
parsePackageFinalQualName :: TP.ParsecT String u Data.Functor.Identity.Identity String
parsePackageFinalQualName = TP.many1 TP.anyChar
parsePackageAndQualNameWithHash :: TP.ParsecT String u Data.Functor.Identity.Identity (String, String)
parsePackageAndQualNameWithHash = do
packageName <- parsePackageName
_ <- parsePackageHash
qualName <- parsePackageFinalQualName
return (packageName, qualName)
where
parsePackageName :: TP.ParsecT String u Data.Functor.Identity.Identity String
parsePackageName = TP.anyChar `TP.manyTill` TP.char '@'
parsePackageHash :: TP.ParsecT String u Data.Functor.Identity.Identity String
parsePackageHash = TP.anyChar `TP.manyTill` TP.char ':'
parsePackageFinalQualName :: TP.ParsecT String u Data.Functor.Identity.Identity String
parsePackageFinalQualName = TP.many1 TP.anyChar
getGhcOptionsViaCabalReplOrEmpty :: IO [String]
getGhcOptionsViaCabalReplOrEmpty = fromMaybe [] <$> shortcut [getGhcOptionsViaStack, getGhcOptionsViaCabalRepl]
type QualifiedName = String
type Symbol = String
newtype GhcOptions
= GhcOptions [String] deriving (Show)
newtype GhcPkgOptions
= GhcPkgOptions [String] deriving (Show)
data HaskellModule
= HaskellModule { modName :: String
, modQualifier :: Maybe String
, modIsImplicit :: Bool
, modHiding :: [String]
, modImportedAs :: Maybe String
, modSpecifically :: [String]
} deriving (Show, Eq)
modifyDFlags :: [String] -> DynFlags -> IO ([GHCOption], DynFlags)
modifyDFlags ghcOpts0 dflags0 =
runGhc (Just libdir) $ do
ghcOpts1 <- GhcMonad.liftIO getGhcOptionsViaCabalReplOrEmpty
(dflags1, _, _) <- GHC.parseDynamicFlags dflags0 (map SrcLoc.noLoc $ ghcOpts0 ++ ghcOpts1)
let dflags2 = dflags1 { hscTarget = HscInterpreted
, ghcLink = LinkInMemory
}
return (ghcOpts0 ++ ghcOpts1, dflags2)
setDynamicFlags :: GhcMonad m => GhcOptions -> DynFlags -> m ([GHCOption], DynFlags)
setDynamicFlags (GhcOptions extraGHCOpts) dflags0 = do
(allGhcOpts, dflags1) <- GhcMonad.liftIO $ modifyDFlags extraGHCOpts dflags0
void $ setSessionDynFlags dflags1
_ <- GhcMonad.liftIO $ Packages.initPackages dflags1
return (allGhcOpts, dflags1)
getTextualImports :: GhcMonad m => GhcOptions -> FilePath -> String -> m ([GHCOption], [SrcLoc.Located (ImportDecl RdrName)])
getTextualImports ghcopts targetFile targetModuleName = do
GhcMonad.liftIO $ putStrLn $ "getTextualImports: " ++ show (targetFile, targetModuleName)
(allGhcOpts, modSum) <- getSummary ghcopts targetFile targetModuleName
GhcMonad.liftIO $ putStrLn $ "getTextualImports: allGhcOpts: " ++ show allGhcOpts
return (allGhcOpts, ms_textual_imps modSum)
getSummary :: GhcMonad m => GhcOptions -> FilePath -> String -> m ([GHCOption], ModSummary)
getSummary ghcopts targetFile targetModuleName = do
GhcMonad.liftIO $ putStrLn "getSummary, setting dynamic flags..."
(allGhcOpts, _) <- getSessionDynFlags >>= setDynamicFlags ghcopts
GhcMonad.liftIO $ putStrLn $ "getSummary, allGhcOpts: " ++ show allGhcOpts
GhcMonad.liftIO $ putStrLn "getSummary, loading the target file..."
target <- guessTarget targetFile Nothing
setTargets [target]
_ <- load LoadAllTargets
GhcMonad.liftIO $ putStrLn "getSummary, setting the context..."
setContext [(IIDecl . simpleImportDecl . mkModuleName) targetModuleName]
`gcatch` (\(e :: SourceError) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a SourceError, trying to continue anyway..." ++ show e))
`gcatch` (\(g :: GhcApiError) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g))
`gcatch` (\(se :: SomeException) -> GhcMonad.liftIO (putStrLn $ "getSummary: setContext failed with a SomeException, trying to continue anyway..." ++ show se))
GhcMonad.liftIO $ putStrLn "getSummary, extracting the module summary..."
modSum <- getModSummary (mkModuleName targetModuleName)
return (allGhcOpts, modSum)
toHaskellModule :: SrcLoc.Located (GHC.ImportDecl GHC.RdrName) -> HaskellModule
toHaskellModule idecl = HaskellModule name qualifier isImplicit hiding importedAs specifically
where idecl' = SrcLoc.unLoc idecl
name = showSDoc tdflags (ppr $ GHC.ideclName idecl')
isImplicit = GHC.ideclImplicit idecl'
qualifier = unpackFS <$> GHC.ideclPkgQual idecl'
hiding = (catMaybes . parseHiding . GHC.ideclHiding) idecl'
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.LIE GHC.RdrName] -> [String]
grabNames' loc = map (showSDoc tdflags . ppr) names
where names :: [RdrName]
names = map (ieName . SrcLoc.unLoc) $ SrcLoc.unLoc loc
parseHiding :: Maybe (Bool, Located [LIE RdrName]) -> [Maybe String]
parseHiding Nothing = [Nothing]
parseHiding (Just (False, _)) = []
parseHiding (Just (True, h)) = map Just $ grabNames' h
parseSpecifically :: Maybe (Bool, Located [LIE RdrName]) -> [String]
parseSpecifically (Just (False, h)) = grabNames' h
parseSpecifically _ = []
symbolImportedFrom :: GlobalRdrElt -> [ModuleName]
symbolImportedFrom occNameLookup = map importSpecModule whys
where prov = gre_prov occNameLookup :: Provenance
Imported (whys :: [ImportSpec]) = prov
separateBy :: Eq a => a -> [a] -> [[a]]
separateBy chr = unfoldr sep' where
sep' [] = Nothing
sep' l = Just . fmap (drop 1) . break (==chr) $ l
postfixMatch :: Symbol -> QualifiedName -> Bool
postfixMatch originalSymbol qName = endTerm `isSuffixOf` qName
where endTerm = last $ separateBy '.' originalSymbol
moduleOfQualifiedName :: QualifiedName -> Maybe String
moduleOfQualifiedName qn = if null bits
then Nothing
else Just $ intercalate "." bits
where bits = reverse $ drop 1 $ reverse $ separateBy '.' qn
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` (\(s :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SourceError, trying to continue anyway..." ++ show s
setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)
`gcatch` (\(g :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g
setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)
`gcatch` (\(se :: SomeException) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SomeException, trying to continue anyway..." ++ show se
setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)
modSummary <- getModSummary $ mkModuleName targetModuleName :: Ghc ModSummary
p <- parseModule modSummary :: Ghc ParsedModule
t <- typecheckModule p :: Ghc TypecheckedModule
let TypecheckedModule{tm_typechecked_source = tcs} = t
bs = listifySpans tcs (lineNr, colNr) :: [LHsBind Id]
es = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id]
ps = listifySpans tcs (lineNr, colNr) :: [LPat Id]
let foo x = showSDoc tdflags $ ppr x
bs' = map foo bs
es' = map foo es
ps' = map foo ps
return $ bs' ++ es' ++ ps'
qualifiedName' :: GhcOptions -> FilePath -> String -> Int -> Int -> String -> [String] -> Ghc [String]
qualifiedName' ghcopts targetFile targetModuleName lineNr colNr symbol importList = do
setContext (map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList))
`gcatch` (\(s :: SourceError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SourceError, trying to continue anyway..." ++ show s
setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)
`gcatch` (\(g :: GhcApiError) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a GhcApiError, trying to continue anyway..." ++ show g
setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)
`gcatch` (\(se :: SomeException) -> do GhcMonad.liftIO $ putStrLn $ "qualifiedName: setContext failed with a SomeException, trying to continue anyway..." ++ show se
setContext $ map (IIDecl . simpleImportDecl . mkModuleName) importList)
modSummary <- getModSummary $ mkModuleName targetModuleName :: Ghc ModSummary
p <- parseModule modSummary :: Ghc ParsedModule
t <- typecheckModule p :: Ghc TypecheckedModule
let TypecheckedModule{tm_typechecked_source = tcs} = t
bs = listifySpans tcs (lineNr, colNr) :: [LHsBind Id]
es = listifySpans tcs (lineNr, colNr) :: [LHsExpr Id]
ps = listifySpans tcs (lineNr, colNr) :: [LPat Id]
let bs' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) bs
es' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) es
ps' = map (showSDocForUser tdflags reallyAlwaysQualify . ppr) ps
return $ filter (postfixMatch symbol) $ concatMap words $ bs' ++ es' ++ ps'
readRestOfHandle :: Handle -> IO String
readRestOfHandle h = do
ineof <- hIsEOF h
if ineof
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
ghcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)
ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m =
shortcut [ stackGhcPkgFindModule m
, hcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m
, _ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m
]
_ghcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)
_ghcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m = do
let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts
putStrLn $ "ghc-pkg " ++ show opts
(_, 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
return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output
hcPkgFindModule :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)
hcPkgFindModule allGhcOptions (GhcPkgOptions extraGHCPkgOpts) m = do
let opts = ["sandbox", "hc-pkg", "find-module", m, "--", "--simple-output"]
(_, Just hout, Just herr, _) <- createProcess (proc "cabal" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
output <- readRestOfHandle hout
err <- readRestOfHandle herr
putStrLn $ "hcPkgFindModule stdout: " ++ show output
putStrLn $ "hcPkgFindModule stderr: " ++ show err
return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output
stackGhcPkgFindModule :: String -> IO (Maybe String)
stackGhcPkgFindModule m = do
do let opts = ["exec", "ghc-pkg", "find-module", m, "--", "--simple-output"]
(_, Just hout, Just herr, _) <- createProcess (proc "stack" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
output <- readRestOfHandle hout
err <- readRestOfHandle herr
putStrLn $ "stackGhcPkgFindModule stdout: " ++ show output
putStrLn $ "stackGhcPkgFindModule stderr: " ++ show err
return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output
ghcPkgHaddockUrl :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)
ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p =
shortcut [ stackPkgHaddockUrl p
, sandboxPkgHaddockUrl p
, _ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p
]
_ghcPkgHaddockUrl :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)
_ghcPkgHaddockUrl allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do
let opts = ["field", p, "haddock-html"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts
putStrLn $ "ghc-pkg "++ show opts
(_, Just hout, _, _) <- createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout
return $ Safe.lastMay $ words line
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
stackPkgHaddockUrl :: String -> IO (Maybe String)
stackPkgHaddockUrl p = do
let opts = ["exec", "ghc-pkg", "field", p, "haddock-html"]
putStrLn $ "stack exec hc-pkg field " ++ p ++ " haddock-html"
(_, Just hout, _, _) <- createProcess (proc "stack" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout
print ("line", line)
if "haddock-html:" `isInfixOf` line
then do print ("line2", Safe.lastMay $ words line)
return $ Safe.lastMay $ words line
else return Nothing
ghcPkgHaddockInterface :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)
ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p =
shortcut [ stackGhcPkgHaddockInterface p
, cabalPkgHaddockInterface p
, _ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p
]
where
_ghcPkgHaddockInterface :: [String] -> GhcPkgOptions -> String -> IO (Maybe String)
_ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do
let opts = ["field", p, "haddock-interfaces"] ++ ["--global", "--user"] ++ optsForGhcPkg allGhcOptions ++ extraGHCPkgOpts
putStrLn $ "ghc-pkg "++ show opts
(_, Just hout, _, _) <- createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout
return $ Safe.lastMay $ words line
cabalPkgHaddockInterface :: String -> IO (Maybe String)
cabalPkgHaddockInterface p = do
let opts = ["sandbox", "hc-pkg", "field", p, "haddock-interfaces"]
putStrLn $ "cabal sandbox hc-pkg field " ++ p ++ " haddock-interfaces"
(_, Just hout, _, _) <- createProcess (proc "cabal" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout
print $ ("ZZZZZZZZZZZZZ", line)
return $ if "haddock-interfaces" `isInfixOf` line
then Safe.lastMay $ words line
else Nothing
stackGhcPkgHaddockInterface :: String -> IO (Maybe String)
stackGhcPkgHaddockInterface p = do
let opts = ["exec", "ghc-pkg", "field", p, "haddock-interfaces"]
putStrLn $ "stack exec ghc-pkg field " ++ p ++ " haddock-interfaces"
(_, Just hout, _, _) <- createProcess (proc "stack" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
line <- (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout
print $ ("UUUUUUUUUUUUU", line, opts)
return $ if "haddock-interfaces" `isInfixOf` line
then Safe.lastMay $ words line
else Nothing
getVisibleExports :: [String] -> GhcPkgOptions -> String -> Ghc (Maybe (M.Map String [String]))
getVisibleExports allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p = do
haddockInterfaceFile <- GhcMonad.liftIO $ ghcPkgHaddockInterface allGhcOptions (GhcPkgOptions extraGHCPkgOpts) p
join <$> traverse getVisibleExports' haddockInterfaceFile
where
getVisibleExports' :: FilePath -> Ghc (Maybe (M.Map String [String]))
getVisibleExports' ifile = do
iface <- Haddock.readInterfaceFile Haddock.nameCacheFromGhc ifile
case iface of
Left err -> GhcMonad.liftIO $ do putStrLn $ "Failed to read the Haddock interface file: " ++ ifile
putStrLn "You probably installed packages without using the '--enable-documentation' flag."
putStrLn ""
putStrLn "Try something like:\n\n\tcabal install --enable-documentation p"
error $ "No haddock interfaces file, giving up."
Right iface' -> do let m = map (\ii -> (Haddock.instMod ii, Haddock.instVisibleExports ii)) $ Haddock.ifInstalledIfaces iface' :: [(Module, [Name])]
m' = map (\(mname, names) -> (showSDoc tdflags $ ppr mname, map (showSDoc tdflags . ppr) names)) m :: [(String, [String])]
return $ Just $ M.fromList m'
moduleNameToHtmlFile :: String -> String
moduleNameToHtmlFile m = map f m ++ ".html"
where f :: Char -> Char
f '.' = '-'
f c = c
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
base' = fromJust base
f = haddock' </> base'
e <- doesFileExist f
if e then return $ "file://" ++ f
else do putStrLn $ "Please reinstall packages using the flag '--enable-documentation' for 'cabal install.\n"
error $ "Could not find " ++ f
filterMatchingQualifiedImport :: String -> [HaskellModule] -> [HaskellModule]
filterMatchingQualifiedImport symbol hmodules =
case moduleOfQualifiedName symbol of Nothing -> []
asBit@(Just _) -> filter (\z -> asBit == modImportedAs z) hmodules
findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle
findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
getModuleExports :: GhcOptions
-> GhcPkgOptions
-> HaskellModule
-> Ghc (Maybe ([String], String))
getModuleExports (GhcOptions ghcOpts) ghcPkgOpts m = do
minfo <- ((findModule (mkModuleName $ modName m) Nothing) >>= getModuleInfo)
`gcatch` (\(e :: SourceError) -> return Nothing)
p <- GhcMonad.liftIO $ ghcPkgFindModule ghcOpts 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
type FullyQualifiedName = String
type StrModuleName = String
data MySymbol = MySymbolSysQualified String
| MySymbolUserQualified String
deriving Show
data ModuleExports = ModuleExports
{ mName :: StrModuleName
, mPackageName :: String
, mInfo :: HaskellModule
, qualifiedExports :: [FullyQualifiedName]
}
deriving Show
pprModuleExports :: ModuleExports -> String
pprModuleExports me = mName me ++ "\n" ++ show (mInfo me) ++ "\n" ++ unwords (map show $ qualifiedExports me)
refineAs :: MySymbol -> [ModuleExports] -> [ModuleExports]
refineAs (MySymbolUserQualified userQualSym) exports = filter f exports
where
f export = case modas of
Nothing -> False
Just modas' -> modas' == userQualAs
where modas = modImportedAs $ mInfo export :: Maybe String
userQualAs = fromMaybe (error $ "Expected a qualified name like 'DL.length' but got: " ++ userQualSym)
(moduleOfQualifiedName userQualSym)
refineAs (MySymbolSysQualified _) exports = exports
refineRemoveHiding :: String -> [ModuleExports] -> [ModuleExports]
refineRemoveHiding symbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports
where
f symbol export = filter (`notElem` hiding') thisExports
where hiding = modHiding $ mInfo export :: [String]
hiding' = map (qualifyName thisExports) hiding :: [String]
thisExports = qualifiedExports export
qualifyName :: [QualifiedName] -> Symbol -> QualifiedName
qualifyName qualifiedNames name
= case filter (postfixMatch name) qualifiedNames of
[match] -> match
_ -> error $ "Could not qualify " ++ name ++ " from these exports: " ++ show qualifiedNames
refineExportsIt :: String -> [ModuleExports] -> [ModuleExports]
refineExportsIt symbol exports = map (\e -> e { qualifiedExports = f symbol e }) exports
where
f symbol export = filter (postfixMatch symbol) thisExports
where thisExports = qualifiedExports export
refineLeadingDot :: MySymbol -> [ModuleExports] -> [ModuleExports]
refineLeadingDot (MySymbolUserQualified userQualSym) exports = exports
refineLeadingDot (MySymbolSysQualified symb) exports = map (\e -> e { qualifiedExports = f leadingDot e }) exports
where
leadingDot :: String
leadingDot = '.' : last (separateBy '.' symb)
f symbol export = filter (symbol `isSuffixOf`) thisExports
where thisExports = qualifiedExports export
refineVisibleExports :: [String] -> GhcPkgOptions -> [ModuleExports] -> Ghc [ModuleExports]
refineVisibleExports allGhcOpts ghcpkgOptions exports = mapM f exports
where
f :: ModuleExports -> Ghc ModuleExports
f mexports = do
let pname = mPackageName mexports
thisModuleName = mName mexports
qexports = qualifiedExports mexports
visibleExportsMap <- getVisibleExports allGhcOpts ghcpkgOptions pname
GhcMonad.liftIO $ print visibleExportsMap
let thisModVisibleExports = fromMaybe
(error $ "Could not get visible exports of " ++ pname)
(join $ traverse (M.lookup thisModuleName) visibleExportsMap)
let qexports' = filter (hasPostfixMatch thisModVisibleExports) qexports
GhcMonad.liftIO $ print (qexports, qexports')
return $ mexports { qualifiedExports = qexports' }
hasPostfixMatch :: [String] -> String -> Bool
hasPostfixMatch xs s = last (separateBy '.' s) `elem` xs
getLastMatch :: [ModuleExports] -> Maybe ModuleExports
getLastMatch exports = Safe.lastMay $ filter f exports
where
f me = length (qualifiedExports me) == 1
guessHaddockUrl :: FilePath -> String -> Symbol -> Int -> Int -> GhcOptions -> GhcPkgOptions -> IO (Either String String)
guessHaddockUrl _targetFile targetModule symbol lineNr colNr (GhcOptions ghcOpts0) ghcpkgOptions = do
cradle <- runGmOutT GhcModTypes.defaultOptions findCradleNoLog
let currentDir = cradleCurrentDir cradle
workDir = cradleRootDir cradle
setCurrentDirectory workDir
let targetFile = currentDir </> _targetFile
putStrLn $ "currentDir: " ++ currentDir
putStrLn $ "workDir: " ++ workDir
putStrLn $ "targetFile: " ++ targetFile
putStrLn $ "targetModule: " ++ targetModule
putStrLn $ "symbol: " ++ show symbol
putStrLn $ "line nr: " ++ show lineNr
putStrLn $ "col nr: " ++ show colNr
putStrLn $ "ghcOpts0: " ++ show ghcOpts0
putStrLn $ "ghcpkgOptions: " ++ show ghcpkgOptions
runGhc (Just libdir) $ do
(allGhcOpts, textualImports) <- getTextualImports (GhcOptions ghcOpts0) targetFile targetModule
let haskellModules0 = map toHaskellModule textualImports
haskellModuleNames0 = map modName haskellModules0
GhcMonad.liftIO $ putStrLn $ "haskellModuleNames0: " ++ show haskellModuleNames0
GhcMonad.liftIO $ putStrLn $ "haskellModuleNames0 (full detail): " ++ show haskellModules0
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
qnames <- filter (not . (' ' `elem`)) <$> qualifiedName (GhcOptions ghcOpts0) targetFile 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]
GhcMonad.liftIO $ putStrLn $ "qualified names with qualified printing: " ++ show qnames_with_qualified_printing
let parsedPackagesAndQualNames :: [Either TP.ParseError (String, String)]
parsedPackagesAndQualNames = map (TP.parse parsePackageAndQualName "") qnames_with_qualified_printing
GhcMonad.liftIO $ putStrLn $ "qqqqqq1: " ++ show parsedPackagesAndQualNames
let symbolToUse :: String
symbolToUse = fromMaybe (head qnames) (Safe.headMay qnames_with_qualified_printing)
GhcMonad.liftIO $ print ("symbolToUse", symbolToUse)
let extraModules :: [HaskellModule]
extraModules = case Safe.headMay parsedPackagesAndQualNames of
Just (Right (_, x)) -> case moduleOfQualifiedName x of Just x' -> [ HaskellModule { modName = x'
, modQualifier = Nothing
, modIsImplicit = False
, modHiding = []
, modImportedAs = Nothing
, modSpecifically = []
}
]
Nothing -> []
_ -> []
GhcMonad.liftIO $ print extraModules
exports <- mapM (getModuleExports (GhcOptions ghcOpts0) ghcpkgOptions) (haskellModules0 ++ extraModules)
let successes :: [(HaskellModule, Maybe ([String], String))]
successes = filter (isJust . snd) (zip (haskellModules0 ++ extraModules) exports)
bubble :: (HaskellModule, Maybe ([FullyQualifiedName], String)) -> Maybe (HaskellModule, ([FullyQualifiedName], String))
bubble (h, Just x) = Just (h, x)
bubble (_, Nothing) = Nothing
successes' :: [(HaskellModule, ([String], String))]
successes' = mapMaybe bubble successes
upToNow = map (\(m, (e, p)) -> ModuleExports
{ mName = modName m
, mPackageName = p
, mInfo = m
, qualifiedExports = e
}) successes'
GhcMonad.liftIO $ forM_ upToNow $ \x -> putStrLn $ pprModuleExports x
let asImports :: [String]
asImports = mapMaybe (modImportedAs . mInfo) upToNow
let mySymbol = case moduleOfQualifiedName symbol of
Nothing -> MySymbolSysQualified symbolToUse
Just x -> if x `elem` asImports
then MySymbolUserQualified symbol
else MySymbolSysQualified symbolToUse
GhcMonad.liftIO $ print mySymbol
let upToNow0 = refineAs mySymbol upToNow
GhcMonad.liftIO $ putStrLn "upToNow0"
GhcMonad.liftIO $ forM_ upToNow0 $ \x -> putStrLn $ pprModuleExports x
let upToNow1 = refineRemoveHiding symbolToUse upToNow0
GhcMonad.liftIO $ putStrLn "upToNow1"
GhcMonad.liftIO $ forM_ upToNow1 $ \x -> putStrLn $ pprModuleExports x
let upToNow2 = refineExportsIt symbolToUse upToNow1
GhcMonad.liftIO $ putStrLn "upToNow2"
GhcMonad.liftIO $ forM_ upToNow2 $ \x -> putStrLn $ pprModuleExports x
let upToNow3 = refineLeadingDot mySymbol upToNow2
GhcMonad.liftIO $ putStrLn "upToNow3"
GhcMonad.liftIO $ forM_ upToNow3 $ \x -> putStrLn $ pprModuleExports x
upToNow4 <- refineVisibleExports allGhcOpts ghcpkgOptions upToNow3
GhcMonad.liftIO $ putStrLn "upToNow4"
GhcMonad.liftIO $ forM_ upToNow4 $ \x -> putStrLn $ pprModuleExports x
let lastMatch3 = getLastMatch upToNow3
lastMatch4 = getLastMatch upToNow4
lastMatch = Safe.headMay $ catMaybes [lastMatch4, lastMatch3]
GhcMonad.liftIO $ print $ "last match: " ++ show lastMatch
let matchedModule :: String
matchedModule = case mName <$> lastMatch of
Just mod -> mod
_ -> error $ "No nice match in lastMatch for module: " ++ show lastMatch
let matchedPackageName :: String
matchedPackageName = case mPackageName <$> lastMatch of
Just p -> p
_ -> error $ "No nice match in lastMatch for package name: " ++ show lastMatch
haddock <- GhcMonad.liftIO $ (maybe (return Nothing) (ghcPkgHaddockUrl allGhcOpts ghcpkgOptions) . Just) matchedPackageName
GhcMonad.liftIO $ putStrLn $ "at the end now: " ++ show (matchedModule, moduleNameToHtmlFile matchedModule, matchedPackageName, haddock)
url <- GhcMonad.liftIO $ matchToUrl (Just matchedModule, haddock, Just matchedModule, Just $ moduleNameToHtmlFile matchedModule)
return $ Right url
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 <- guessHaddockUrl file modstr symbol lineNr colNr ghcopts ghcpkgopts
print ("res", show res)
case res of Right x -> return $ "SUCCESS: " ++ x ++ "\n"
Left err -> return $ "FAIL: " ++ show err ++ "\n"