{-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.SourceCollectorH -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Metainfo.SourceCollectorH ( -- collectPackageFromSource findSourceForPackage , packageFromSource , interfaceToModuleDescr , PackageCollectStats(..) ) where import IDE.Core.CTypes (getThisPackage, PackageDescr(..), TypeDescr(..), RealDescr(..), Descr(..), ModuleDescr(..), PackModule(..), SimpleDescr(..), packageIdentifierToString) #ifdef MIN_VERSION_haddock_leksah import Haddock.Types (ExportItem(..), DeclInfo, Interface(..)) import Haddock.Interface #else import Documentation.Haddock #endif import Distribution.Text (simpleParse) import InstEnv (Instance(..)) import MyMissing import Data.Map (Map) import qualified Data.Map as Map (empty) import Data.List (nub) import qualified Data.ByteString.Char8 as BS (pack) #if MIN_VERSION_ghc(6,12,1) import IDE.Metainfo.WorkspaceCollector (srcSpanToLocation, uncommentDecl, uncommentData, printHsDoc, sortByLoc) #else import IDE.Metainfo.WorkspaceCollector (srcSpanToLocation, uncommentDecl, uncommentData, sortByLoc) #endif import Name (getOccString,getSrcSpan) import PackageConfig (PackageConfig) import Distribution.Verbosity (verbose) import qualified Distribution.InstalledPackageInfo as IPI import IDE.StrippedPrefs (getUnpackDirectory, Prefs(..)) import IDE.Metainfo.SourceDB (sourceForPackage, getSourcesMap) import MonadUtils (liftIO) import System.Directory (setCurrentDirectory, doesDirectoryExist,createDirectory) import System.FilePath ((<.>), dropFileName, ()) import Data.Maybe(mapMaybe) import IDE.Utils.GHCUtils (inGhcIO) import qualified Control.Exception as NewException (SomeException, catch) import IDE.Utils.Tool import Control.Monad (unless) import IDE.Utils.FileUtils (figureOutGhcOpts, myCanonicalizePath) import Distribution.Package(PackageIdentifier) import GHC hiding(Id,Failed,Succeeded,ModuleName) import System.Log.Logger (warningM, debugM) import Control.DeepSeq (deepseq) import Data.ByteString.Char8 (ByteString) import Outputable hiding (trace) import GHC.Show(showSpace) #ifdef MIN_VERSION_haddock_leksah #else type HsDoc = Doc #endif type NDoc = HsDoc Name isEmptyDoc :: NDoc -> Bool isEmptyDoc DocEmpty = True isEmptyDoc _ = False show' :: Outputable alpha => alpha -> String #if MIN_VERSION_ghc(6,12,1) type MyLDocDecl = LDocDecl show' = showSDoc . ppr #else type MyLDocDecl = LDocDecl Name show' = showSDoc . ppr #endif data PackageCollectStats = PackageCollectStats { packageString :: String, modulesTotal :: Maybe Int, withSource :: Bool, retrieved :: Bool, mbError :: Maybe String} findSourceForPackage :: Prefs -> PackageConfig -> IO (Either String FilePath) findSourceForPackage prefs packageConfig = do sourceMap <- liftIO $ getSourcesMap prefs case sourceForPackage (getThisPackage packageConfig) sourceMap of Just fpSource -> return (Right fpSource) Nothing -> do unpackDir <- getUnpackDirectory prefs case unpackDir of Nothing -> return (Left "No source found. Prefs don't allow for retreiving") Just fpUnpack -> do exists <- doesDirectoryExist fpUnpack unless exists $ createDirectory fpUnpack setCurrentDirectory fpUnpack runTool' "cabal" (["unpack",packageName]) Nothing success <- doesDirectoryExist (fpUnpack packageName) if not success then return (Left "Failed to download and unpack source") else return (Right (fpUnpack packageName takeWhile (/= '-') packageName <.> "cabal")) where packageName = packageIdentifierToString (getThisPackage packageConfig) packageFromSource :: FilePath -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats) packageFromSource cabalPath packageConfig = do setCurrentDirectory dirPath ghcFlags <- figureOutGhcOpts debugM "leksah-server" ("ghcFlags: " ++ show ghcFlags) NewException.catch (inner ghcFlags) handler where _handler' (_e :: NewException.SomeException) = do debugM "leksah-server" "would block" return ([]) handler (e :: NewException.SomeException) = do warningM "leksah-server" ("Ghc failed to process: " ++ show e) return (Nothing, PackageCollectStats packageName Nothing False False (Just ("Ghc failed to process: " ++ show e))) inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ _flags -> do #if MIN_VERSION_haddock(2,8,0) (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] [] #else (interfaces,_) <- createInterfaces verbose (exportedMods ++ hiddenMods) [] [] #endif liftIO $ print (length interfaces) let mods = map (interfaceToModuleDescr dirPath (getThisPackage packageConfig)) interfaces sp <- liftIO $ myCanonicalizePath dirPath let pd = PackageDescr { pdPackage = getThisPackage packageConfig , pdModules = mods , pdBuildDepends = [] -- TODO depends packageConfig , pdMbSourcePath = Just sp} let stat = PackageCollectStats packageName (Just (length mods)) True False Nothing liftIO $ deepseq pd $ return (Just pd, stat) exportedMods = map moduleNameString $ IPI.exposedModules packageConfig hiddenMods = map moduleNameString $ IPI.hiddenModules packageConfig dirPath = dropFileName cabalPath packageName = packageIdentifierToString (getThisPackage packageConfig) -- Heaven interfaceToModuleDescr :: FilePath -> PackageIdentifier -> Interface -> ModuleDescr interfaceToModuleDescr _dirPath pid interface = ModuleDescr { mdModuleId = PM pid modName , mdMbSourcePath = Just filepath , mdReferences = imports , mdIdDescriptions = descrs} where filepath = ifaceOrigFilename interface modName = forceJust ((simpleParse . moduleNameString . moduleName . ifaceMod) interface) "Can't parse module name" descrs = extractDescrs (PM pid modName) (ifaceDeclMap interface) (ifaceExportItems interface) (ifaceInstances interface) [] --(ifaceLocals interface) imports = Map.empty --TODO #if MIN_VERSION_ghc(7,4,1) type DeclInfo = [LHsDecl Name] #endif #if MIN_VERSION_ghc(6,12,1) extractDescrs :: PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] extractDescrs pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals = transformToDescrs pm exportedDeclInfo ++ map (toDescrInst pm) ifaceInstances' where exportedDeclInfo = mapMaybe toDeclInfo ifaceExportItems' toDeclInfo (ExportDecl decl mbDoc subDocs _) = Just(decl,fst mbDoc,map (\ (a,b) -> (a,fst b)) subDocs) toDeclInfo (ExportNoDecl _ _) = Nothing toDeclInfo (ExportGroup _ _ _) = Nothing toDeclInfo (ExportDoc _) = Nothing toDeclInfo (ExportModule _) = Nothing #else extractDescrs :: PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] extractDescrs pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals = transformToDescrs pm exportedDeclInfo ++ map (toDescrInst pm) ifaceInstances' where exportedDeclInfo = mapMaybe toDeclInfo ifaceExportItems' toDeclInfo (ExportDecl decl mbDoc subDocs _) = Just(decl,mbDoc,subDocs) toDeclInfo (ExportNoDecl _ _) = Nothing toDeclInfo (ExportGroup _ _ _) = Nothing toDeclInfo (ExportDoc _) = Nothing toDeclInfo (ExportModule _) = Nothing #endif transformToDescrs :: PackModule -> [(LHsDecl Name, Maybe NDoc, [(Name, Maybe NDoc)])] -> [Descr] transformToDescrs pm = concatMap transformToDescr where #if MIN_VERSION_ghc(7,2,0) transformToDescr ((L loc (SigD (TypeSig [name] typ))), mbComment,_subCommentList) = #else transformToDescr ((L loc (SigD (TypeSig name typ))), mbComment,_subCommentList) = #endif [Real $ RealDescr { dscName' = getOccString (unLoc name) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = VariableDescr , dscExported' = True}] transformToDescr ((L _loc (SigD _)), _mbComment, _subCommentList) = [] transformToDescr ((L loc (TyClD typ@(TySynonym lid _ _ _ ))), mbComment, _subCommentList) = [Real $ RealDescr { dscName' = getOccString (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr ((L loc (TyClD typ@(TyData DataType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = DataDescr constructors fields , dscExported' = True}] ++ derivings tcdDerivs' where constructors = map extractConstructor lConDecl fields = nub $ concatMap extractRecordFields lConDecl name = getOccString (unLoc tcdLName') derivings Nothing = [] derivings (Just _l) = [] transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = NewtypeDescr constructor mbField , dscExported' = True}] ++ derivings tcdDerivs' where constructor = forceHead (map extractConstructor lConDecl) "WorkspaceCollector>>transformToDescr: no constructor for newtype" mbField = case concatMap extractRecordFields lConDecl of [] -> Nothing a:_ -> Just a name = getOccString (unLoc tcdLName') derivings Nothing = [] derivings (Just _l) = [] transformToDescr ((L loc (TyClD cl@(ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = getOccString (unLoc tcdLName') , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr cl{tcdMeths = emptyLHsBinds})) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = ClassDescr super methods , dscExported' = True }] where methods = extractMethods tcdSigs' docs super = [] transformToDescr (_, _mbComment, _sigList) = [] toDescrInst :: PackModule -> Instance -> Descr toDescrInst pm inst@(Instance is_cls' _is_tcs _is_tvs is_tys' _is_dfun _is_flag) = Real $ RealDescr { dscName' = getOccString is_cls' , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr inst)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation (getSrcSpan inst) , dscMbComment' = Nothing , dscTypeHint' = InstanceDescr (map (showSDocUnqual . ppr) is_tys') , dscExported' = True} extractMethods :: [LSig Name] -> [MyLDocDecl] -> [SimpleDescr] extractMethods sigs docs = let pairs = attachComments' sigs docs in mapMaybe extractMethod pairs extractMethod :: (LHsDecl Name, Maybe NDoc) -> Maybe SimpleDescr #if MIN_VERSION_ghc(7,2,0) extractMethod ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) = #else extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = #endif Just $ SimpleDescr (getOccString (unLoc name)) (Just (BS.pack (showSDocUnqual $ ppr ts))) (srcSpanToLocation loc) (toComment mbDoc []) True extractMethod (_, _mbDoc) = Nothing extractConstructor :: LConDecl Name -> SimpleDescr extractConstructor decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = SimpleDescr (getOccString (unLoc name)) (Just (BS.pack (showSDocUnqual $ppr (uncommentDecl decl)))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just (BS.pack (printHsDoc'' d))) True extractRecordFields :: LConDecl Name -> [SimpleDescr] extractRecordFields (L _ _decl@(ConDecl {con_details=(RecCon flds)})) = map extractRecordFields' flds where extractRecordFields' _field@(ConDeclField (L loc name) typ doc) = SimpleDescr (getOccString name) (Just (BS.pack (showSDocUnqual $ ppr typ))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just (BS.pack (printHsDoc'' d))) True extractRecordFields _ = [] toComment :: Maybe NDoc -> [NDoc] -> Maybe ByteString toComment (Just c) _ = Just (BS.pack (printHsDoc' c)) toComment Nothing (c:_) = Just (BS.pack (printHsDoc' c)) toComment Nothing [] = Nothing {-- = 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 (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment') = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] [] --} printHsDoc' :: HsDoc Name -> String printHsDoc' d = show (PPDoc d) #if MIN_VERSION_ghc(6,12,1) printHsDoc'' :: HsDocString -> String printHsDoc'' = printHsDoc #else printHsDoc'' :: HsDoc Name -> String printHsDoc'' = printHsDoc' #endif newtype PPDoc alpha = PPDoc (HsDoc alpha) instance Outputable 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 '\'' . ((showString . showSDoc . ppr) 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 attachComments' :: [LSig Name] -> [MyLDocDecl] -> [(LHsDecl Name, Maybe (HsDoc Name))] attachComments' sigs docs = collectDocs' $ sortByLoc $ ((map (\ (L l i) -> L l (SigD i)) sigs) ++ (map (\ (L l i) -> L l (DocD i)) docs)) -- | Collect the docs and attach them to the right declaration. collectDocs' :: [LHsDecl Name] -> [(LHsDecl Name, (Maybe (HsDoc Name)))] collectDocs' = collect' Nothing DocEmpty collect' :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [(LHsDecl Name, (Maybe (HsDoc Name)))] collect' d doc_so_far [] = case d of Nothing -> [] Just d0 -> finishedDoc' d0 doc_so_far [] collect' d doc_so_far (e:es) = case e of L _ (DocD (DocCommentNext str)) -> case d of Nothing -> collect' d (DocAppend doc_so_far (DocString (show' str))) es Just d0 -> finishedDoc' d0 doc_so_far (collect' Nothing (DocString (show' str)) es) L _ (DocD (DocCommentPrev str)) -> collect' d (DocAppend doc_so_far (DocString (show' str))) es _ -> case d of Nothing -> collect' (Just e) doc_so_far es Just d0 -> finishedDoc' d0 doc_so_far (collect' (Just e) DocEmpty es) finishedDoc' :: LHsDecl alpha -> NDoc -> [(LHsDecl alpha, (Maybe ((HsDoc Name))))] -> [(LHsDecl alpha, (Maybe ((HsDoc Name))))] finishedDoc' d doc rest | isEmptyDoc doc = (d, Nothing) : rest finishedDoc' d doc rest | notDocDecl d = (d, Just doc) : rest where notDocDecl (L _ (DocD _)) = False notDocDecl _ = True finishedDoc' _ _ rest = rest