leksah-0.4.1: 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
) 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 Data.ByteString.Char8 as BS
import GHC hiding (idType)
import SrcLoc
import RdrName
import OccName
import DynFlags
import StringBuffer
import Bag
import ErrUtils
import FastString
import Lexer hiding (lexer)
import qualified Parser as P
import Outputable hiding (char)
import HscStats
import IDE.Core.State
import IDE.FileUtils
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.PackageDescription.Parse (readPackageDescription)
import GHC.Exception (SomeException(..))
import Distribution.Package (PackageIdentifier(..))
import Distribution.Text (display)
import DriverPipeline (preprocess)
import GHC.Show (showSpace)
-- ---------------------------------------------------------------------
-- | Collect infos from sources for one package
--
collectSources :: Map PackageIdentifier [FilePath]
-> PackageDescr
-> Ghc (PackageDescr,Int)
collectSources sourceMap pdescr = do
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
let basePath = normalise $ (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 = HscNothing,
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]
++ ["-X" ++ show e | e <- nub $ concatMap extensions bis]
-- trace ("flags " ++ show flags) $ return ()
dflags3 <- getSessionDynFlags
(dflags4,_,_) <- parseDynamicFlags dflags3 (map noLoc flags)
let dflags5 = dopt_set (dopt_set dflags4 Opt_Haddock) Opt_ReadUserPackageConf
setSessionDynFlags dflags5
let allMods = nub (exeModules pkgDescr ++ libModules pkgDescr)
let exposedMods = map (modu . moduleIdMD) (exposedModulesPD pdescr)
sourceFiles <- liftIO $ mapM (findSourceFile
buildPaths
["hs","lhs","chs","hs.pp","lhs.pp","chs.pp"])
$ nub (exposedMods ++ allMods)
(newModDescrs,failureCount)
<- foldM collectSourcesForModule ([],0)
(zip (exposedModulesPD pdescr) sourceFiles)
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 one module
--
collectSourcesForModule :: ([ModuleDescr],Int)
-> (ModuleDescr, Maybe FilePath)
-> Ghc ([ModuleDescr],Int)
collectSourcesForModule (moduleDescrs,failureCount) (moduleDescr,mbfp) =
case mbfp of
Nothing -> do
sysMessage Normal $ "No source for module " ++ (display $ modu $ moduleIdMD moduleDescr)
return(moduleDescr : moduleDescrs, failureCount+1)
Just fp -> do
session <- getSession
(_,fp) <- preprocess session (fp,Nothing)
dynFlags <- getSessionDynFlags
liftIO $ do
stringBuffer <- hGetStringBuffer fp
parseResult <- myParseModule dynFlags fp (Just stringBuffer)
let newModD = moduleDescr{mbSourcePathMD = mbfp}
case parseResult of
Right (L _ (HsModule _ _ _ decls _ _ _ )) -> do
let map' = convertToMap (idDescriptionsMD newModD)
let commentedDecls = addComments (filterSignatures decls)
let (descrs,restMap) = foldl collectParseInfoForDecl ([],map')
commentedDecls
let newModD' = newModD{
idDescriptionsMD = reverse descrs ++ concat (Map.elems restMap)}
return(newModD' : moduleDescrs, failureCount)
Left errMsg -> do
sysMessage Normal $ "Failed to parse " ++ fp
printBagOfErrors defaultDynFlags (unitBag errMsg)
return (newModD : 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 d = show (PPDoc d)
newtype PPDoc alpha = PPDoc (HsDoc alpha)
instance Show alpha => Show (PPDoc alpha) where
showsPrec _ (PPDoc DocEmpty) = id
showsPrec _ (PPDoc (DocAppend l r)) = shows (PPDoc l) . shows (PPDoc r)
showsPrec _ (PPDoc (DocString str)) = showString str
showsPrec _ (PPDoc (DocParagraph d)) = shows (PPDoc d) . showChar '\n'
showsPrec _ (PPDoc (DocIdentifier l)) = foldr (\i f -> showChar '\'' . shows i . showChar '\'') id l
showsPrec _ (PPDoc (DocModule str)) = showChar '"' . showString str . showChar '"'
showsPrec _ (PPDoc (DocEmphasis doc)) = showChar '/' . shows (PPDoc doc) . showChar '/'
showsPrec _ (PPDoc (DocMonospaced doc)) = showChar '@' . shows (PPDoc doc) . showChar '@'
showsPrec _ (PPDoc (DocUnorderedList l)) =
foldr (\s r -> showString "* " . shows (PPDoc s) . showChar '\n' . r) id l
showsPrec _ (PPDoc (DocOrderedList l)) =
foldr (\(i,n) f -> shows n . showSpace . shows (PPDoc i)) id (zip l [1 .. length l])
showsPrec _ (PPDoc (DocDefList li)) =
foldr (\(l,r) f -> showString "[@" . shows (PPDoc l) . showString "[@ " . shows (PPDoc r) . f) id li
showsPrec _ (PPDoc (DocCodeBlock doc)) = showChar '@' . shows (PPDoc doc) . showChar '@'
showsPrec _ (PPDoc (DocURL str)) = showChar '<' . showString str . showChar '>'
showsPrec _ (PPDoc (DocAName str)) = showChar '#' . showString str . showChar '#'
showsPrec _ (PPDoc _) = id
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 ()
---------------------------------------------------------------------
-- | Parser function copied here, because it is not exported
myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
-> IO (Either ErrMsg (Located (HsModule RdrName)))
myParseModule dflags src_filename maybe_src_buf
= -------------------------- Parser ----------------
showPass dflags "Parser" >>
{-# SCC "Parser" #-} do
-- sometimes we already have the buffer in memory, perhaps
-- because we needed to parse the imports out of it, or get the
-- module name.
buf <- case maybe_src_buf of
Just b -> return b
Nothing -> hGetStringBuffer src_filename
let loc = mkSrcLoc (mkFastString src_filename) 1 0
case unP P.parseModule (mkPState buf loc dflags) of {
PFailed span err -> return (Left (mkPlainErrMsg span err));
POk pst rdr_module -> do {
let {ms = getMessages pst};
printErrorsAndWarnings dflags ms;
-- when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
(ppSourceStats False rdr_module) ;
return (Right rdr_module)
-- ToDo: free the string buffer later.
}}
-- ---------------------------------------------------------------------
-- Function to map packages to file paths
--
getSourcesMap :: Prefs -> IO (Map PackageIdentifier [FilePath])
getSourcesMap prefs = do
mbSources <- parseSourceForPackageDB
case mbSources of
Just map -> return map
Nothing -> do
buildSourceForPackageDB prefs
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 :: Prefs -> IO ()
buildSourceForPackageDB prefs = do
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"