{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables, PatternGuards, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.WorkspaceCollector -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Metainfo.WorkspaceCollector ( collectWorkspace , sortByLoc , attachComments , uncommentData , uncommentDecl , printHsDoc , toComment , srcSpanToLocation , sigToByteString ) where import Control.Applicative hiding(empty) import Control.Arrow ((&&&)) import Prelude import IDE.Utils.Utils import IDE.Utils.GHCUtils #if MIN_VERSION_ghc(7,10,0) import GHC hiding(Id,Failed,Succeeded,ModuleName,PackageKey) #else import GHC hiding(Id,Failed,Succeeded,ModuleName) import PackageConfig (mkPackageId) #endif #if !MIN_VERSION_ghc(7,2,0) import HscTypes hiding (liftIO) #endif #if MIN_VERSION_ghc(7,6,0) import Outputable hiding(trace, (<>)) #else import Outputable hiding(trace, (<>), showSDoc, showSDocUnqual) import qualified Outputable as O #endif import ErrUtils import qualified Data.Map as Map import Data.Map(Map) import System.Directory import Distribution.Package hiding (PackageId) import Distribution.ModuleName import System.FilePath import qualified Data.ByteString.Char8 as BS import Data.Binary.Shared import IDE.Utils.FileUtils import IDE.Core.Serializable () import IDE.Core.CTypes hiding (SrcSpan(..)) import Data.ByteString.Char8 (ByteString) import DriverPipeline (preprocess) import StringBuffer(hGetStringBuffer) import Data.List(partition,sortBy,nub,find) import Data.Ord(comparing) import GHC.Exception #if !MIN_VERSION_ghc(7,6,0) import MyMissing(forceHead) #endif import LoadIface(findAndReadIface) import Distribution.Text(display) import TcRnMonad (initTcRnIf, IfGblEnv(..)) import qualified Maybes as M import IDE.Metainfo.InterfaceCollector import Data.Maybe (isJust, catMaybes, isNothing, mapMaybe) import PrelNames import System.Log.Logger import Control.DeepSeq (deepseq) import FastString(mkFastString,appendFS,nullFS,unpackFS) import Control.Monad.IO.Class (MonadIO, MonadIO(..)) import Control.Monad (when) import Control.Exception as E import Data.Text (Text) import qualified Data.Text as T import Data.Monoid ((<>)) #if MIN_VERSION_ghc(8,2,0) import DynFlags (thisPackage) import Module (toInstalledUnitId, InstalledModule(..), UnitId(..), DefUnitId(..)) import HsImpExp (ieWrappedName) #endif #if !MIN_VERSION_ghc(8,2,0) ieWrappedName :: RdrName -> RdrName ieWrappedName = id type OutputableBndrId = OutputableBndr toInstalledUnitId :: GHC.UnitId -> GHC.UnitId toInstalledUnitId = id #endif #if !MIN_VERSION_Cabal(2,0,0) mkPackageName :: String -> PackageName mkPackageName = PackageName #endif type NDecl = LHsDecl RdrName myDocEmpty :: NDoc myDocAppend :: NDoc -> NDoc -> NDoc isEmptyDoc :: NDoc -> Bool type NDoc = HsDocString type MyLDocDecl = LDocDecl myDocEmpty=HsDocString(mkFastString "") myDocAppend (HsDocString l) (HsDocString r) = HsDocString (appendFS l r) isEmptyDoc (HsDocString fs) = nullFS fs type NSig = Located (Sig RdrName) #if !MIN_VERSION_ghc(7,6,0) showSDoc :: DynFlags -> SDoc -> Text showSDoc _ = O.showSDoc showSDocUnqual :: DynFlags -> SDoc -> Text showSDocUnqual _ = O.showSDocUnqual #endif showRdrName :: DynFlags -> RdrName -> Text showRdrName dflags r = T.pack . showSDoc dflags $ ppr r collectWorkspace :: PackageIdentifier -> [(Text,FilePath)] -> Bool -> Bool -> FilePath -> IO() collectWorkspace pid moduleList forceRebuild writeAscii dir = do debugM "leksah-server" $ "collectWorkspace called with modules " ++ show moduleList ++ " in folder " ++ dir collectorPath <- liftIO getCollectorPath let packageCollectorPath = collectorPath T.unpack (packageIdentifierToString pid) when forceRebuild $ do exists <- doesDirectoryExist packageCollectorPath when exists $ removeDirectoryRecursive packageCollectorPath -- Construct directory liftIO $ createDirectoryIfMissing True packageCollectorPath setCurrentDirectory dir opts1 <- filterOpts <$> figureOutGhcOpts dir opts2 <- figureOutHaddockOpts libDir <- getSysLibDir VERSION_ghc debugM "leksah-server" $ "before collect modules" ++ "\n\nopts1: " ++ show opts1 ++ "\n\n opt2: " ++ show opts2 mapM_ (collectModule libDir packageCollectorPath writeAscii pid opts1) moduleList debugM "leksah-server" "after collect modules" where filterOpts :: [Text] -> [Text] filterOpts [] = [] filterOpts (o:_:r) | o `elem` ["-link-js-lib", "-js-lib-outputdir", "-js-lib-src", "-package-id"] = filterOpts r filterOpts (o:r) = o:filterOpts r collectModule :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> (Text,FilePath) -> IO() collectModule libDir collectorPackagePath writeAscii pid opts (modId,sourcePath) = case parseModuleKey (T.unpack modId) sourcePath of Nothing -> errorM "leksah-server" (T.unpack $ "Can't parse module name " <> modId) Just modKey -> do let collectorModulePath = collectorPackagePath moduleCollectorFileName modKey <.> leksahMetadataWorkspaceFileExtension moduleName' = moduleKeyToName modKey existCollectorFile <- doesFileExist collectorModulePath existSourceFile <- doesFileExist sourcePath if existSourceFile then if not existCollectorFile then collectModule' libDir sourcePath collectorModulePath writeAscii pid opts moduleName' else do sourceModTime <- getModificationTime sourcePath collModTime <- getModificationTime collectorModulePath when (sourceModTime > collModTime) $ collectModule' libDir sourcePath collectorModulePath writeAscii pid opts moduleName' else errorM "leksah-server" ("source file not found " ++ sourcePath) collectModule' :: FilePath -> FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> ModuleName -> IO() collectModule' libDir sourcePath destPath writeAscii pid opts moduleName' = gcatch ( inGhcIO libDir (opts++["-cpp"]) [Opt_Haddock] [] $ \ dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0) (dynFlags3,fp') <- liftIO $ preprocess session (sourcePath,Nothing) #else (dynFlags3,fp') <- preprocess session (sourcePath,Nothing) #endif let packIdAndKey = PackageIdAndKey pid #if MIN_VERSION_ghc(7,10,0) (toInstalledUnitId $ thisPackage dynFlags3) #endif mbInterfaceDescr <- mayGetInterfaceDescription dynFlags packIdAndKey moduleName' liftIO $ do stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModule dynFlags3 sourcePath (Just stringBuffer) case parseResult of Right (L _ hsMod@HsModule{}) -> do let moduleDescr = extractModDescr dynFlags pid moduleName' sourcePath hsMod let moduleDescr' = case mbInterfaceDescr of Nothing -> moduleDescr Just md -> mergeWithInterfaceDescr moduleDescr md E.catch (writeExtractedModule destPath writeAscii moduleDescr') (\ (_:: IOException) -> errorM "leksah-server" ("Can't write extracted package " ++ destPath)) Left errMsg -> do errorM "leksah-server" $ "Failed to parse " ++ sourcePath ++ " " ++ show errMsg let moduleDescr = ModuleDescr { mdModuleId = PM pid moduleName' , mdMbSourcePath = Just sourcePath , mdReferences = Map.empty -- imports , mdIdDescriptions = [Real RealDescr { dscName' = "Parse Error" , dscMbTypeStr' = Nothing , dscMbModu' = Just (PM pid moduleName') #if MIN_VERSION_ghc(7,7,0) , dscMbLocation' = srcSpanToLocation $ errMsgSpan errMsg #else , dscMbLocation' = case errMsgSpans errMsg of (sp:_) -> srcSpanToLocation sp [] -> Nothing #endif , dscMbComment' = Just (BS.pack $ show errMsg) , dscTypeHint' = ErrorDescr , dscExported' = False}]} E.catch (deepseq moduleDescr $ writeExtractedModule destPath writeAscii moduleDescr) (\ (_:: IOException) -> errorM "leksah-server" ("Can't write extracted module " ++ destPath)) ) (\ (e :: SomeException) -> errorM "leksah-server" ("Can't extract module " ++ destPath ++ " " ++ show e)) writeExtractedModule :: MonadIO m => FilePath -> Bool -> ModuleDescr -> m () writeExtractedModule filePath writeAscii md = if writeAscii then liftIO $ writeFile (filePath ++ "dpg") (show md) else liftIO $ encodeFileSer filePath (metadataVersion, md) ----------------------------------------------------------------------------------- -- Format conversion #if MIN_VERSION_ghc(7,10,0) unLoc710 :: GenLocated l e -> e unLoc710 = unLoc #else unLoc710 :: a -> a unLoc710 = id #endif extractModDescr :: DynFlags -> PackageIdentifier -> ModuleName -> FilePath -> HsModule RdrName -> ModuleDescr extractModDescr dflags pid moduleName' sourcePath hsMod = ModuleDescr { mdModuleId = PM pid moduleName' , mdMbSourcePath = modFile $ hsmodName hsMod , mdReferences = Map.empty -- imports , mdIdDescriptions = descrs'} where descrs = extractDescrs dflags (PM pid moduleName') (hsmodDecls hsMod) descrs' = fixExports dflags (unLoc710 <$> hsmodExports hsMod) descrs modFile (Just (L loc _)) = (locationFile <$> srcSpanToLocation loc) <|> Just sourcePath modFile _ = Just sourcePath ----------------------------------------------------------------------------------- -- Add exported hint fixExports :: DynFlags -> Maybe [LIE RdrName] -> [Descr] -> [Descr] fixExports _ Nothing descrs = descrs fixExports dflags (Just iel) descrs = map (fixDescr (map unLoc iel)) descrs where fixDescr :: [IE RdrName] -> Descr -> Descr fixDescr _ d@(Reexported _) = d fixDescr list (Real rd) = Real rd' where rd' = case dscTypeHint' rd of VariableDescr -> rd{dscExported' = isJust findVar} PatternSynonymDescr -> rd{dscExported' = isJust findVar} InstanceDescr _ -> rd _ -> case findThing of Nothing -> nothingExported rd Just (IEThingAll _) -> allExported rd Just (IEThingAbs _) -> someExported rd [] #if MIN_VERSION_ghc(8,0,0) Just (IEThingWith _ _ l _) -> someExported rd (map (showRdrName dflags . ieWrappedName . unLoc710) l) #else Just (IEThingWith _ l) -> someExported rd (map (showRdrName dflags . unLoc710) l) #endif _ -> allExported rd findVar = find (\ a -> case a of IEVar r | showRdrName dflags (ieWrappedName $ unLoc710 r) == dscName' rd -> True _ -> False) list findThing = find (\ a -> case a of IEThingAbs r | showRdrName dflags (ieWrappedName $ unLoc710 r) == dscName' rd -> True IEThingAll r | showRdrName dflags (ieWrappedName $ unLoc710 r) == dscName' rd -> True #if MIN_VERSION_ghc(8,0,0) IEThingWith r _ _list _ | showRdrName dflags (ieWrappedName $ unLoc710 r) == dscName' rd -> True #else IEThingWith r _list | showRdrName dflags (unLoc710 r) == dscName' rd -> True #endif _ -> False) list allExported rd = rd nothingExported rd = rd{dscExported' = False, dscTypeHint' = nothingExportedS (dscTypeHint' rd)} nothingExportedS (DataDescr lsd1 lsd2) = DataDescr (map (setExportedSD False) lsd1) (map (setExportedSD False) lsd2) nothingExportedS (NewtypeDescr sd1 Nothing) = NewtypeDescr (setExportedSD False sd1) Nothing nothingExportedS (NewtypeDescr sd1 (Just _sd2)) = NewtypeDescr (setExportedSD False sd1) (Just (setExportedSD False sd1)) nothingExportedS (ClassDescr n lsd2) = ClassDescr n (map (setExportedSD False) lsd2) nothingExportedS other = other someExported rd l = rd{dscExported' = True, dscTypeHint' = someExportedS (dscTypeHint' rd) l} someExportedS (DataDescr lsd1 lsd2) l = DataDescr (map (maySetExportedSD l) lsd1) (map (maySetExportedSD l) lsd2) someExportedS (NewtypeDescr sd1 Nothing) l = NewtypeDescr (maySetExportedSD l sd1) Nothing someExportedS (NewtypeDescr sd1 (Just _sd2)) l = NewtypeDescr (maySetExportedSD l sd1) (Just (maySetExportedSD l sd1)) someExportedS (ClassDescr n lsd2) l = ClassDescr n (map (maySetExportedSD l) lsd2) someExportedS other _ = other setExportedSD bool sd = sd{sdExported = bool} maySetExportedSD list sd = sd{sdExported = sdName sd `elem` list} extractDescrs :: DynFlags -> PackModule -> [NDecl] -> [Descr] extractDescrs dflags pm decls = transformToDescrs dflags pm tripleWithSigs where sortedDecls = sortByLoc decls pairedWithDocs = collectDocs sortedDecls filteredDecls = filterUninteresting pairedWithDocs (withoutSignatures,signatures) = partitionSignatures filteredDecls tripleWithSigs = attachSignatures dflags signatures withoutSignatures -- | Sort by source location sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) filterUninteresting :: [(NDecl,Maybe NDoc)] -> [(NDecl,Maybe NDoc)] filterUninteresting = filter filterSignature where filterSignature (L _srcDecl (SpliceD _),_) = False filterSignature (L _srcDecl (RuleD _),_) = False filterSignature (L _srcDecl (WarningD _),_) = False filterSignature (L _srcDecl (ForD _),_) = False filterSignature (L _srcDecl (DefD _),_) = False filterSignature _ = True partitionSignatures :: [(NDecl,Maybe NDoc)] -> ([(NDecl,Maybe NDoc)],[(NDecl,Maybe NDoc)]) partitionSignatures = partition filterSignature where filterSignature (L _srcDecl (SigD _),_) = False filterSignature _ = True --partitionInstances :: [(NDecl,Maybe NDoc)] -> ([(NDecl,Maybe NDoc)],[(NDecl,Maybe NDoc)]) --partitionInstances i = (i,[]) --partition filterInstances -- where -- filterInstances ((L srcDecl (InstD _)),_) = False -- filterInstances _ = True -- | Collect the docs and attach them to the right declaration. collectDocs :: [LHsDecl RdrName] -> [(LHsDecl RdrName, Maybe NDoc)] collectDocs = collect Nothing myDocEmpty collect :: Maybe (LHsDecl RdrName) -> NDoc -> [LHsDecl RdrName] -> [(LHsDecl RdrName, Maybe NDoc)] 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 (myDocAppend doc_so_far str) es Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es) L _ (DocD (DocCommentPrev str)) -> collect d (myDocAppend doc_so_far str) es _ -> case d of Nothing -> collect (Just e) doc_so_far es Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) myDocEmpty es) finishedDoc :: LHsDecl RdrName -> NDoc -> [(LHsDecl RdrName, Maybe NDoc)] -> [(LHsDecl RdrName, Maybe NDoc)] 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 sigNameNoLoc' :: Sig name -> [name] #if MIN_VERSION_ghc(7,2,0) #if MIN_VERSION_ghc(8,0,0) sigNameNoLoc' (TypeSig ns _) = map unLoc ns #elif MIN_VERSION_ghc(7,10,0) sigNameNoLoc' (TypeSig ns _ _) = map unLoc ns #else sigNameNoLoc' (TypeSig ns _) = map unLoc ns #endif sigNameNoLoc' (SpecSig n _ _) = [unLoc n] sigNameNoLoc' (InlineSig n _) = [unLoc n] #if MIN_VERSION_ghc(7,10,0) sigNameNoLoc' (FixSig (FixitySig ns _)) = map unLoc ns #else sigNameNoLoc' (FixSig (FixitySig n _)) = [unLoc n] #endif sigNameNoLoc' _ = [] #else sigNameNoLoc' = maybeToList sigNameNoLoc #endif attachSignatures :: DynFlags -> [(NDecl, Maybe NDoc)] -> [(NDecl,Maybe NDoc)] -> [(NDecl, Maybe NDoc, [(NSig,Maybe NDoc)])] attachSignatures dflags signatures = map (attachSignature signaturesMap) where signaturesMap = Map.fromListWith (++) $ concatMap sigMap signatures sigMap :: (NDecl, Maybe NDoc) -> [(RdrName, [(NSig,Maybe NDoc)])] sigMap (L loc (SigD sig),c) | nameList <- sigNameNoLoc' sig = map (\n -> (n, [(L loc sig,c)])) nameList sigMap v = error ("Unexpected location type" ++ (showSDoc dflags . ppr) v) attachSignature :: Map RdrName [(NSig,Maybe NDoc)] -> (NDecl, Maybe NDoc) -> (NDecl, Maybe NDoc, [(NSig,Maybe NDoc)]) attachSignature signaturesMap' (decl,mbDoc) = case declName (unLoc decl) of Nothing -> (decl,mbDoc, []) Just name -> case name `Map.lookup` signaturesMap' of Just sigList -> (decl,mbDoc, sigList) Nothing -> (decl, mbDoc, []) declName _t@(TyClD x) = Just (tcdName x) declName _t@(ValD FunBind {fun_id = fun_id'}) = Just (unLoc fun_id') declName _ = Nothing transformToDescrs :: DynFlags -> PackModule -> [(NDecl, Maybe NDoc, [(NSig, Maybe NDoc)])] -> [Descr] transformToDescrs dflags pm = concatMap transformToDescr where transformToDescr :: (NDecl, Maybe NDoc, [(NSig, Maybe NDoc)]) -> [Descr] transformToDescr (L loc (ValD FunBind {fun_id = lid}), mbComment, sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = sigToByteString dflags sigList , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment (mapMaybe snd sigList) , dscTypeHint' = VariableDescr , dscExported' = True}] #if MIN_VERSION_ghc(7,8,0) #if MIN_VERSION_ghc(7,10,0) transformToDescr (L loc (ValD (PatSynBind PSB{..})), mbComment,sigList) = #else transformToDescr (L loc (ValD PatSynBind{..}), mbComment,sigList) = #endif [Real RealDescr { #if MIN_VERSION_ghc(7,10,0) dscName' = showRdrName dflags (unLoc psb_id) #else dscName' = showRdrName dflags (unLoc patsyn_id) #endif , dscMbTypeStr' = sigToByteString dflags sigList , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment (catMaybes (map snd sigList)) , dscTypeHint' = PatternSynonymDescr , dscExported' = True}] #endif #if MIN_VERSION_ghc(7,7,0) transformToDescr (L loc for@(ForD (ForeignImport lid _ _ _)), mbComment,_sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr for)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr (L loc (TyClD typ@FamDecl {tcdFam = FamilyDecl{ fdLName = lid}}), mbComment,_sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr (L loc (TyClD typ@SynDecl {tcdLName = lid}), mbComment,_sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr (L loc (TyClD typ@(DataDecl {tcdLName = lid, tcdDataDefn = HsDataDefn {dd_cons=lConDecl, dd_derivs=tcdDerivs'}})), mbComment,_sigList) = Real RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = DataDescr constructors fields , dscExported' = True} : derivings tcdDerivs' where constructors = concatMap (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl name = showRdrName dflags (unLoc lid) #if MIN_VERSION_ghc(8,2,0) derivings :: HsDeriving RdrName -> [Descr] derivings l = concatMap (extractDeriving dflags pm name) (unLoc710 l) #else derivings Nothing = [] derivings (Just l) = map (extractDeriving dflags pm name) (unLoc710 l) #endif #elif MIN_VERSION_ghc(7,6,0) transformToDescr (L loc (TyClD typ@ForeignType {tcdLName = lid}), mbComment,_sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr (L loc (TyClD typ@TyFamily {tcdLName = lid}), mbComment,_sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr (L loc (TyClD typ@TyDecl {tcdLName = lid, tcdTyDefn = TySynonym {}}), mbComment,_sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr (L loc (TyClD typ@TyDecl {tcdLName = lid, tcdTyDefn = TyData {td_cons=lConDecl, td_derivs=tcdDerivs'}}), mbComment,_sigList) = Real RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = DataDescr constructors fields , dscExported' = True} : derivings tcdDerivs' where constructors = concatMap (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl name = showRdrName dflags (unLoc lid) derivings Nothing = [] derivings (Just l) = map (extractDeriving dflags pm name) l #else transformToDescr (L loc (TyClD typ@(TySynonym lid _ _ _ )), mbComment,_sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $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,_sigList) = Real RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = DataDescr constructors fields , dscExported' = True} : derivings tcdDerivs' where constructors = map (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl name = showRdrName dflags (unLoc tcdLName') derivings Nothing = [] derivings (Just l) = map (extractDeriving dflags pm name) l transformToDescr (L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs')), mbComment,_sigList) = Real RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $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 dflags) lConDecl) "WorkspaceCollector>>transformToDescr: no constructor for newtype" mbField = case concatMap (extractRecordFields dflags) lConDecl of [] -> Nothing a:_ -> Just a name = showRdrName dflags (unLoc tcdLName') derivings Nothing = [] derivings (Just l) = map (extractDeriving dflags pm name) l #endif transformToDescr (L loc (TyClD cl@ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}), mbComment,_sigList) = [Real RealDescr { dscName' = showRdrName dflags (unLoc tcdLName') , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr cl{tcdMeths = emptyLHsBinds})) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = ClassDescr super methods , dscExported' = True }] where methods = extractMethods dflags tcdSigs' docs super = [] #if MIN_VERSION_ghc(7,7,0) transformToDescr (L loc (InstD inst), mbComment, _sigList) = let typp = case inst of ClsInstD t -> ppr t DataFamInstD t -> ppr t TyFamInstD t -> ppr t (instn,nameI,other) = case T.words . T.pack $ showSDocUnqual dflags typp of instn':nameI':tl -> (instn',nameI',takeWhile (/= "where") tl) _ -> ("","",[]) in [Real $ RealDescr { dscName' = instn <> " " <> nameI , dscMbTypeStr' = Just (BS.pack . T.unpack $ instn <> " " <> nameI <> " " <> (T.intercalate " " other)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = InstanceDescr other , dscExported' = True}] where #elif MIN_VERSION_ghc(7,6,0) transformToDescr (L loc (InstD _inst@(ClsInstD typ _ _ _)), mbComment, _sigList) = [Real RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack ("instance " ++ showSDocUnqual dflags (ppr typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = InstanceDescr other , dscExported' = True}] where (name,other) = case T.words $ T.pack (showSDocUnqual dflags $ppr typ) of [] -> ("",[]) hd:tl -> (hd,tl) #else transformToDescr (L loc (InstD _inst@(InstDecl typ _ _ _)), mbComment, _sigList) = [Real RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack ("instance " ++ showSDocUnqual dflags (ppr typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = InstanceDescr other , dscExported' = True}] where (name,other) = case T.words $ T.pack (showSDocUnqual dflags $ppr typ) of [] -> ("",[]) hd:tl -> (hd,tl) #endif transformToDescr (_, _mbComment, _sigList) = [] uncommentData :: TyClDecl a -> TyClDecl a #if MIN_VERSION_ghc(7,7,0) uncommentData td@(DataDecl {tcdDataDefn = def@(HsDataDefn{dd_cons = conDecls})}) = td{ tcdDataDefn = def{dd_cons = map uncommentDecl conDecls}} #elif MIN_VERSION_ghc(7,6,0) uncommentData td@(TyDecl {tcdTyDefn = def@(TyData{td_cons = conDecls})}) = td{ tcdTyDefn = def{td_cons = map uncommentDecl conDecls}} #else uncommentData td@TyData {tcdCons = conDecls} = td{tcdCons = map uncommentDecl conDecls} #endif uncommentData other = other uncommentDecl :: LConDecl a -> LConDecl a #if MIN_VERSION_ghc(8,0,1) uncommentDecl (L l cd@ConDeclGADT{}) = L l cd{con_doc = Nothing} uncommentDecl (L l cd@ConDeclH98{}) = L l cd{con_details= uncommentDetails (con_details cd), con_doc = Nothing} #else uncommentDecl (L l cd) = L l cd{con_details= uncommentDetails (con_details cd)} #endif uncommentDetails :: HsConDeclDetails a -> HsConDeclDetails a #if MIN_VERSION_ghc(7,10,0) uncommentDetails (RecCon (L l flds)) = RecCon (L l (map uncommentField flds)) where uncommentField (L l2 (ConDeclField a1 a2 _doc)) = L l2 (ConDeclField a1 a2 Nothing) #else uncommentDetails (RecCon flds) = RecCon (map uncommentField flds) where uncommentField (ConDeclField a1 a2 _doc) = ConDeclField a1 a2 Nothing #endif uncommentDetails other = other mergeWithInterfaceDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr mergeWithInterfaceDescr md imd = md { mdReferences = mdReferences imd, mdIdDescriptions = mergeIdDescrs (mdIdDescriptions md) (mdIdDescriptions imd)} mergeIdDescrs :: [Descr] -> [Descr] -> [Descr] mergeIdDescrs d1 d2 = dres ++ reexported where (reexported,real) = partition isReexported d2 lm = Map.fromList $ zip (map (dscName &&& dscTypeHint) real) real dres = map (addType lm) d1 addType lm' (Real d1') | isNothing (dscMbTypeStr' d1') = Real $ d1'{dscMbTypeStr' = case (dscName' d1', dscTypeHint' d1') `Map.lookup` lm' of Nothing -> Nothing Just d -> dscMbTypeStr d} addType _ d = d #if MIN_VERSION_ghc(8,2,0) extractDeriving :: OutputableBndrId alpha => DynFlags -> PackModule -> Text -> LHsDerivingClause alpha -> [Descr] extractDeriving dflags pm name (L _ HsDerivingClause {deriv_clause_tys = L _ c}) = map (extractDeriving' dflags pm name) c extractDeriving' :: OutputableBndrId alpha => DynFlags -> PackModule -> Text -> LHsSigType alpha -> Descr extractDeriving' dflags pm name (HsIB { hsib_body = (L loc typ) }) = #elif MIN_VERSION_ghc(8,0,0) extractDeriving :: OutputableBndr alpha => DynFlags -> PackModule -> Text -> LHsSigType alpha -> Descr extractDeriving dflags pm name HsIB { hsib_body = (L loc typ) } = #else extractDeriving :: OutputableBndr alpha => DynFlags -> PackModule -> Text -> LHsType alpha -> Descr extractDeriving dflags pm name (L loc typ) = #endif Real RealDescr { dscName' = className , dscMbTypeStr' = Just (BS.pack . T.unpack $ "instance " <> className <> " " <> name) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment (Nothing :: Maybe NDoc) [] , dscTypeHint' = InstanceDescr (T.words name) , dscExported' = True} where className = T.pack . showSDocUnqual dflags $ ppr typ extractMethods :: DynFlags -> [LSig RdrName] -> [MyLDocDecl] -> [SimpleDescr] extractMethods dflags sigs docs = let pairs = attachComments sigs docs in concatMap (extractMethod dflags) pairs extractMethod :: OutputableBndrId alpha => DynFlags -> (LHsDecl alpha, Maybe NDoc) -> [SimpleDescr] #if MIN_VERSION_ghc(8,0,0) extractMethod dflags (L loc (SigD ts@(TypeSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #if MIN_VERSION_ghc(8,2,0) extractMethod dflags (L loc (SigD ts@(PatSynSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #else extractMethod dflags (L loc (SigD ts@(PatSynSig name _typ)), mbDoc) = [extractMethodName dflags loc ts mbDoc name] #endif extractMethod dflags (L loc (SigD ts@(ClassOpSig _ names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #elif MIN_VERSION_ghc(7,10,0) extractMethod dflags (L loc (SigD ts@(TypeSig names _typ _)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #elif MIN_VERSION_ghc(7,2,0) extractMethod dflags (L loc (SigD ts@(TypeSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #else extractMethod dflags (L loc (SigD ts@(TypeSig name' _typ)), mbDoc) = [extractMethodName dflags loc ts mbDoc name'] #endif extractMethod _ _ = [] extractMethodName :: (Outputable o1, Outputable o2) => DynFlags -> SrcSpan -> o1 -> Maybe NDoc -> GenLocated l o2 -> SimpleDescr extractMethodName dflags loc ts mbDoc name = SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc name) (Just . BS.pack . showSDocUnqual dflags $ ppr ts) (srcSpanToLocation loc) (toComment mbDoc []) True extractConstructor :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr] #if MIN_VERSION_ghc(8,0,0) extractConstructor dflags decl@(L loc d') = extractDecl d' where extractDecl (ConDeclGADT {..}) = map (extractName con_doc) con_names extractDecl (ConDeclH98 {..}) = [extractName con_doc con_name] #elif MIN_VERSION_ghc(7,10,0) extractConstructor dflags decl@(L loc (ConDecl {con_names = names, con_doc = doc})) = map (extractName doc) names where #else extractConstructor dflags decl@(L loc ConDecl {con_name = name', con_doc = doc}) = [extractName doc name'] where #endif extractName doc name = SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc name) (Just . BS.pack . showSDocUnqual dflags . ppr $ uncommentDecl decl) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True extractRecordFields :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr] #if MIN_VERSION_ghc(8,0,0) extractRecordFields dflags (L _ _decl@ConDeclH98 {con_details = RecCon flds}) = #else extractRecordFields dflags (L _ _decl@ConDecl {con_details = RecCon flds}) = #endif concatMap extractRecordFields' (unLoc710 flds) where #if MIN_VERSION_ghc(7,10,0) extractRecordFields' :: OutputableBndrId name => LConDeclField name -> [SimpleDescr] extractRecordFields' (L _ _field@(ConDeclField names typ doc)) = map extractName names #else extractRecordFields' _field@(ConDeclField name' typ doc) = [extractName name'] #endif where extractName :: LFieldOcc name -> SimpleDescr extractName name = SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc710 name) (Just . BS.pack . showSDocUnqual dflags $ ppr typ) (srcSpanToLocation $ getLoc name) (case doc of Nothing -> Nothing Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True #if MIN_VERSION_ghc(8,0,0) extractRecordFields dflags (L _ _decl@ConDeclGADT {con_names = names, con_type = typ, con_doc = doc}) = map extractName names where extractName name = SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc710 name) (Just (BS.pack (showSDocUnqual dflags $ ppr typ))) (srcSpanToLocation $ getLoc name) (case doc of Nothing -> Nothing Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True #endif extractRecordFields _ _ = [] attachComments :: [LSig RdrName] -> [MyLDocDecl] -> [(LHsDecl RdrName, Maybe NDoc)] attachComments sigs docs = collectDocs $ sortByLoc (map (\ (L l i) -> L l (SigD i)) sigs ++ map (\ (L l i) -> L l (DocD i)) docs) sigToByteString :: DynFlags -> [(NSig, Maybe NDoc)] -> Maybe ByteString sigToByteString _ [] = Nothing sigToByteString dflags [(sig,_)] = Just (BS.pack (showSDocUnqual dflags $ppr sig)) sigToByteString dflags ((sig,_):_) = Just (BS.pack (showSDocUnqual dflags $ppr sig)) srcSpanToLocation :: SrcSpan -> Maybe Location #if MIN_VERSION_ghc(7,2,0) srcSpanToLocation (RealSrcSpan span') = Just (Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span')) srcSpanToLocation _ = Nothing #else srcSpanToLocation span' | not (isGoodSrcSpan span') = Nothing srcSpanToLocation span' = Just (Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span')) #endif toComment :: Maybe NDoc -> [NDoc] -> Maybe ByteString toComment (Just c) _ = Just . BS.pack . T.unpack $ printHsDoc c toComment Nothing (c:_) = Just . BS.pack . T.unpack $ 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 :: NDoc -> Text printHsDoc (HsDocString fs) = T.pack $ unpackFS fs --------------------------------------------------------------------------------- -- Now the interface file stuff mayGetInterfaceFile :: PackageIdAndKey -> ModuleName -> Ghc (Maybe (ModIface,FilePath)) mayGetInterfaceFile p mn = let pid = packId p #if MIN_VERSION_ghc(8,2,0) makeMod = mkModule (DefiniteUnitId (DefUnitId (packUnitId p))) makeInstMod = InstalledModule (packUnitId p) #elif MIN_VERSION_ghc(8,0,0) makeMod = mkModule (packUnitId p) #elif MIN_VERSION_ghc(7,10,0) makeMod = mkModule (packKey p) #else makeMod = mkModule (mkPackageId pid) #endif isBase = pkgName pid == mkPackageName "base" mn' = mkModuleName (display mn) iface = findAndReadIface empty #if MIN_VERSION_ghc(8,2,0) (makeInstMod mn') #endif (if isBase then mkBaseModule_ mn' else makeMod mn') False gblEnv = IfGblEnv { if_rec_types = Nothing, if_doc = empty } in do hscEnv <- getSession maybe' <- liftIO $ initTcRnIf 'i' hscEnv gblEnv () iface case maybe' of M.Succeeded val -> return (Just val) _ -> return Nothing mayGetInterfaceDescription :: DynFlags -> PackageIdAndKey -> ModuleName -> Ghc (Maybe ModuleDescr) mayGetInterfaceDescription dflags pid mn = do mbIf <- mayGetInterfaceFile pid mn case mbIf of Nothing -> do liftIO $ debugM "leksah-server" ("no interface file for " ++ show mn) return Nothing Just (mif,_) -> let allDescrs = extractExportedDescrH dflags pid mif mod' = extractExportedDescrR dflags pid allDescrs mif in do liftIO $ debugM "leksah-server" ("interface file for " ++ show mn ++ " descrs: " ++ show (length (mdIdDescriptions mod'))) return (Just mod')