leksah-0.4.0.3: src/IDE/Metainfo/SourceCollector.hs
{-# OPTIONS_GHC -XScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Metainfo.SourceCollector
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>
-- Stability : experimental
-- Portability : portable
--
-- | This module collects information for packages with source available
--
-------------------------------------------------------------------------------
module IDE.Metainfo.SourceCollector (
collectSources
, buildSourceForPackageDB
, sourceForPackage
, parseSourceForPackageDB
, getSourcesMap
, unloadGhc
) where
import qualified Text.PrettyPrint.HughesPJ as PP
import qualified Data.Map as Map
import Data.Map (Map)
import Distribution.PackageDescription
import Distribution.Verbosity
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language(emptyDef)
import System.Directory
import Control.Monad.State
import System.FilePath
import System.IO
import Data.List (foldl',nub,delete,sort)
import Data.Maybe(catMaybes)
import qualified Control.Exception as C
import qualified Data.ByteString.Char8 as BS
import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Control.Exception (SomeException)
import GHC hiding (idType)
import SrcLoc
import RdrName
import OccName
import DynFlags
--import PackageConfig hiding (exposedModules,package)
import FastString
import Outputable hiding (char)
import IDE.Core.State
import IDE.FileUtils
import IDE.Pane.Preferences
import Digraph (flattenSCCs)
import HscTypes (msHsFilePath)
import Distribution.Package (PackageIdentifier(..))
import Distribution.Text (display)
-- ---------------------------------------------------------------------
-- | Collect infos from sources for one package
--
collectSources :: Map PackageIdentifier [FilePath]
-> PackageDescr
-> Ghc (PackageDescr,Int)
collectSources sourceMap pdescr = do
unloadGhc
sysMessage Normal $ "Now collecting sources for " ++ display (packagePD pdescr)
case sourceForPackage (packagePD pdescr) sourceMap of
Nothing -> do
sysMessage Normal $ "No source for package " ++ display (packagePD pdescr)
return (pdescr,0)
Just cabalPath' -> gcatch (do
cabalPath <- liftIO $ canonicalizePath cabalPath'
let basePath = takeDirectory cabalPath
pkgDescr <- gcatch (liftIO $ (liftM flattenPackageDescription
(readPackageDescription silent cabalPath)))
(\(e :: SomeException) -> return emptyPackageDescription)
let bis = allBuildInfo pkgDescr
let buildPaths = if hasExes pkgDescr
then let exeName' = exeName (head (executables pkgDescr))
in -- map (\p -> basePath </> p) $
("dist" </> "build" </> exeName' </>
exeName' ++ "-tmp" </> "") :
("dist" </> "build" </> "autogen") : (".")
: (nub $ concatMap hsSourceDirs bis)
else -- map (\p -> basePath </> p) $
("dist" </> "build" </> "autogen") : (".")
: (nub $ concatMap hsSourceDirs bis)
let includes = {-- map (\p -> basePath </> p) $ --} nub $ concatMap includeDirs bis
dflags <- getSessionDynFlags
let dflags2 = dflags {
topDir = basePath,
hscTarget = HscAsm,
ghcMode = CompManager,
ghcLink = NoLink}
setSessionDynFlags dflags2
let flags = ["-fglasgow-exts"]
++ ["-cpp"]
++ ["-I" ++ dir | dir <- includes]
++ ["-I" ++ dir | dir <- buildPaths]
++ ["-i" ++ dir | dir <- includes]
++ ["-i" ++ dir | dir <- buildPaths]
-- trace ("flags " ++ show flags) $ return ()
dflags3 <- getSessionDynFlags
(dflags4,_,_) <- parseDynamicFlags dflags3 (map noLoc flags)
let dflags5 = dopt_set dflags4 Opt_Haddock
setSessionDynFlags dflags5
defaultCleanupHandler dflags (do
let allMods = nub (exeModules pkgDescr ++ libModules pkgDescr)
let interestingMods = map (modu . moduleIdMD) (exposedModulesPD pdescr)
sourceFiles <- liftIO $ mapM (findSourceFile
buildPaths
["hs","lhs","chs","hs.pp","lhs.pp","chs.pp"])
$ nub (interestingMods ++ allMods)
liftIO $ mapM_ (\(mbSf, mn) ->
case mbSf of
Nothing -> putStrLn $ "Cant find source file for " ++ mn
Just _ -> return ()) $ zip sourceFiles (map display allMods)
(newModDescrs,failureCount) <- collectSourcesForPackage pdescr (catMaybes sourceFiles)
(map display interestingMods)
let nPackDescr = pdescr{mbSourcePathPD = Just cabalPath,
exposedModulesPD = newModDescrs}
return (nPackDescr,failureCount)))
(\(e :: SomeException) -> do
sysMessage Normal $ "source collector throwIDE1 " ++ show e ++ " in " ++
display (packagePD pdescr) ++ " missed "
++ show (length $ exposedModulesPD pdescr)
return (pdescr,length $ exposedModulesPD pdescr))
-- ---------------------------------------------------------------------
-- | Collect infos from sources for modules
--
--------------------------
collectSourcesForPackage :: PackageDescr -> [String] -> [String] -> Ghc ([ModuleDescr],Int)
collectSourcesForPackage pkgDescr sourceFiles interesting = do
targets <- mapM (\f -> guessTarget f Nothing) sourceFiles
setTargets targets
trace ("before depanal") $ return ()
modgraph <- depanal [] False
trace ("after depanal") $ return ()
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
let interestingMods = filter (\m -> elem (moduleNameString (ms_mod_name m)) interesting) orderedMods
let orderedTupels = catMaybes (map (\om -> case filter (\m -> ((moduleNameString . moduleName . ms_mod) om) ==
(display . modu . moduleIdMD) m)
(exposedModulesPD pkgDescr) of
[] -> trace ("Cant find module source " ++ (moduleNameString . moduleName . ms_mod) om) $ Nothing
(x:_) -> (Just (x,om))) interestingMods)
foldM collectSourcesForModule ([],0) orderedTupels
collectSourcesForModule :: ([ModuleDescr],Int) -> (ModuleDescr, ModSummary) -> Ghc ([ModuleDescr],Int)
collectSourcesForModule (moduleDescrs,failureCount) (modD,modsum) = gcatch (do
let filename = msHsFilePath modsum
let dynflags = ms_hspp_opts modsum
parsedMod <- parseModule modsum
let decls = (hsmodDecls . unLoc . parsedSource) $ parsedMod
let map' = convertToMap (idDescriptionsMD modD)
let commentedDecls = addComments (filterSignatures decls)
let (descrs,restMap) = foldl' collectParseInfoForDecl ([],map') commentedDecls
let newMod = modD{
idDescriptionsMD = reverse descrs ++ concat (Map.elems restMap),
mbSourcePathMD = Just filename}
return(newMod : moduleDescrs, failureCount))
(\(e :: SomeException) -> do
sysMessage Normal $ "source collector throwIDE2 " ++ show e ++ " in " ++
msHsFilePath modsum
return (modD : moduleDescrs, failureCount + 1))
where
convertToMap :: [Descr] -> Map Symbol [Descr]
convertToMap list =
foldl' (\ st idDescr -> Map.insertWith (++) (descrName idDescr) [idDescr] st)
Map.empty list
convertFromMap :: Map Symbol [Descr] -> [Descr]
convertFromMap = concat . Map.elems
filterSignatures :: [LHsDecl RdrName] -> [LHsDecl RdrName]
filterSignatures declList = filter filterSignature declList
where
filterSignature (L srcDecl (SigD _)) = False
filterSignature _ = True
addComments :: [LHsDecl RdrName] -> [(Maybe (LHsDecl RdrName), Maybe String)]
addComments = reverse . snd . foldl' addComment (Nothing,[])
where
addComment :: (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)])
-> LHsDecl RdrName
-> (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)])
addComment (maybeComment,((Just decl,Nothing):r)) (L srcDecl (DocD (DocCommentPrev doc))) =
(Nothing,((Just decl,Just (printHsDoc doc)):r))
addComment other (L srcDecl (DocD (DocCommentPrev doc))) =
other
addComment (maybeComment,resultList) (L srcDecl (DocD (DocCommentNext doc))) =
(Just (printHsDoc doc),resultList)
addComment (maybeComment,resultList) (L srcDecl (DocD (DocGroup i doc))) =
(Nothing,(((Nothing,Just (printHsDoc doc)): resultList)))
addComment (maybeComment,resultList) (L srcDecl (DocD (DocCommentNamed str doc))) =
(Nothing,resultList)
addComment (Nothing,resultList) decl = (Nothing,(Just decl,Nothing):resultList)
addComment (Just comment,resultList) decl = (Nothing,(Just decl,Just comment):resultList)
collectParseInfoForDecl :: ([Descr],SymbolTable)
-> (Maybe (LHsDecl RdrName),Maybe String)
-> ([Descr],SymbolTable)
collectParseInfoForDecl (l,st) (Just (L loc _),_) | not (isGoodSrcSpan loc) = (l,st)
collectParseInfoForDecl (l,st) ((Just (L loc (ValD (FunBind lid _ _ _ _ _)))), mbComment')
= addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Variable] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyData _ _ lid _ _ _ _ _)))), mbComment')
= addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Data] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyFamily _ lid _ _)))), mbComment')
= addLocationAndComment (l,st) (unLoc lid) loc mbComment' [] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TySynonym lid _ _ _)))), mbComment')
= addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Type] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment')
= addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] []
collectParseInfoForDecl (l,st) ((Just (L loc (InstD (InstDecl lid binds sigs cldecl)))), mbComment')
= case unLoc lid of
HsForAllTy _ _ _ e ->
case unLoc e of
HsPredTy p ->
case p of
HsClassP n types
-> --trace ("name: " ++ unpackFS (occNameFS (rdrNameOcc n)) ++ "\n" ++
--"binds : " ++ showSDocUnqual (ppr binds) ++ "\n" ++
--"sigs : " ++ showSDocUnqual (ppr sigs) ++ "\n" ++
--"cldecl : " ++ showSDocUnqual (ppr cldecl) ++ "\n" ++
-- "types : " ++ showSDocUnqual (ppr types)) $
addLocationAndComment (l,st) n loc mbComment' [Instance]
(map (\t -> analyse (unLoc t)) types)
_ -> trace ("lid3:Other") (l,st)
_ -> trace "lid2:Other" (l,st)
_ -> trace "lid:Other" (l,st)
where
analyse (HsTyVar n) = unpackFS (occNameFS (rdrNameOcc n))
analyse (HsForAllTy n _ _ _) = trace "lid5:For all" ""
analyse _ = trace "lid5:Other" ""
collectParseInfoForDecl (l,st) (Just decl,mbComment')
= {--trace (declTypeToString (unLoc decl) ++ "--" ++ (showSDocUnqual $ppr decl))--} (l,st)
collectParseInfoForDecl (l,st) (Nothing, mbComment') =
{--trace ("Found comment " ++ show mbComment')--} (l,st)
addLocationAndComment :: ([Descr],SymbolTable)
-> RdrName
-> SrcSpan
-> Maybe String
-> [DescrType]
-> [String]
-> ([Descr],SymbolTable)
addLocationAndComment (l,st) lid srcSpan mbComment' types insts =
let occ = rdrNameOcc lid
name = unpackFS (occNameFS occ)
mbItems = Map.lookup name st
(mbItem,nst)= case mbItems of
Nothing -> (Nothing,st)
Just [i] -> (Just i, Map.delete name st)
Just list ->
case filter (\i -> matches i types insts) list of
[] -> (Nothing,st)
l' -> (Just (head l'),
Map.adjust (\li -> delete (head l') li)
name st)
in case mbItem of
Just identDescr |not (isReexported identDescr) -> (identDescr{
mbLocation' = Just (srcSpanToLocation srcSpan),
mbComment' = case mbComment' of
Nothing -> Nothing
Just s -> Just (BS.pack s)}
: l, nst)
otherwise -> (l,st)
where
matches :: Descr -> [DescrType] -> [String] -> Bool
matches idDescr idTypes inst =
case descrType (details idDescr) of
Instance ->
--trace ("instances " ++ show (sort (binds idDescr)) ++ " -- ?= -- " ++ show (sort inst)) $
elem Instance idTypes && sort (binds (details idDescr)) == sort inst
other -> elem other idTypes
declTypeToString :: Show alpha => HsDecl alpha -> String
declTypeToString (TyClD _) = "TyClD"
declTypeToString (InstD _) = "InstD"
declTypeToString (DerivD _)= "DerivD"
declTypeToString (ValD _) = "ValD"
declTypeToString (SigD _) = "SigD"
declTypeToString (DefD _) = "DefD"
declTypeToString (ForD _) = "ForD"
declTypeToString (WarningD _)= "WarnD"
declTypeToString (RuleD _) = "RuleD"
declTypeToString (SpliceD _) = "SpliceD"
declTypeToString (DocD v) = "DocD " ++ show v
srcSpanToLocation :: SrcSpan -> Location
srcSpanToLocation span | not (isGoodSrcSpan span)
= throwIDE "srcSpanToLocation: unhelpful span"
srcSpanToLocation span
= Location (srcSpanStartLine span) (srcSpanStartCol span)
(srcSpanEndLine span) (srcSpanEndCol span)
printHsDoc :: Show alpha => HsDoc alpha -> String
printHsDoc DocEmpty = ""
printHsDoc (DocAppend l r) = printHsDoc l ++ " " ++ printHsDoc r
printHsDoc (DocString str) = str
printHsDoc (DocParagraph d) = printHsDoc d ++ "\n"
printHsDoc (DocIdentifier l) = concatMap show l
printHsDoc (DocModule str) = "Module " ++ str
printHsDoc (DocEmphasis doc) = printHsDoc doc
printHsDoc (DocMonospaced doc) = printHsDoc doc
printHsDoc (DocUnorderedList l) = concatMap printHsDoc l
printHsDoc (DocOrderedList l) = concatMap printHsDoc l
printHsDoc (DocDefList li) = concatMap (\(l,r) -> printHsDoc l ++ " " ++
printHsDoc r) li
printHsDoc (DocCodeBlock doc) = printHsDoc doc
printHsDoc (DocURL str) = str
printHsDoc (DocAName str) = str
printHsDoc _ = ""
instance Show RdrName where
show = unpackFS . occNameFS . rdrNameOcc
instance Show alpha => Show (DocDecl alpha) where
show (DocCommentNext doc) = "DocCommentNext " ++ show doc
show (DocCommentPrev doc) = "DocCommentPrev " ++ show doc
show (DocCommentNamed str doc) = "DocCommentNamed" ++ " " ++ str ++ " " ++ show doc
show (DocGroup i doc) = "DocGroup" ++ " " ++ show i ++ " " ++ show doc
unloadGhc :: Ghc ()
unloadGhc = do
setTargets []
load LoadAllTargets
return ()
-- ---------------------------------------------------------------------
-- Function to map packages to file paths
--
getSourcesMap :: IO (Map PackageIdentifier [FilePath])
getSourcesMap = do
mbSources <- parseSourceForPackageDB
case mbSources of
Just map -> return map
Nothing -> do
buildSourceForPackageDB
mbSources <- parseSourceForPackageDB
case mbSources of
Just map -> do
return map
Nothing -> throwIDE "can't build/open source for package file"
sourceForPackage :: PackageIdentifier
-> (Map PackageIdentifier [FilePath])
-> Maybe FilePath
sourceForPackage id map =
case id `Map.lookup` map of
Just (h:_) -> Just h
_ -> Nothing
buildSourceForPackageDB :: IO ()
buildSourceForPackageDB = do
prefsPath <- getConfigFilePathForLoad "Default.prefs"
prefs <- readPrefs prefsPath
case autoExtractTars prefs of
Nothing -> return ()
Just path -> do
dir <- getCurrentDirectory
autoExtractTarFiles path
setCurrentDirectory dir
let dirs = sourceDirectories prefs
cabalFiles <- mapM allCabalFiles dirs
fCabalFiles <- mapM canonicalizePath $ concat cabalFiles
mbPackages <- mapM (\fp -> parseCabal fp) fCabalFiles
let pdToFiles = Map.fromListWith (++)
$ map (\(Just p,o ) -> (p,o))
$ filter (\(mb, _) -> case mb of
Nothing -> False
_ -> True )
$ zip mbPackages (map (\a -> [a]) fCabalFiles)
filePath <- getConfigFilePathForSave "source_packages.txt"
writeFile filePath (PP.render (showSourceForPackageDB pdToFiles))
showSourceForPackageDB :: Map String [FilePath] -> PP.Doc
showSourceForPackageDB aMap = PP.vcat (map showIt (Map.toList aMap))
where
showIt :: (String,[FilePath]) -> PP.Doc
showIt (pd,list) = (foldl' (\l n -> l PP.$$ (PP.text $ show n)) label list)
PP.<> PP.char '\n'
where label = PP.text pd PP.<> PP.colon
parseSourceForPackageDB :: IO (Maybe (Map PackageIdentifier [FilePath]))
parseSourceForPackageDB = do
filePath <- getConfigFilePathForLoad "source_packages.txt"
exists <- doesFileExist filePath
if exists
then do
res <- parseFromFile sourceForPackageParser filePath
case res of
Left pe -> do
sysMessage Normal $"Error reading source packages file "
++ filePath ++ " " ++ show pe
return Nothing
Right r -> return (Just r)
else do
sysMessage Normal $"No source packages file found: " ++ filePath
return Nothing
---- Returns the package name as a string (e.g. ohohoh-0.1.0)
--parseCabal :: FilePath -> IO (Maybe String)
--parseCabal cabalPath = gcatch (do
-- gpd <- readPackageDescription silent cabalPath
-- return (Just ((display . package . packageDescription) gpd)))
-- $ \ (e :: SomeException) -> do
-- sysMessage Normal ("SourceCollector>>parseCabal:Can't parse cabal " ++ show e)
-- return Nothing
--
-- ---------------------------------------------------------------------
-- | Parser for Package DB
--
packageStyle :: P.LanguageDef st
packageStyle = emptyDef
{ P.commentStart = "{-"
, P.commentEnd = "-}"
, P.commentLine = "--"
}
lexer = P.makeTokenParser packageStyle
whiteSpace = P.whiteSpace lexer
symbol = P.symbol lexer
sourceForPackageParser :: CharParser () (Map PackageIdentifier [FilePath])
sourceForPackageParser = do
whiteSpace
ls <- many onePackageParser
whiteSpace
eof
return (Map.fromList (catMaybes ls))
<?> "sourceForPackageParser"
onePackageParser :: CharParser () (Maybe (PackageIdentifier,[FilePath]))
onePackageParser = do
mbPd <- packageDescriptionParser
filePaths <- many filePathParser
case mbPd of
Nothing -> return Nothing
Just pd -> return (Just (pd,filePaths))
<?> "onePackageParser"
packageDescriptionParser :: CharParser () (Maybe PackageIdentifier)
packageDescriptionParser = try (do
whiteSpace
str <- many (noneOf ":")
char ':'
return (toPackageIdentifier str))
<?> "packageDescriptionParser"
filePathParser :: CharParser () FilePath
filePathParser = try (do
whiteSpace
char '"'
str <- many (noneOf ['"'])
char '"'
return (str))
<?> "filePathParser"
parseCabal :: FilePath -> IO (Maybe String)
parseCabal fn = do
--putStrLn $ "Now parsing minimal " ++ fn
res <- parseFromFile cabalMinimalParser fn
case res of
Left pe -> do
sysMessage Normal $"Error reading cabal file " ++ show fn ++ " " ++ show pe
return Nothing
Right r -> do
sysMessage Normal r
return (Just r)
cabalMinimalParser :: CharParser () String
cabalMinimalParser = do
r1 <- cabalMinimalP
r2 <- cabalMinimalP
case r1 of
Left v -> do
case r2 of
Right n -> return (n ++ "-" ++ v)
Left _ -> unexpected "Illegal cabal"
Right n -> do
case r2 of
Left v -> return (n ++ "-" ++ v)
Right _ -> unexpected "Illegal cabal"
cabalMinimalP :: CharParser () (Either String String)
cabalMinimalP =
do try $(symbol "name:" <|> symbol "Name:")
whiteSpace
name <- (many $noneOf " \n")
(many $noneOf "\n")
char '\n'
return (Right name)
<|> do
try $(symbol "version:" <|> symbol "Version:")
whiteSpace
version <- (many $noneOf " \n")
(many $noneOf "\n")
char '\n'
return (Left version)
<|> do
many $noneOf "\n"
char '\n'
cabalMinimalP
<?> "cabal minimal"