-- 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,
    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,

    LogActionCompat,
    logActionCompat,

    pprSigmaType,

    module GHC,
    module DynFlags,
    initializePlugins,
    applyPluginsParsedResultAction,
    module Compat.HieTypes,
    module Compat.HieUtils,
    dropForAll
    ,isQualifiedImport) 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 qualified SrcLoc
#else
import           Module                 (InstalledUnitId,
                                         UnitId (DefiniteUnitId),
                                         toInstalledUnitId)
import           TcType                 (pprSigmaType)
#endif
import           Compat.HieAst          (enrichHie, mkHieFile)
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 :: Bool
supportsHieFiles = Bool
True

hieExportNames :: HieFile -> [(SrcSpan, Name)]
hieExportNames :: HieFile -> [(SrcSpan, Name)]
hieExportNames = [AvailInfo] -> [(SrcSpan, Name)]
nameListFromAvails ([AvailInfo] -> [(SrcSpan, Name)])
-> (HieFile -> [AvailInfo]) -> HieFile -> [(SrcSpan, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> [AvailInfo]
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 :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
upNameCache = IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
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' :: ModSummary
-> [AvailInfo] -> HieASTs Type -> ByteString -> Hsc HieFile
mkHieFile' ModSummary
ms [AvailInfo]
exports HieASTs Type
asts ByteString
src = do
  let Just FilePath
src_file = ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath) -> ModLocation -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
ms
      (HieASTs TypeIndex
asts',Array TypeIndex HieTypeFlat
arr) = HieASTs Type -> (HieASTs TypeIndex, Array TypeIndex HieTypeFlat)
compressTypes HieASTs Type
asts
  HieFile -> Hsc HieFile
forall (m :: * -> *) a. Monad m => a -> m a
return (HieFile -> Hsc HieFile) -> HieFile -> Hsc HieFile
forall a b. (a -> b) -> a -> b
$ HieFile :: FilePath
-> Module
-> Array TypeIndex HieTypeFlat
-> HieASTs TypeIndex
-> [AvailInfo]
-> ByteString
-> HieFile
HieFile
      { hie_hs_file :: FilePath
hie_hs_file = FilePath
src_file
      , hie_module :: Module
hie_module = ModSummary -> Module
ms_mod ModSummary
ms
      , hie_types :: Array TypeIndex HieTypeFlat
hie_types = Array TypeIndex HieTypeFlat
arr
      , hie_asts :: HieASTs TypeIndex
hie_asts = HieASTs TypeIndex
asts'
      -- mkIfaceExports sorts the AvailInfos for stability
      , hie_exports :: [AvailInfo]
hie_exports = [AvailInfo] -> [AvailInfo]
mkIfaceExports [AvailInfo]
exports
      , hie_hs_src :: ByteString
hie_hs_src = ByteString
src
      }

addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags
addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags
addIncludePathsQuote FilePath
path DynFlags
x = DynFlags
x{includePaths :: IncludeSpecs
includePaths = IncludeSpecs -> IncludeSpecs
f (IncludeSpecs -> IncludeSpecs) -> IncludeSpecs -> IncludeSpecs
forall a b. (a -> b) -> a -> b
$ DynFlags -> IncludeSpecs
includePaths DynFlags
x}
    where f :: IncludeSpecs -> IncludeSpecs
f IncludeSpecs
i = IncludeSpecs
i{includePathsQuote :: [FilePath]
includePathsQuote = FilePath
path FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: IncludeSpecs -> [FilePath]
includePathsQuote IncludeSpecs
i}

pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation
#if MIN_VERSION_ghc(8,8,0)
pattern $bModLocation :: Maybe FilePath -> FilePath -> FilePath -> ModLocation
$mModLocation :: forall r.
ModLocation
-> (Maybe FilePath -> FilePath -> FilePath -> r)
-> (Void# -> r)
-> r
ModLocation a b c <-
    GHC.ModLocation a b c _ where ModLocation Maybe FilePath
a FilePath
b FilePath
c = Maybe FilePath -> FilePath -> FilePath -> FilePath -> ModLocation
GHC.ModLocation Maybe FilePath
a FilePath
b FilePath
c FilePath
""
#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 :: FilePath -> DynFlags -> DynFlags
setHieDir FilePath
_f DynFlags
d =
#if MIN_VERSION_ghc(8,8,0)
    DynFlags
d { hieDir :: Maybe FilePath
hieDir     = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
_f}
#else
    d
#endif

dontWriteHieFiles :: DynFlags -> DynFlags
dontWriteHieFiles :: DynFlags -> DynFlags
dontWriteHieFiles DynFlags
d =
#if MIN_VERSION_ghc(8,8,0)
    DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
d GeneralFlag
Opt_WriteHie
#else
    d
#endif

setUpTypedHoles ::DynFlags -> DynFlags
setUpTypedHoles :: DynFlags -> DynFlags
setUpTypedHoles DynFlags
df
  = (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_AbstractRefHoleFits    -- too spammy
#if MIN_VERSION_ghc(8,8,0)
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowDocsOfHoleFits     -- not used
#endif
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowMatchesOfHoleFits  -- nice but broken (forgets module qualifiers)
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowProvOfHoleFits     -- not used
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowTypeAppOfHoleFits  -- not used
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowTypeAppVarsOfHoleFits -- not used
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowTypeOfHoleFits     -- massively simplifies parsing
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_set   GeneralFlag
Opt_SortBySubsumHoleFits   -- very nice and fast enough in most cases
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_SortValidHoleFits
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_UnclutterValidHoleFits
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
df
  { refLevelHoleFits :: Maybe TypeIndex
refLevelHoleFits = TypeIndex -> Maybe TypeIndex
forall a. a -> Maybe a
Just TypeIndex
1   -- becomes slow at higher levels
  , maxRefHoleFits :: Maybe TypeIndex
maxRefHoleFits   = TypeIndex -> Maybe TypeIndex
forall a. a -> Maybe a
Just TypeIndex
10  -- quantity does not impact speed
  , maxValidHoleFits :: Maybe TypeIndex
maxValidHoleFits = Maybe TypeIndex
forall a. Maybe a
Nothing  -- quantity does not impact speed
  }


nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
nameListFromAvails [AvailInfo]
as =
  (Name -> (SrcSpan, Name)) -> [Name] -> [(SrcSpan, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> (Name -> SrcSpan
nameSrcSpan Name
n, Name
n)) ((AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames [AvailInfo]
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 :: a -> SrcSpan
getLoc = a -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
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 :: ModIface -> Fingerprint
getModuleHash = ModIfaceBackend -> Fingerprint
mi_mod_hash (ModIfaceBackend -> Fingerprint)
-> (ModIface -> ModIfaceBackend) -> ModIface -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> ModIfaceBackend
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
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 :: LogActionCompat -> LogAction
logActionCompat LogActionCompat
logAction DynFlags
dynFlags WarnReason
wr Severity
severity SrcSpan
loc PprStyle
style = LogActionCompat
logAction DynFlags
dynFlags WarnReason
wr Severity
severity SrcSpan
loc (PprStyle -> PrintUnqualified
Out.queryQual PprStyle
style)

type Unit = Module.UnitId
-- type PackageConfig = Packages.PackageConfig
definiteUnitId :: Module.DefUnitId -> UnitId
definiteUnitId :: DefUnitId -> UnitId
definiteUnitId = DefUnitId -> UnitId
Module.DefiniteUnitId
defUnitId :: InstalledUnitId -> Module.DefUnitId
defUnitId :: InstalledUnitId -> DefUnitId
defUnitId = InstalledUnitId -> DefUnitId
Module.DefUnitId
installedModule :: InstalledUnitId -> ModuleName -> Module.InstalledModule
installedModule :: InstalledUnitId -> ModuleName -> InstalledModule
installedModule = InstalledUnitId -> ModuleName -> InstalledModule
Module.InstalledModule
oldLookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
oldLookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
oldLookupInstalledPackage = DynFlags -> InstalledUnitId -> Maybe PackageConfig
Packages.lookupInstalledPackage
-- packageName = Packages.packageName
-- lookupPackage = Packages.lookupPackage
-- getPackageConfigMap = Packages.getPackageConfigMap
setThisInstalledUnitId :: InstalledUnitId -> DynFlags -> DynFlags
setThisInstalledUnitId :: InstalledUnitId -> DynFlags -> DynFlags
setThisInstalledUnitId InstalledUnitId
uid DynFlags
df = DynFlags
df { thisInstalledUnitId :: InstalledUnitId
thisInstalledUnitId = InstalledUnitId
uid}

lookupUnit' :: Bool -> PackageConfigMap -> p -> UnitId -> Maybe PackageConfig
lookupUnit' :: Bool -> PackageConfigMap -> p -> UnitId -> Maybe PackageConfig
lookupUnit' Bool
b PackageConfigMap
pcm p
_ = Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
Packages.lookupPackage' Bool
b PackageConfigMap
pcm
preloadClosureUs :: b -> ()
preloadClosureUs = () -> b -> ()
forall a b. a -> b -> a
const ()

oldUnhelpfulSpan :: FastString -> SrcSpan
oldUnhelpfulSpan  = FastString -> SrcSpan
UnhelpfulSpan
pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan
pattern $bOldRealSrcSpan :: RealSrcSpan -> SrcSpan
$mOldRealSrcSpan :: forall r. SrcSpan -> (RealSrcSpan -> r) -> (Void# -> r) -> r
OldRealSrcSpan x = RealSrcSpan x
{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-}

pattern NotBoot, IsBoot :: IsBootInterface
pattern $bNotBoot :: Bool
$mNotBoot :: forall r. Bool -> (Void# -> r) -> (Void# -> r) -> r
NotBoot = False
pattern $bIsBoot :: Bool
$mIsBoot :: forall r. Bool -> (Void# -> r) -> (Void# -> r) -> r
IsBoot = True

initUnits :: DynFlags -> IO DynFlags
initUnits              = ((DynFlags, [InstalledUnitId]) -> DynFlags)
-> IO (DynFlags, [InstalledUnitId]) -> IO DynFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags, [InstalledUnitId]) -> DynFlags
forall a b. (a, b) -> a
fst (IO (DynFlags, [InstalledUnitId]) -> IO DynFlags)
-> (DynFlags -> IO (DynFlags, [InstalledUnitId]))
-> DynFlags
-> IO DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> IO (DynFlags, [InstalledUnitId])
Packages.initPackages

unitDepends :: InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
unitDepends            = InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [instunitid]
depends

oldListVisibleModuleNames :: DynFlags -> [ModuleName]
oldListVisibleModuleNames = DynFlags -> [ModuleName]
Packages.listVisibleModuleNames
oldLookupModuleWithSuggestions :: DynFlags -> ModuleName -> Maybe FastString -> LookupResult
oldLookupModuleWithSuggestions = DynFlags -> ModuleName -> Maybe FastString -> LookupResult
Packages.lookupModuleWithSuggestions
-- oldLookupInPackageDB = Packages.lookupInPackageDB

oldRenderWithStyle :: DynFlags -> SDoc -> PprStyle -> FilePath
oldRenderWithStyle = DynFlags -> SDoc -> PprStyle -> FilePath
Out.renderWithStyle
oldMkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle
oldMkUserStyle = DynFlags -> PrintUnqualified -> Depth -> PprStyle
Out.mkUserStyle
oldMkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
oldMkErrStyle = DynFlags -> PrintUnqualified -> PprStyle
Out.mkErrStyle
oldFormatErrDoc :: DynFlags -> ErrDoc -> SDoc
oldFormatErrDoc = DynFlags -> ErrDoc -> SDoc
Err.formatErrDoc

-- Linear Haskell
type Scaled a = a
scaledThing :: Scaled a -> a
scaledThing :: Scaled a -> Scaled a
scaledThing = Scaled a -> Scaled a
forall a. a -> a
id
#endif

getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName
getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName
getPackageName DynFlags
dfs InstalledUnitId
i = PackageConfig -> PackageName
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> srcpkgname
packageName (PackageConfig -> PackageName)
-> Maybe PackageConfig -> Maybe PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage DynFlags
dfs (DefUnitId -> UnitId
definiteUnitId (InstalledUnitId -> DefUnitId
defUnitId InstalledUnitId
i))

disableWarningsAsErrors :: DynFlags -> DynFlags
disableWarningsAsErrors :: DynFlags -> DynFlags
disableWarningsAsErrors DynFlags
df =
    (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_WarnIsError (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> WarningFlag -> DynFlags)
-> DynFlags -> [WarningFlag] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> WarningFlag -> DynFlags
wopt_unset_fatal DynFlags
df [TypeIndex -> WarningFlag
forall a. Enum a => TypeIndex -> a
toEnum TypeIndex
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 :: HscEnv
-> DynFlags
-> ModSummary
-> ApiAnns
-> ParsedSource
-> IO ParsedSource
applyPluginsParsedResultAction HscEnv
env DynFlags
dflags ModSummary
ms ApiAnns
hpm_annotations ParsedSource
parsed = do
  -- Apply parsedResultAction of plugins
  let applyPluginAction :: Plugin -> [FilePath] -> HsParsedModule -> Hsc HsParsedModule
applyPluginAction Plugin
p [FilePath]
opts = Plugin
-> [FilePath] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction Plugin
p [FilePath]
opts ModSummary
ms
  (HsParsedModule -> ParsedSource)
-> IO HsParsedModule -> IO ParsedSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsParsedModule -> ParsedSource
hpm_module (IO HsParsedModule -> IO ParsedSource)
-> IO HsParsedModule -> IO ParsedSource
forall a b. (a -> b) -> a -> b
$
    HscEnv -> Hsc HsParsedModule -> IO HsParsedModule
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
env (Hsc HsParsedModule -> IO HsParsedModule)
-> Hsc HsParsedModule -> IO HsParsedModule
forall a b. (a -> b) -> a -> b
$ DynFlags
-> (Plugin -> [FilePath] -> HsParsedModule -> Hsc HsParsedModule)
-> HsParsedModule
-> Hsc HsParsedModule
forall (m :: * -> *) a.
Monad m =>
DynFlags -> PluginOperation m a -> a -> m a
withPlugins DynFlags
dflags Plugin -> [FilePath] -> HsParsedModule -> Hsc HsParsedModule
applyPluginAction
      (ParsedSource -> [FilePath] -> ApiAnns -> HsParsedModule
HsParsedModule ParsedSource
parsed [] ApiAnns
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 $bExposePackage :: FilePath -> PackageArg -> ModRenaming -> PackageFlag
$mExposePackage :: forall r.
PackageFlag
-> (FilePath -> PackageArg -> ModRenaming -> r)
-> (Void# -> r)
-> r
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 :: LHsType pass -> LHsType pass
dropForAll = ([LHsTyVarBndr pass], LHsType pass) -> LHsType pass
forall a b. (a, b) -> b
snd (([LHsTyVarBndr pass], LHsType pass) -> LHsType pass)
-> (LHsType pass -> ([LHsTyVarBndr pass], LHsType pass))
-> LHsType pass
-> LHsType pass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
forall pass. LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
GHC.splitLHsForAllTyInvis
#else
dropForAll = snd . GHC.splitLHsForAllTy
#endif

pattern FunTy :: Type -> Type -> Type
#if MIN_VERSION_ghc(8, 10, 0)
pattern $mFunTy :: forall r. Type -> (Type -> Type -> r) -> (Void# -> r) -> r
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 a -> Bool
isQualifiedImport ImportDecl{ideclQualified :: forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified = ImportDeclQualifiedStyle
NotQualified} = Bool
False
isQualifiedImport ImportDecl{}                              = Bool
True
#else
isQualifiedImport ImportDecl{ideclQualified}                = ideclQualified
#endif
isQualifiedImport ImportDecl a
_                                         = Bool
False



#if __GLASGOW_HASKELL__ >= 900
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 :: HieAST a -> NodeIdentifiers a
getNodeIds = NodeInfo a -> NodeIdentifiers a
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers (NodeInfo a -> NodeIdentifiers a)
-> (HieAST a -> NodeInfo a) -> HieAST a -> NodeIdentifiers a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieAST a -> NodeInfo a
forall a. HieAST a -> NodeInfo a
nodeInfo
-- import qualified FastString as FS

-- nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex
nodeInfo' :: Ord a => HieAST a -> NodeInfo a
nodeInfo' :: HieAST a -> NodeInfo a
nodeInfo' = HieAST a -> NodeInfo a
forall a. HieAST a -> NodeInfo a
nodeInfo
-- type Unit = UnitId
-- unitString :: Unit -> String
-- unitString = unitIdString
stringToUnit :: String -> Unit
stringToUnit :: FilePath -> UnitId
stringToUnit = FilePath -> UnitId
Module.stringToUnitId
-- moduleUnit :: Module -> Unit
-- moduleUnit = moduleUnitId
-- unhelpfulSpanFS :: FS.FastString -> FS.FastString
-- unhelpfulSpanFS = id
rtsUnit :: UnitId
rtsUnit = UnitId
Module.rtsUnitId
#endif

#if MIN_VERSION_ghc(9,0,0)
#else
#endif