module Language.Haskell.GhcImportedFrom (
QualifiedName(..)
, Symbol(..)
, GhcOptions(..)
, GhcPkgOptions(..)
, HaskellModule(..)
, ghcOptionToGhcPKg
, getGhcOptionsViaGhcMod
, getGHCOptionsViaCradle
, modifyDFlags
, setDynamicFlags
, getTextualImports
, getSummary
, toHaskellModule
, lookupSymbol
, symbolImportedFrom
, postfixMatch
, moduleOfQualifiedName
, qualifiedName
, ghcPkgFindModule
, ghcPkgHaddockUrl
, moduleNameToHtmlFile
, expandMatchingAsImport
, specificallyMatches
, toHackageUrl
, bestPrefixMatches
, findHaddockModule
, matchToUrl
, guessHaddockUrl
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Instances()
import Control.Monad.Writer
import Control.Monad.Trans as CMT
import Data.Function (on)
import Data.List
import Data.Maybe
import Data.Typeable()
import Desugar()
import DynFlags
import FastString
import GHC
import GHC.Paths (libdir)
import GHC.SYB.Utils()
import HscTypes
import Name
import Outputable
import RdrName
import System.Directory
import System.Environment()
import System.FilePath
import System.IO
import System.Process
import TcRnTypes()
import qualified DynFlags()
import qualified GhcMonad
import qualified MonadUtils()
import qualified Packages
import qualified SrcLoc
import qualified Safe
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
import Language.Haskell.GhcImportedFrom.UtilsFromGhcMod
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)
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)
getGhcOptionsViaGhcMod :: IO GhcOptions
getGhcOptionsViaGhcMod = GhcOptions . cradlePackageDbOpts <$> findCradle
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
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
(dflags1, _, _) <- GHC.parseDynamicFlags dflags0 (map SrcLoc.noLoc $ ghcOpts1 ++ ghcOpts2 ++ ghcOpts0)
let dflags2 = dflags1 { hscTarget = HscInterpreted
, ghcLink = LinkInMemory
}
return (ghcOpts1, ghcOpts2, dflags2)
setDynamicFlags :: GhcMonad m => GhcOptions -> DynFlags -> m ([String], [GHCOption], DynFlags)
setDynamicFlags (GhcOptions extraGHCOpts) dflags0 = do
(ghcOpts1, ghcOpts2, dflags1) <- GhcMonad.liftIO $ modifyDFlags extraGHCOpts dflags0
void $ setSessionDynFlags dflags1
_ <- GhcMonad.liftIO $ Packages.initPackages dflags1
return (ghcOpts1, ghcOpts2, dflags1)
getTextualImports :: GhcOptions -> FilePath -> String -> WriterT [String] IO [SrcLoc.Located (ImportDecl RdrName)]
getTextualImports ghcopts targetFile targetModuleName = do
(ghcOpts1, ghcOpts2, modSum) <- CMT.liftIO $ getSummary ghcopts targetFile targetModuleName
myTell $ "getTextualImports: ghcOpts1: " ++ show ghcOpts1
myTell $ "getTextualImports: ghcOpts2: " ++ show ghcOpts2
return $ ms_textual_imps modSum
getSummary :: GhcOptions -> FilePath -> String -> IO ([String], [GHCOption], ModSummary)
getSummary ghcopts targetFile targetModuleName =
defaultErrorHandler defaultFatalMessager defaultFlushOut $
runGhc (Just libdir) $ do
(ghcOpts1, ghcOpts2, _) <- getSessionDynFlags >>= setDynamicFlags ghcopts
target <- guessTarget targetFile Nothing
setTargets [target]
_ <- load LoadAllTargets
setContext [(IIDecl . simpleImportDecl . mkModuleName) targetModuleName]
modSum <- getModSummary (mkModuleName targetModuleName)
return (ghcOpts1, ghcOpts2, 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 tracingDynFlags (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'
specifically = map removeBrackets $ (parseSpecifically . GHC.ideclHiding) idecl'
removeBrackets :: [a] -> [a]
removeBrackets [] = []
removeBrackets x = (init . tail) x
grabNames :: GHC.Located (GHC.IE GHC.RdrName) -> String
grabNames loc = showSDoc tracingDynFlags (ppr names)
where names = GHC.ieNames $ SrcLoc.unLoc loc
parseHiding :: Maybe (Bool, [Located (IE RdrName)]) -> [Maybe String]
parseHiding Nothing = [Nothing]
parseHiding (Just (False, _)) = []
parseHiding (Just (True, h)) = map (Just . grabNames) h
parseSpecifically :: Maybe (Bool, [Located (IE RdrName)]) -> [String]
parseSpecifically (Just (False, h)) = map grabNames h
parseSpecifically _ = []
lookupSymbol :: GhcOptions -> FilePath -> String -> String -> [String] -> IO [(Name, [GlobalRdrElt])]
lookupSymbol ghcopts targetFile targetModuleName qualifiedSymbol importList =
defaultErrorHandler defaultFatalMessager defaultFlushOut $
runGhc (Just libdir) $ do
_ <- getSessionDynFlags >>= setDynamicFlags ghcopts
target <- guessTarget targetFile Nothing
setTargets [target]
_ <- load LoadAllTargets
setContext $ map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName:importList)
modSummary <- getModSummary $ mkModuleName targetModuleName :: Ghc ModSummary
p <- parseModule modSummary :: Ghc ParsedModule
t <- typecheckModule p :: Ghc TypecheckedModule
d <- desugarModule t :: Ghc DesugaredModule
let guts = coreModule d :: ModGuts
gre = HscTypes.mg_rdr_env guts :: GlobalRdrEnv
names <- parseName qualifiedSymbol
let occNames = map nameOccName names :: [OccName]
occNamesLookups = map (lookupGlobalRdrEnv gre) occNames :: [[GlobalRdrElt]]
return $ zip names occNamesLookups
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] -> IO [String]
qualifiedName ghcopts targetFile targetModuleName lineNr colNr importList =
defaultErrorHandler defaultFatalMessager defaultFlushOut $
runGhc (Just libdir) $ do
_ <- getSessionDynFlags >>= setDynamicFlags ghcopts
target <- guessTarget targetFile Nothing
setTargets [target]
_ <- load LoadAllTargets
setContext $ map (IIDecl . simpleImportDecl . mkModuleName) (targetModuleName: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 tracingDynFlags $ ppr x
bs' = map foo bs
es' = map foo es
ps' = map foo ps
return $ bs' ++ es' ++ ps'
readRestOfHandle :: Handle -> IO String
readRestOfHandle h = do
ineof <- hIsEOF h
if ineof
then return ""
else hGetContents h
ghcPkgFindModule :: GhcPkgOptions -> String -> WriterT [String] IO (Maybe String)
ghcPkgFindModule (GhcPkgOptions extraGHCPkgOpts) m = do
(GhcOptions gopts) <- CMT.liftIO getGhcOptionsViaGhcMod :: WriterT [String] IO GhcOptions
let opts = ["find-module", m, "--simple-output"] ++ ["--global", "--user"] ++ ghcOptionToGhcPKg gopts ++ extraGHCPkgOpts
myTell $ "ghc-pkg " ++ show opts
(_, Just hout, Just herr, _) <- CMT.liftIO $ createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
output <- CMT.liftIO $ readRestOfHandle hout
err <- CMT.liftIO $ readRestOfHandle herr
myTell $ "ghcPkgFindModule stdout: " ++ output
myTell $ "ghcPkgFindModule stderr: " ++ err
return $ join $ Safe.lastMay <$> words <$> (Safe.lastMay . lines) output
ghcPkgHaddockUrl :: GhcPkgOptions -> String -> WriterT [String] IO (Maybe String)
ghcPkgHaddockUrl (GhcPkgOptions extraGHCPkgOpts) p = do
(GhcOptions gopts) <- CMT.liftIO getGhcOptionsViaGhcMod :: WriterT [String] IO GhcOptions
let opts = ["field", p, "haddock-html"] ++ ["--global", "--user"] ++ ghcOptionToGhcPKg gopts ++ extraGHCPkgOpts
myTell $ "ghc-pkg "++ show opts
(_, Just hout, _, _) <- CMT.liftIO $ createProcess (proc "ghc-pkg" opts){ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
line <- CMT.liftIO $ (reverse . dropWhile (== '\n') . reverse) <$> readRestOfHandle hout
return $ Safe.lastMay $ words line
moduleNameToHtmlFile :: String -> String
moduleNameToHtmlFile m = map f m ++ ".html"
where f :: Char -> Char
f '.' = '-'
f c = c
expandMatchingAsImport :: QualifiedName -> [HaskellModule] -> Maybe QualifiedName
expandMatchingAsImport symbol hmodules = case x of (Just (h, Just cp)) -> Just $ modName h ++ drop (length cp) symbol
_ -> Nothing
where x = Safe.headMay $ filter (isJust . snd) $ zip hmodules (map (cmpMod symbol) hmodules)
cmpMod s (HaskellModule _ _ _ _ (Just impAs) _) = if impAs `isPrefixOf` s
then Just $ commonPrefix s impAs
else Nothing
cmpMod _ _ = Nothing
commonPrefix :: Eq a => [a] -> [a] -> [a]
commonPrefix a b = map fst (takeWhile (uncurry (==)) (zip a b))
specificallyMatches :: Symbol -> [HaskellModule] -> [HaskellModule]
specificallyMatches symbol = filter (\h -> symbol `elem` modSpecifically h)
toHackageUrl :: FilePath -> String -> String -> String
toHackageUrl filepath package modulename = "https://hackage.haskell.org/package/" ++ package ++ "/" ++ "docs/" ++ modulename''
where filepath' = map repl filepath
modulename' = head $ separateBy '.' $ head $ separateBy '-' modulename
modulename'' = drop (fromJust $ substringP modulename' filepath') filepath'
repl :: Char -> Char
repl '\\' = '/'
repl c = c
substringP :: String -> String -> Maybe Int
substringP _ [] = Nothing
substringP sub str = if sub `isPrefixOf` str then Just 0 else fmap (+1) $ substringP sub (tail str)
bestPrefixMatches :: Name -> [GlobalRdrElt] -> [String]
bestPrefixMatches name lookUp = x''
where name' = showSDoc tracingDynFlags $ ppr name
name'' = fromJust $ moduleOfQualifiedName name'
x = concatMap symbolImportedFrom lookUp
x' = map (showSDoc tracingDynFlags . ppr) x
x'' = filter (name'' `isPrefixOf`) x'
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)
let definedIn = nameModule name
bpms = bestPrefixMatches name lookUp
importedFrom = if null smatches
then if null bpms then Safe.headMay $ map (showSDoc tracingDynFlags . ppr) $ concatMap symbolImportedFrom lookUp
else Safe.headMay bpms :: Maybe String
else (Just . (showSDoc tracingDynFlags . ppr) . mkModuleName . fromJust . moduleOfQualifiedName) symbol''
myTell $ "definedIn: " ++ showSDoc tracingDynFlags (ppr definedIn)
myTell $ "bpms: " ++ show bpms
myTell $ "concat $ map symbolImportedFrom lookUp: " ++ showSDoc tracingDynFlags (ppr $ concatMap symbolImportedFrom lookUp)
myTell $ "importedFrom: " ++ show importedFrom
foundModule <- maybe (return Nothing) (ghcPkgFindModule ghcPkgOpts) importedFrom
myTell $ "ghcPkgFindModule result: " ++ show foundModule
let base = moduleNameToHtmlFile <$> importedFrom
myTell $ "base: : " ++ show base
haddock <- maybe (return Nothing) (ghcPkgHaddockUrl ghcPkgOpts) foundModule
myTell $ "haddock: " ++ show haddock
myTell $ "foundModule: " ++ show foundModule
return (importedFrom, haddock, foundModule, base)
myTell :: MonadWriter [t] m => t -> m ()
myTell x = tell [x]
matchToUrl :: (Maybe String, Maybe String, Maybe String, Maybe String) -> WriterT [String] IO String
matchToUrl (importedFrom, haddock, foundModule, base) = do
let importedFrom' = fromJust importedFrom
haddock' = fromJust haddock
foundModule' = fromJust foundModule
base' = fromJust base
f = haddock' </> base'
e <- CMT.liftIO $ doesFileExist f
if e then return $ "file://" ++ f
else do myTell $ "f: " ++ show f
myTell $ "foundModule: " ++ show foundModule'
return $ toHackageUrl f foundModule' (showSDoc tracingDynFlags (ppr importedFrom'))
guessHaddockUrl :: FilePath -> String -> Symbol -> Int -> Int -> GhcOptions -> GhcPkgOptions -> WriterT [String] IO (Either String String)
guessHaddockUrl targetFile targetModule symbol lineNr colNr (GhcOptions ghcOpts0) ghcPkgOpts = do
myTell $ "targetFile: " ++ targetFile
myTell $ "targetModule: " ++ targetModule
myTell $ "symbol: " ++ show symbol
myTell $ "line nr: " ++ show lineNr
myTell $ "col nr: " ++ show colNr
textualImports <- getTextualImports (GhcOptions ghcOpts0) targetFile targetModule
let haskellModuleNames = map (modName . toHaskellModule) textualImports
myTell $ "haskellModuleNames: " ++ show haskellModuleNames
qnames <- CMT.liftIO $ filter (not . (' ' `elem`)) <$> qualifiedName (GhcOptions ghcOpts0) targetFile targetModule lineNr colNr haskellModuleNames
myTell $ "qualified names: " ++ show qnames
let matchingAsImport = expandMatchingAsImport symbol (map toHaskellModule textualImports)
myTell $ "matchingAsImport: " ++ show matchingAsImport
let postMatches = filter (postfixMatch symbol) qnames :: [String]
symbol' = fromMaybe (if null postMatches then symbol else minimumBy (compare `on` length) postMatches) matchingAsImport
myTell $ "postMatches: " ++ show postMatches
myTell $ "symbol': " ++ symbol'
let maybeExtraModule = moduleOfQualifiedName symbol'
haskellModuleNames' = if symbol == symbol' then haskellModuleNames else haskellModuleNames ++ [fromJust maybeExtraModule]
myTell $ "maybeExtraModule: " ++ show maybeExtraModule
myTell $ "haskellModuleNames': " ++ show haskellModuleNames'
let smatches = specificallyMatches symbol (map toHaskellModule textualImports)
myTell $ "smatches: " ++ show smatches
let symbol'' = if null smatches
then symbol'
else modName (head smatches) ++ "." ++ symbol
myTell $ "symbol'': " ++ symbol''
let allJust (a, b, c, d) = isJust a && isJust b && isJust c && isJust d
final1 <- CMT.liftIO $ lookupSymbol (GhcOptions ghcOpts0) targetFile targetModule symbol'' haskellModuleNames'
final2 <- filter allJust <$> mapM (findHaddockModule symbol'' smatches ghcPkgOpts) final1
final3 <- mapM matchToUrl final2
return (if null final3 then Left "No matches found."
else Right $ head final3)