leksah-0.1: src/IDE/Metainfo/SourceCollector.hs
-----------------------------------------------------------------------------
--
-- Module : IDE.Metainfo.SourceCollector
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>
-- Stability : experimental
-- Portability : portable
--
-- | This module collects information for packages with source available
--
-------------------------------------------------------------------------------
module IDE.Metainfo.SourceCollector (
collectAllSources
, 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(nub,delete,sort)
import Distribution.Simple.PreProcess.Unlit
import Distribution.Simple.PreProcess(runSimplePreProcessor,ppCpp)
import Distribution.Simple.Program(defaultProgramConfiguration)
import Distribution.Compiler(CompilerFlavor(..))
import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..))
import Distribution.Simple.Configure(configure)
import Distribution.Simple.Setup(emptyConfigFlags)
import Data.Maybe(catMaybes)
import qualified Control.Exception as C
import qualified Data.ByteString.Char8 as BS
import GHC hiding (idType)
import SrcLoc
import RdrName
import OccName
import DynFlags
import PackageConfig hiding (exposedModules)
import StringBuffer
import Bag
import ErrUtils
import FastString
import Lexer hiding (lexer)
import Parser
import Outputable hiding (char)
import HscStats
import IDE.Core.State
import IDE.Utils.File
import IDE.Preferences
-- ---------------------------------------------------------------------
-- Function to map packages to file paths
--
getSourcesMap :: IO (Map PackageIdentifier [FilePath])
getSourcesMap = do
mbSources <- parseSourceForPackageDB
case mbSources of
Just map -> do
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
let dirs = sourceDirectories prefs
cabalFiles <- mapM allCabalFiles dirs
fCabalFiles <- mapM canonicalizePath $ concat cabalFiles
packages <- mapM (\fp -> parseCabal fp) fCabalFiles
let pdToFiles = Map.fromListWith (++) (zip packages (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
-- ---------------------------------------------------------------------
-- | Parser for Package DB
--
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"
-- ---------------------------------------------------------------------
-- | Parser for the package name from a cabal file
--
cabalStyle :: P.LanguageDef st
cabalStyle = emptyDef
{ P.commentStart = "{-"
, P.commentEnd = "-}"
, P.commentLine = "--"
}
lexer = P.makeTokenParser cabalStyle
whiteSpace = P.whiteSpace lexer
symbol = P.symbol lexer
parseCabal :: FilePath -> IO String
parseCabal fn = do
putStrLn $ "Now parsing minimal " ++ fn
res <- parseFromFile cabalMinimalParser fn
case res of
Left pe -> do
putStrLn "before throw"
throwIDE $"Error reading cabal file " ++ show fn ++ " " ++ show pe
Right r -> do
sysMessage Normal r
return 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 _ -> throwIDE "Illegal cabal"
Right n -> do
case r2 of
Left v -> return (n ++ "-" ++ v)
Right _ -> throwIDE "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"
-- ---------------------------------------------------------------------
-- Functions to collect infos from the sources
--
-- ---------------------------------------------------------------------
-- | Collect infos from sources for a list of packages
--
collectAllSources :: Session
-> Map PackageIdentifier [FilePath]
-> [PackageDescr]
-> IO ([PackageDescr],Int)
collectAllSources session sourceMap pdescrs =
foldM (\ (pdescrs, failureNum) pdescr -> do
(pdescr, num) <- collectSources session sourceMap pdescr
return (pdescr:pdescrs,failureNum + num))
([],0) pdescrs
-- ---------------------------------------------------------------------
-- | Collect infos from sources for one package
--
collectSources :: Session
-> Map PackageIdentifier [FilePath]
-> PackageDescr
-> IO (PackageDescr,Int)
collectSources session sourceMap pdescr = do
putStrLn $ "Now collecting sources for " ++ show (packagePD pdescr)
case sourceForPackage (packagePD pdescr) sourceMap of
Nothing -> do
sysMessage Normal $ "No source for package " ++ showPackageId (packagePD pdescr)
return (pdescr,0)
Just cabalPath -> C.catch (do
let basePath = takeDirectory cabalPath
dflags0 <- getSessionDynFlags session
setSessionDynFlags session dflags0
{ topDir = basePath
, ghcMode = CompManager
}
dflags1 <- getSessionDynFlags session
let flags = ["-fglasgow-exts",("-I" ++ basePath </> "include"),"-haddock"]
(dflags2,_) <- parseDynamicFlags dflags1 flags
setSessionDynFlags session dflags2
genPkgDescr <- readPackageDescription silent cabalPath
let pkgDescr = flattenPackageDescription genPkgDescr
localBuildInfo <- configure (Left genPkgDescr, emptyHookedBuildInfo)
(emptyConfigFlags defaultProgramConfiguration)
--let allModules = libModules pd ++ exeModules pd
let exposedMods = exposedModulesPD pdescr
let buildPaths = nub $ ("dist" </> "build" </> "autogen") :
(concatMap hsSourceDirs $ allBuildInfo pkgDescr)
let basePath = normalise $ (takeDirectory cabalPath)
sourceFiles <- mapM (findSourceFile
(map (\p -> basePath </> p) buildPaths)
["hs","lhs"])
(map (modu . moduleIdMD) exposedMods)
(newModDescrs,failureCount)
<- foldM (collectSourcesForModule session genPkgDescr
localBuildInfo) ([],0)
(zip (exposedModulesPD pdescr) sourceFiles)
let nPackDescr = pdescr{mbSourcePathPD = Just cabalPath,
exposedModulesPD = newModDescrs}
return (nPackDescr,failureCount))
(\e -> do sysMessage Normal $ "source collector throwIDE " ++ show e ++ " in " ++
showPackageId (packagePD pdescr)
return (pdescr,length $ exposedModulesPD pdescr))
-- ---------------------------------------------------------------------
-- | Collect infos from sources for one module
--
collectSourcesForModule :: Session
-> GenericPackageDescription
-> LocalBuildInfo
-> ([ModuleDescr],Int)
-> (ModuleDescr, Maybe FilePath)
-> IO ([ModuleDescr],Int)
collectSourcesForModule session pkgDescr localBuildInfo (moduleDescrs,failureCount)
(moduleDescr,mbfp) =
case mbfp of
Nothing -> do
sysMessage Normal $ "No source for module " ++ (modu $ moduleIdMD moduleDescr)
return(moduleDescr : moduleDescrs, failureCount+1)
Just fp -> do
str <- preprocess fp pkgDescr localBuildInfo
stringBuffer <- stringToStringBuffer str
dynFlags <- getSessionDynFlags session
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 :: [IdentifierDescr] -> Map Symbol [IdentifierDescr]
convertToMap list =
foldl (\ st idDescr -> Map.insertWith (++) (identifierID idDescr) [idDescr] st)
Map.empty list
convertFromMap :: Map Symbol [IdentifierDescr] -> [IdentifierDescr]
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 declList = reverse $ snd $ foldl addComment (Nothing,[]) declList
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 :: ([IdentifierDescr],SymbolTable)
-> (Maybe (LHsDecl RdrName),Maybe String)
-> ([IdentifierDescr],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' [Function] []
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 :: ([IdentifierDescr],SymbolTable)
-> RdrName
-> SrcSpan
-> Maybe String
-> [IdType]
-> [String]
-> ([IdentifierDescr],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
Nothing -> (l,st)
Just identDescr -> (identDescr{
mbLocation = Just (srcSpanToLocation srcSpan),
mbComment = case mbComment' of
Nothing -> Nothing
Just s -> Just (BS.pack s)}
: l, nst)
where
matches :: IdentifierDescr -> [IdType] -> [String] -> Bool
matches idDescr idTypes inst =
case idType idDescr of
Instance ->
--trace ("instances " ++ show (sort (binds idDescr)) ++ " -- ?= -- " ++ show (sort inst)) $
elem Instance idTypes && sort (binds 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 (DeprecD _)= "DeprecD"
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 (DocPic _) = ""
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
--instance Show alpha => Show (HsDoc alpha) where
-- show d = printHsDoc d
---------------------------------------------------------------------
-- | Simple preprocessing
preprocess :: FilePath -> GenericPackageDescription -> LocalBuildInfo -> IO String
preprocess fp pkgDescr localBuildInfo =
let aBuildInfo = head (allBuildInfo (flattenPackageDescription pkgDescr))
needCpp = elem "-cpp" (hcOptions GHC (options aBuildInfo))
in C.catch (do
str' <- if True
then do
tempFileName <- getConfigFilePathForSave "Temp.hspp"
isItTheir <- doesFileExist tempFileName
when isItTheir $
removeFile tempFileName
-- (_, conf') <- requireProgram normal ghcProgram
-- (orLaterVersion (Version [6,2] []))
-- defaultProgramConfiguration
-- localBuildInfo' <- localBuildInfo pkgDescr conf'
runSimplePreProcessor (ppCpp aBuildInfo localBuildInfo)
fp tempFileName normal
isItTheir <- doesFileExist tempFileName
if isItTheir
then do
str <- readFile tempFileName
return str
else do
sysMessage Normal $ "Failed to preprocess " ++ fp
str <- readFile fp
return str
else do
str <- readFile fp
return str
let str2 = if takeExtension fp == ".lhs"
then unlit fp str'
else str'
return str2)
(\e -> do sysMessage Normal $ "preprocess throwIDE " ++ show e ++ " in " ++ fp
str <- readFile fp
return str)
---------------------------------------------------------------------
-- | 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 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.
}}