-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} {-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove! -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( HieFileResult(..), HieFile(..), NameCacheUpdater(..), hieExportNames, mkHieFile', enrichHie, writeHieFile, readHieFile, supportsHieFiles, setHieDir, dontWriteHieFiles, #if !MIN_VERSION_ghc(8,8,0) ml_hie_file, addBootSuffixLocnOut, getRealSrcSpan, #endif hPutStringBuffer, addIncludePathsQuote, getModuleHash, getPackageName, setUpTypedHoles, GHC.ModLocation, Module.addBootSuffix, pattern ModLocation, pattern ExposePackage, HasSrcSpan, getLoc, upNameCache, disableWarningsAsErrors, AvailInfo, tcg_exports, pattern FunTy, #if MIN_VERSION_ghc(8,10,0) module GHC.Hs.Extension, module LinkerTypes, #else module HsExtension, noExtField, linkableTime, #endif #if MIN_VERSION_ghc(9,0,1) -- Reexports from GHC UnitId, moduleUnitId, pkgState, thisInstalledUnitId, -- Reexports from DynFlags thisPackage, writeIfaceFile, gcatch, #else RefMap, Unit, #endif -- Linear Scaled, scaledThing, lookupUnit', preloadClosureUs, -- Reexports from Package InstalledUnitId, PackageConfig, getPackageConfigMap, getPackageIncludePath, installedModule, pattern DefiniteUnitId, packageName, packageNameString, packageVersion, toInstalledUnitId, lookupPackage, -- lookupPackage', explicitPackages, exposedModules, packageConfigId, setThisInstalledUnitId, initUnits, lookupInstalledPackage, oldLookupInstalledPackage, unitDepends, haddockInterfaces, oldUnhelpfulSpan , pattern IsBoot, pattern NotBoot, pattern OldRealSrcSpan, oldRenderWithStyle, oldMkUserStyle, oldMkErrStyle, oldFormatErrDoc, oldListVisibleModuleNames, oldLookupModuleWithSuggestions, nodeInfo', getNodeIds, stringToUnit, rtsUnit, unitString, LogActionCompat, logActionCompat, pprSigmaType, module GHC, module DynFlags, initializePlugins, applyPluginsParsedResultAction, module Compat.HieTypes, module Compat.HieUtils, dropForAll, isQualifiedImport, GhcVersion(..), ghcVersion, ghcVersionStr ) where #if MIN_VERSION_ghc(8,10,0) import LinkerTypes #endif import DynFlags hiding (ExposePackage) import qualified DynFlags import qualified ErrUtils as Err import Fingerprint (Fingerprint) import qualified Module import qualified Outputable as Out import StringBuffer #if MIN_VERSION_ghc(9,0,1) import Control.Exception.Safe as Safe (Exception, MonadCatch, catch) import qualified Data.Set as S import GHC.Core.TyCo.Ppr (pprSigmaType) import GHC.Core.TyCo.Rep (Scaled, scaledThing) import GHC.Iface.Load import GHC.Types.Unique.Set (emptyUniqSet) import Module (unitString) import qualified SrcLoc #else import Module (InstalledUnitId, UnitId (DefiniteUnitId), toInstalledUnitId) import TcType (pprSigmaType) #endif import Compat.HieAst (enrichHie) import Compat.HieBin import Compat.HieTypes import Compat.HieUtils import qualified Data.ByteString as BS import Data.IORef import HscTypes import MkIface import NameCache import Packages import TcRnTypes #if MIN_VERSION_ghc(8,10,0) import GHC.Hs.Extension #else import HsExtension #endif import Avail import GHC hiding (HasSrcSpan, ModLocation, getLoc, lookupName) import qualified GHC import qualified TyCoRep #if MIN_VERSION_ghc(8,8,0) import Data.List (foldl') #else import Data.List (foldl', isSuffixOf) #endif import qualified Data.Map as M import DynamicLoading import Plugins (Plugin (parsedResultAction), withPlugins) #if !MIN_VERSION_ghc(8,8,0) import SrcLoc (RealLocated) import System.FilePath ((-<.>)) #endif #if !MIN_VERSION_ghc(8,8,0) import qualified EnumSet import Foreign.ForeignPtr import System.IO hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> hPutBuf hdl ptr len #endif #if !MIN_VERSION_ghc(8,10,0) noExtField :: NoExt noExtField = noExt #endif supportsHieFiles :: Bool supportsHieFiles = True hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports #if !MIN_VERSION_ghc(8,8,0) ml_hie_file :: GHC.ModLocation -> FilePath ml_hie_file ml | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot" | otherwise = ml_hi_file ml -<.> ".hie" #endif upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c #if !MIN_VERSION_ghc(8,8,0) upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn #else upNameCache = updNameCache #endif #if !MIN_VERSION_ghc(9,0,1) type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] #endif mkHieFile' :: ModSummary -> [AvailInfo] -> HieASTs Type -> BS.ByteString -> Hsc HieFile mkHieFile' ms exports asts src = do let Just src_file = ml_hs_file $ ms_location ms (asts',arr) = compressTypes asts return $ HieFile { hie_hs_file = src_file , hie_module = ms_mod ms , hie_types = arr , hie_asts = asts' -- mkIfaceExports sorts the AvailInfos for stability , hie_exports = mkIfaceExports exports , hie_hs_src = src } addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation #if MIN_VERSION_ghc(8,8,0) pattern ModLocation a b c <- GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" #else pattern ModLocation a b c <- GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c #endif setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = #if MIN_VERSION_ghc(8,8,0) d { hieDir = Just _f} #else d #endif dontWriteHieFiles :: DynFlags -> DynFlags dontWriteHieFiles d = #if MIN_VERSION_ghc(8,8,0) gopt_unset d Opt_WriteHie #else d #endif setUpTypedHoles ::DynFlags -> DynFlags setUpTypedHoles df = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy #if MIN_VERSION_ghc(8,8,0) $ flip gopt_unset Opt_ShowDocsOfHoleFits -- not used #endif $ flip gopt_unset Opt_ShowMatchesOfHoleFits -- nice but broken (forgets module qualifiers) $ flip gopt_unset Opt_ShowProvOfHoleFits -- not used $ flip gopt_unset Opt_ShowTypeAppOfHoleFits -- not used $ flip gopt_unset Opt_ShowTypeAppVarsOfHoleFits -- not used $ flip gopt_unset Opt_ShowTypeOfHoleFits -- massively simplifies parsing $ flip gopt_set Opt_SortBySubsumHoleFits -- very nice and fast enough in most cases $ flip gopt_unset Opt_SortValidHoleFits $ flip gopt_unset Opt_UnclutterValidHoleFits $ df { refLevelHoleFits = Just 1 -- becomes slow at higher levels , maxRefHoleFits = Just 10 -- quantity does not impact speed , maxValidHoleFits = Nothing -- quantity does not impact speed } nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as = map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) #if MIN_VERSION_ghc(9,0,0) -- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) -- type HasSrcSpan x = () :: Constraint class HasSrcSpan a where getLoc :: a -> SrcSpan instance HasSrcSpan (GenLocated SrcSpan a) where getLoc = GHC.getLoc -- getLoc :: GenLocated l a -> l -- getLoc = GHC.getLoc #elif MIN_VERSION_ghc(8,8,0) type HasSrcSpan = GHC.HasSrcSpan getLoc :: HasSrcSpan a => a -> SrcSpan getLoc = GHC.getLoc #else class HasSrcSpan a where getLoc :: a -> SrcSpan instance HasSrcSpan Name where getLoc = nameSrcSpan instance HasSrcSpan (GenLocated SrcSpan a) where getLoc = GHC.getLoc -- | Add the @-boot@ suffix to all output file paths associated with the -- module, not including the input file itself addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation addBootSuffixLocnOut locn = locn { ml_hi_file = Module.addBootSuffix (ml_hi_file locn) , ml_obj_file = Module.addBootSuffix (ml_obj_file locn) } #endif getModuleHash :: ModIface -> Fingerprint #if MIN_VERSION_ghc(8,10,0) getModuleHash = mi_mod_hash . mi_final_exts #else getModuleHash = mi_mod_hash #endif -- type PackageName = Packages.PackageName #if MIN_VERSION_ghc(9,0,0) -- NOTE: Since both the new and old version uses UnitId with different meaning, -- we try to avoid it and instead use InstalledUnitId and Unit, since it is unambiguous. type UnitId = Module.Unit type InstalledUnitId = Module.UnitId type PackageConfig = Packages.UnitInfo pattern DefiniteUnitId x = Module.RealUnit x definiteUnitId = Module.RealUnit defUnitId = Module.Definite installedModule = Module.Module -- pattern InstalledModule a b = Module.Module a b packageName = Packages.unitPackageName lookupPackage = Packages.lookupUnit . unitState -- lookupPackage' = undefined -- lookupPackage' b pm u = Packages.lookupUnit' b pm undefined u -- lookupPackage' b pm u = Packages.lookupUnit' b pm emptyUniqSet u -- TODO: Is this correct? -- lookupPackage' = fmap Packages.lookupUnit' . unitState getPackageConfigMap = Packages.unitInfoMap . unitState preloadClosureUs = Packages.preloadClosure . unitState -- getPackageConfigMap = unitState -- getPackageIncludePath = undefined getPackageIncludePath = Packages.getUnitIncludePath explicitPackages = Packages.explicitUnits pkgState = GHC.unitState packageNameString = Packages.unitPackageNameString packageVersion = Packages.unitPackageVersion -- toInstalledUnitId = id -- Module.toUnitId -- TODO: This is probably wrong toInstalledUnitId = Module.toUnitId exposedModules = Packages.unitExposedModules packageConfigId = Packages.mkUnit moduleUnitId = Module.moduleUnit lookupInstalledPackage = Packages.lookupUnitId oldLookupInstalledPackage = Packages.lookupUnitId . unitState -- initUnits = Packages.initUnits -- initPackages = initPackagesx haddockInterfaces = unitHaddockInterfaces thisInstalledUnitId = GHC.homeUnitId thisPackage = DynFlags.homeUnit setThisInstalledUnitId uid df = df { homeUnitId = uid} oldUnhelpfulSpan = UnhelpfulSpan . SrcLoc.UnhelpfulOther -- unhelpfulOther = unhelpfulOther . _ pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan pattern OldRealSrcSpan x <- RealSrcSpan x _ where OldRealSrcSpan x = RealSrcSpan x Nothing {-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} oldListVisibleModuleNames = Packages.listVisibleModuleNames . unitState oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions . unitState -- oldLookupInPackageDB = Packages.lookupInPackageDB . unitState oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc oldMkUserStyle _ = Out.mkUserStyle oldMkErrStyle _ = Out.mkErrStyle -- TODO: This is still a mess! oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext where dummySDocContext = initSDocContext dflags Out.defaultUserStyle -- oldFormatErrDoc = Err.formatErrDoc . undefined writeIfaceFile = writeIface type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO () -- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. logActionCompat :: LogActionCompat -> LogAction logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify -- We are using Safe here, which is not equivalent, but probably what we want. gcatch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a gcatch = Safe.catch #else type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO () logActionCompat :: LogActionCompat -> LogAction logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (Out.queryQual style) type Unit = Module.UnitId -- type PackageConfig = Packages.PackageConfig definiteUnitId :: Module.DefUnitId -> UnitId definiteUnitId = Module.DefiniteUnitId defUnitId :: InstalledUnitId -> Module.DefUnitId defUnitId = Module.DefUnitId installedModule :: InstalledUnitId -> ModuleName -> Module.InstalledModule installedModule = Module.InstalledModule oldLookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig oldLookupInstalledPackage = Packages.lookupInstalledPackage -- packageName = Packages.packageName -- lookupPackage = Packages.lookupPackage -- getPackageConfigMap = Packages.getPackageConfigMap setThisInstalledUnitId :: InstalledUnitId -> DynFlags -> DynFlags setThisInstalledUnitId uid df = df { thisInstalledUnitId = uid} lookupUnit' :: Bool -> PackageConfigMap -> p -> UnitId -> Maybe PackageConfig lookupUnit' b pcm _ = Packages.lookupPackage' b pcm preloadClosureUs = const () oldUnhelpfulSpan = UnhelpfulSpan pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan pattern OldRealSrcSpan x = RealSrcSpan x {-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} pattern NotBoot, IsBoot :: IsBootInterface pattern NotBoot = False pattern IsBoot = True initUnits = fmap fst . Packages.initPackages unitDepends = depends oldListVisibleModuleNames = Packages.listVisibleModuleNames oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions -- oldLookupInPackageDB = Packages.lookupInPackageDB oldRenderWithStyle = Out.renderWithStyle oldMkUserStyle = Out.mkUserStyle oldMkErrStyle = Out.mkErrStyle oldFormatErrDoc = Err.formatErrDoc -- Linear Haskell type Scaled a = a scaledThing :: Scaled a -> a scaledThing = id #endif getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName getPackageName dfs i = packageName <$> lookupPackage dfs (definiteUnitId (defUnitId i)) disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df = flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..] #if !MIN_VERSION_ghc(8,8,0) wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_unset_fatal dfs f = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } getRealSrcSpan :: RealLocated a -> RealSrcSpan getRealSrcSpan = GHC.getLoc #endif applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms fmap hpm_module $ runHsc env $ withPlugins dflags applyPluginAction (HsParsedModule parsed [] hpm_annotations) pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag -- https://github.com/facebook/fbghc #ifdef __FACEBOOK_HASKELL__ pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr #else pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif -- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body dropForAll :: LHsType pass -> LHsType pass #if MIN_VERSION_ghc(8,10,0) dropForAll = snd . GHC.splitLHsForAllTyInvis #else dropForAll = snd . GHC.splitLHsForAllTy #endif pattern FunTy :: Type -> Type -> Type #if MIN_VERSION_ghc(8,10,0) pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} #else pattern FunTy arg res <- TyCoRep.FunTy arg res #endif isQualifiedImport :: ImportDecl a -> Bool #if MIN_VERSION_ghc(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False isQualifiedImport ImportDecl{} = True #else isQualifiedImport ImportDecl{ideclQualified} = ideclQualified #endif isQualifiedImport _ = False #if MIN_VERSION_ghc(9,0,0) getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a) getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo ad `combineNodeIds` (NodeInfo _ _ bd) = M.unionWith (<>) ad bd -- Copied from GHC and adjusted to accept TypeIndex instead of Type -- nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex nodeInfo' = M.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a (NodeInfo as ai ad) `combineNodeInfo'` (NodeInfo bs bi bd) = NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) where mergeSorted :: Ord a => [a] -> [a] -> [a] mergeSorted la@(a:as) lb@(b:bs) = case compare a b of LT -> a : mergeSorted as lb EQ -> a : mergeSorted as bs GT -> b : mergeSorted la bs mergeSorted as [] = as mergeSorted [] bs = bs stringToUnit = Module.stringToUnit rtsUnit = Module.rtsUnit #else getNodeIds = nodeIdentifiers . nodeInfo -- import qualified FastString as FS -- nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' = nodeInfo -- type Unit = UnitId unitString :: Unit -> String unitString = Module.unitIdString stringToUnit :: String -> Unit stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit -- moduleUnit = moduleUnitId -- unhelpfulSpanFS :: FS.FastString -> FS.FastString -- unhelpfulSpanFS = id rtsUnit = Module.rtsUnitId #endif data GhcVersion = GHC86 | GHC88 | GHC810 | GHC90 deriving (Eq, Ord, Show) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion #if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) ghcVersion = GHC90 #elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) ghcVersion = GHC810 #elif MIN_VERSION_GLASGOW_HASKELL(8,8,0,0) ghcVersion = GHC88 #elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0) ghcVersion = GHC86 #endif