-- 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-incomplete-uni-patterns -Wno-dodgy-imports #-}

-- | Attempt at hiding the GHC version differences we can.
module Development.IDE.GHC.Compat(
    mkHomeModLocation,
    hPutStringBuffer,
    addIncludePathsQuote,
    getModuleHash,
    setUpTypedHoles,
    NameCacheUpdater(..),
#if MIN_VERSION_ghc(9,3,0)
    getMessages,
    renderDiagnosticMessageWithHints,
    nameEnvElts,
#else
    upNameCache,
#endif
    lookupNameCache,
    disableWarningsAsErrors,
    reLoc,
    reLocA,
    getPsMessages,
    renderMessages,
    pattern PFailedWithErrorMessages,
    isObjectLinkable,

#if !MIN_VERSION_ghc(9,3,0)
    extendModSummaryNoDeps,
    emsModSummary,
#endif
    myCoreToStgExpr,

    Usage(..),

    liftZonkM,

    FastStringCompat,
    bytesFS,
    mkFastStringByteString,
    nodeInfo',
    getNodeIds,
    sourceNodeInfo,
    generatedNodeInfo,
    simpleNodeInfoCompat,
    isAnnotationInNodeInfo,
    nodeAnnotations,
    mkAstNode,
    combineRealSrcSpans,

    nonDetOccEnvElts,
    nonDetFoldOccEnv,

    isQualifiedImport,
    GhcVersion(..),
    ghcVersion,
    ghcVersionStr,
    -- * HIE Compat
    HieFileResult(..),
    HieFile(..),
    hieExportNames,
    mkHieFile',
    enrichHie,
    writeHieFile,
    readHieFile,
    setHieDir,
    dontWriteHieFiles,
    module Compat.HieTypes,
    module Compat.HieUtils,
    -- * Compat modules
    module Development.IDE.GHC.Compat.Core,
    module Development.IDE.GHC.Compat.Env,
    module Development.IDE.GHC.Compat.Iface,
    module Development.IDE.GHC.Compat.Logger,
    module Development.IDE.GHC.Compat.Outputable,
    module Development.IDE.GHC.Compat.Parser,
    module Development.IDE.GHC.Compat.Plugins,
    module Development.IDE.GHC.Compat.Units,
    -- * Extras that rely on compat modules
    -- * SysTools
    Option (..),
    runUnlit,
    runPp,

    -- * Recompilation avoidance
    hscCompileCoreExprHook,
    CoreExpr,
    simplifyExpr,
    tidyExpr,
    emptyTidyEnv,
    tcInitTidyEnv,
    corePrepExpr,
    corePrepPgm,
    lintInteractiveExpr,
    icInteractiveModule,
    HomePackageTable,
    lookupHpt,
    loadModulesHome,
#if MIN_VERSION_ghc(9,3,0)
    Dependencies(dep_direct_mods),
#else
    Dependencies(dep_mods),
#endif
    bcoFreeNames,
    ModIfaceAnnotation,
    pattern Annotation,
    AnnTarget(ModuleTarget),
    extendAnnEnvList,
    module UniqDSet,
    module UniqSet,
    module UniqDFM,
    getDependentMods,
    flattenBinds,
    mkRnEnv2,
    emptyInScopeSet,
    Unfolding(..),
    noUnfolding,
    loadExpr,
    byteCodeGen,
    bc_bcos,
    loadDecls,
    hscInterp,
    expectJust,
    extract_cons,
    recDotDot,
#if MIN_VERSION_ghc(9,5,0)
    XModulePs(..),
#endif
    ) where

import           Prelude                               hiding (mod)
import           Development.IDE.GHC.Compat.Core hiding (moduleUnitId)
import           Development.IDE.GHC.Compat.Env
import           Development.IDE.GHC.Compat.Iface
import           Development.IDE.GHC.Compat.Logger
import           Development.IDE.GHC.Compat.Outputable
import           Development.IDE.GHC.Compat.Parser
import           Development.IDE.GHC.Compat.Plugins
import           Development.IDE.GHC.Compat.Units
import           Development.IDE.GHC.Compat.Util
import           GHC                                   hiding (HasSrcSpan,
                                                        ModLocation,
                                                        RealSrcSpan, exprType,
                                                        getLoc, lookupName)
import           Data.Coerce                           (coerce)
import           Data.String                           (IsString (fromString))
import           Compat.HieAst                         (enrichHie)
import           Compat.HieBin
import           Compat.HieTypes                       hiding (nodeAnnotations)
import qualified Compat.HieTypes                       as GHC (nodeAnnotations)
import           Compat.HieUtils
import qualified Data.ByteString                       as BS
import           Data.List                             (foldl')
import qualified Data.Map                              as Map
import qualified Data.Set                              as S

-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]

#if MIN_VERSION_ghc(9,7,0)
import           GHC.Tc.Zonk.TcType                    (tcInitTidyEnv)
#endif
import qualified GHC.Core.Opt.Pipeline                 as GHC
import           GHC.Core.Tidy                         (tidyExpr)
import           GHC.CoreToStg.Prep                    (corePrepPgm)
import qualified GHC.CoreToStg.Prep                    as GHC
import           GHC.Driver.Hooks                      (hscCompileCoreExprHook)

import           GHC.ByteCode.Asm                      (bcoFreeNames)
import           GHC.Types.Annotations                 (AnnTarget (ModuleTarget),
                                                        Annotation (..),
                                                        extendAnnEnvList)
import           GHC.Types.Unique.DFM                  as UniqDFM
import           GHC.Types.Unique.DSet                 as UniqDSet
import           GHC.Types.Unique.Set                  as UniqSet
import           GHC.Data.FastString
import           GHC.Core
import           GHC.Data.StringBuffer
import           GHC.Driver.Session                    hiding (ExposePackage)
import           GHC.Types.Var.Env
import           GHC.Iface.Make                        (mkIfaceExports)
import           GHC.SysTools.Tasks                    (runUnlit, runPp)
import qualified GHC.Types.Avail                       as Avail


#if !MIN_VERSION_ghc(9,5,0)
import           GHC.Core.Lint                         (lintInteractiveExpr)
#endif


import           GHC.Iface.Env
import           GHC.Types.SrcLoc                      (combineRealSrcSpans)
import           GHC.Linker.Loader                     (loadExpr)
import           GHC.Runtime.Context                   (icInteractiveModule)
import           GHC.Unit.Home.ModInfo                 (HomePackageTable,
                                                        lookupHpt)
import           GHC.Driver.Env                        as Env
import           GHC.Unit.Module.ModIface
import           GHC.Builtin.Uniques
import           GHC.ByteCode.Types
import           GHC.CoreToStg
import           GHC.Data.Maybe
import           GHC.Linker.Loader                     (loadDecls)
import           GHC.Stg.Pipeline
import           GHC.Stg.Syntax
import           GHC.StgToByteCode
import           GHC.Types.CostCentre
import           GHC.Types.IPE

#if !MIN_VERSION_ghc(9,3,0)
import           GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..))
import           GHC.Linker.Types                      (isObjectLinkable)
import           GHC.Unit.Module.ModSummary
import           GHC.Runtime.Interpreter
#endif

#if !MIN_VERSION_ghc(9,3,0)
import           Data.IORef
#endif

#if MIN_VERSION_ghc(9,3,0)
import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..))
import GHC.Driver.Config.Stg.Pipeline
#endif

#if MIN_VERSION_ghc(9,5,0)
import           GHC.Core.Lint.Interactive                           (interactiveInScope)
import           GHC.Driver.Config.Core.Lint.Interactive             (lintInteractiveExpr)
import           GHC.Driver.Config.Core.Opt.Simplify                 (initSimplifyExprOpts)
import           GHC.Driver.Config.CoreToStg                         (initCoreToStgOpts)
import           GHC.Driver.Config.CoreToStg.Prep                    (initCorePrepConfig)
#endif

#if !MIN_VERSION_ghc(9,7,0)
liftZonkM :: a -> a
liftZonkM :: forall a. a -> a
liftZonkM = forall a. a -> a
id
#endif

#if !MIN_VERSION_ghc(9,7,0)
nonDetFoldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b
nonDetFoldOccEnv :: forall a b. (a -> b -> b) -> b -> OccEnv a -> b
nonDetFoldOccEnv = forall a b. (a -> b -> b) -> b -> OccEnv a -> b
foldOccEnv
#endif

#if !MIN_VERSION_ghc(9,3,0)
nonDetOccEnvElts :: OccEnv a -> [a]
nonDetOccEnvElts :: forall a. OccEnv a -> [a]
nonDetOccEnvElts = forall a. OccEnv a -> [a]
occEnvElts
#endif

type ModIfaceAnnotation = Annotation

#if MIN_VERSION_ghc(9,3,0)
nameEnvElts :: NameEnv a -> [a]
nameEnvElts = nonDetNameEnvElts
#endif

myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
#if MIN_VERSION_ghc(9,3,0)
            -> Bool
#endif
                -> Module -> ModLocation -> CoreExpr
                -> IO ( Id
#if MIN_VERSION_ghc(9,3,0)
                      ,[CgStgTopBinding] -- output program
#else
                      ,[StgTopBinding] -- output program
#endif
                      , InfoTableProvMap
                      , CollectedCCs )
myCoreToStgExpr :: Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreExpr
-> IO (Id, [StgTopBinding], InfoTableProvMap, CollectedCCs)
myCoreToStgExpr Logger
logger DynFlags
dflags InteractiveContext
ictxt
#if MIN_VERSION_ghc(9,3,0)
                for_bytecode
#endif
                Module
this_mod ModLocation
ml CoreExpr
prepd_expr = do
    {- Create a temporary binding (just because myCoreToStg needs a
       binding for the stg2stg step) -}
    let bco_tmp_id :: Id
bco_tmp_id = FastString -> Unique -> Mult -> Mult -> Id
mkSysLocal (String -> FastString
fsLit String
"BCO_toplevel")
                                (TypeIndex -> Unique
mkPseudoUniqueE TypeIndex
0)
#if MIN_VERSION_ghc(9,5,0)
                                ManyTy
#else
                                Mult
Many
#endif
                                (CoreExpr -> Mult
exprType CoreExpr
prepd_expr)
    ([StgTopBinding]
stg_binds, InfoTableProvMap
prov_map, CollectedCCs
collected_ccs) <-
       Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO ([StgTopBinding], InfoTableProvMap, CollectedCCs)
myCoreToStg Logger
logger
                   DynFlags
dflags
                   InteractiveContext
ictxt
#if MIN_VERSION_ghc(9,3,0)
                   for_bytecode
#endif
                   Module
this_mod
                   ModLocation
ml
                   [forall b. b -> Expr b -> Bind b
NonRec Id
bco_tmp_id CoreExpr
prepd_expr]
    forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bco_tmp_id, [StgTopBinding]
stg_binds, InfoTableProvMap
prov_map, CollectedCCs
collected_ccs)

myCoreToStg :: Logger -> DynFlags -> InteractiveContext
#if MIN_VERSION_ghc(9,3,0)
            -> Bool
#endif
            -> Module -> ModLocation -> CoreProgram
#if MIN_VERSION_ghc(9,3,0)
            -> IO ( [CgStgTopBinding] -- output program
#else
            -> IO ( [StgTopBinding] -- output program
#endif
                  , InfoTableProvMap
                  , CollectedCCs )  -- CAF cost centre info (declared and used)
myCoreToStg :: Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO ([StgTopBinding], InfoTableProvMap, CollectedCCs)
myCoreToStg Logger
logger DynFlags
dflags InteractiveContext
ictxt
#if MIN_VERSION_ghc(9,3,0)
            for_bytecode
#endif
            Module
this_mod ModLocation
ml CoreProgram
prepd_binds = do
    let ([StgTopBinding]
stg_binds, InfoTableProvMap
denv, CollectedCCs
cost_centre_info)
         = {-# SCC "Core2Stg" #-}
           DynFlags
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg
#if MIN_VERSION_ghc(9,5,0)
             (initCoreToStgOpts dflags)
#else
             DynFlags
dflags
#endif
             Module
this_mod ModLocation
ml CoreProgram
prepd_binds

#if MIN_VERSION_ghc(9,8,0)
    (unzip -> (stg_binds2,_),_)
#elif MIN_VERSION_ghc(9,4,2)
    (stg_binds2,_)
#else
    [StgTopBinding]
stg_binds2
#endif
        <- {-# SCC "Stg2Stg" #-}
#if MIN_VERSION_ghc(9,3,0)
           stg2stg logger
#if MIN_VERSION_ghc(9,5,0)
                   (interactiveInScope ictxt)
#else
                   ictxt
#endif
                   (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds
#else
           Logger
-> DynFlags
-> InteractiveContext
-> Module
-> [StgTopBinding]
-> IO [StgTopBinding]
stg2stg Logger
logger DynFlags
dflags InteractiveContext
ictxt Module
this_mod [StgTopBinding]
stg_binds
#endif

    forall (m :: * -> *) a. Monad m => a -> m a
return ([StgTopBinding]
stg_binds2, InfoTableProvMap
denv, CollectedCCs
cost_centre_info)



getDependentMods :: ModIface -> [ModuleName]
#if MIN_VERSION_ghc(9,3,0)
getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps
#else
getDependentMods :: ModIface -> [ModuleName]
getDependentMods = forall a b. (a -> b) -> [a] -> [b]
map forall mod. GenWithIsBoot mod -> mod
gwib_mod forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [GenWithIsBoot ModuleName]
dep_mods forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps
#endif

simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
#if MIN_VERSION_ghc(9,5,0)
simplifyExpr _ env = GHC.simplifyExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) (ue_eps (Development.IDE.GHC.Compat.Env.hsc_unit_env env)) (initSimplifyExprOpts (hsc_dflags env) (hsc_IC env))
#else
simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
simplifyExpr DynFlags
_ = HscEnv -> CoreExpr -> IO CoreExpr
GHC.simplifyExpr
#endif

corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
#if MIN_VERSION_ghc(9,5,0)
corePrepExpr _ env expr = do
  cfg <- initCorePrepConfig env
  GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg expr
#else
corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr DynFlags
_ = HscEnv -> CoreExpr -> IO CoreExpr
GHC.corePrepExpr
#endif

renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg)
renderMessages :: PsMessages -> PsMessages
renderMessages PsMessages
msgs =
#if MIN_VERSION_ghc(9,3,0)
  let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs
  in (renderMsgs psWarnings, renderMsgs psErrors)
#else
  PsMessages
msgs
#endif

pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a
pattern $mPFailedWithErrorMessages :: forall {r} {a} {b}.
ParseResult a
-> ((b -> Bag (MsgEnvelope DecoratedSDoc)) -> r)
-> ((# #) -> r)
-> r
PFailedWithErrorMessages msgs
#if MIN_VERSION_ghc(9,3,0)
     <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs)
#else
     <- PFailed (const . fmap pprError . getErrorMessages -> msgs)
#endif
{-# COMPLETE POk, PFailedWithErrorMessages #-}

hieExportNames :: HieFile -> [(SrcSpan, Name)]
hieExportNames :: HieFile -> [(SrcSpan, Name)]
hieExportNames = [AvailInfo] -> [(SrcSpan, Name)]
nameListFromAvails forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> [AvailInfo]
hie_exports

#if MIN_VERSION_ghc(9,3,0)
type NameCacheUpdater = NameCache
#else

lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
-- Lookup up the (Module,OccName) in the NameCache
-- If you find it, return it; if not, allocate a fresh original name and extend
-- the NameCache.
-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
-- If we need to explore its value we will load Foo.hi; but meanwhile all we
-- need is a Name for it.
lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
lookupNameCache Module
mod OccName
occ NameCache
name_cache =
  case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache (NameCache -> OrigNameCache
nsNames NameCache
name_cache) Module
mod OccName
occ of {
    Just Name
name -> (NameCache
name_cache, Name
name);
    Maybe Name
Nothing   ->
        case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
name_cache) of {
          (Unique
uniq, UniqSupply
us) ->
              let
                name :: Name
name      = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
noSrcSpan
                new_cache :: OrigNameCache
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache (NameCache -> OrigNameCache
nsNames NameCache
name_cache) Module
mod OccName
occ Name
name
              in (NameCache
name_cache{ nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us, nsNames :: OrigNameCache
nsNames = OrigNameCache
new_cache }, Name
name) }}

upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
upNameCache :: forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
upNameCache = forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
updNameCache
#endif

mkHieFile' :: ModSummary
           -> [Avail.AvailInfo]
           -> HieASTs Type
           -> BS.ByteString
           -> Hsc HieFile
mkHieFile' :: ModSummary
-> [AvailInfo] -> HieASTs Mult -> ByteString -> Hsc HieFile
mkHieFile' ModSummary
ms [AvailInfo]
exports HieASTs Mult
asts ByteString
src = do
  let Just String
src_file = ModLocation -> Maybe String
ml_hs_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
ms
      (HieASTs TypeIndex
asts',Array TypeIndex HieTypeFlat
arr) = HieASTs Mult -> (HieASTs TypeIndex, Array TypeIndex HieTypeFlat)
compressTypes HieASTs Mult
asts
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HieFile
      { hie_hs_file :: String
hie_hs_file = String
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 :: String -> DynFlags -> DynFlags
addIncludePathsQuote String
path DynFlags
x = DynFlags
x{includePaths :: IncludeSpecs
includePaths = IncludeSpecs -> IncludeSpecs
f forall a b. (a -> b) -> a -> b
$ DynFlags -> IncludeSpecs
includePaths DynFlags
x}
    where f :: IncludeSpecs -> IncludeSpecs
f IncludeSpecs
i = IncludeSpecs
i{includePathsQuote :: [String]
includePathsQuote = String
path forall a. a -> [a] -> [a]
: IncludeSpecs -> [String]
includePathsQuote IncludeSpecs
i}

setHieDir :: FilePath -> DynFlags -> DynFlags
setHieDir :: String -> DynFlags -> DynFlags
setHieDir String
_f DynFlags
d = DynFlags
d { hieDir :: Maybe String
hieDir = forall a. a -> Maybe a
Just String
_f}

dontWriteHieFiles :: DynFlags -> DynFlags
dontWriteHieFiles :: DynFlags -> DynFlags
dontWriteHieFiles DynFlags
d = DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
d GeneralFlag
Opt_WriteHie

setUpTypedHoles ::DynFlags -> DynFlags
setUpTypedHoles :: DynFlags -> DynFlags
setUpTypedHoles DynFlags
df
  = forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_AbstractRefHoleFits    -- too spammy
  forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowDocsOfHoleFits     -- not used
  forall a b. (a -> b) -> a -> b
$ 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)
  forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowProvOfHoleFits     -- not used
  forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowTypeAppOfHoleFits  -- not used
  forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowTypeAppVarsOfHoleFits -- not used
  forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_ShowTypeOfHoleFits     -- massively simplifies parsing
  forall a b. (a -> b) -> a -> b
$ 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
  forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_SortValidHoleFits
  forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_UnclutterValidHoleFits
  forall a b. (a -> b) -> a -> b
$ DynFlags
df
  { refLevelHoleFits :: Maybe TypeIndex
refLevelHoleFits = forall a. a -> Maybe a
Just TypeIndex
1   -- becomes slow at higher levels
  , maxRefHoleFits :: Maybe TypeIndex
maxRefHoleFits   = forall a. a -> Maybe a
Just TypeIndex
10  -- quantity does not impact speed
  , maxValidHoleFits :: Maybe TypeIndex
maxValidHoleFits = forall a. Maybe a
Nothing  -- quantity does not impact speed
  }


nameListFromAvails :: [Avail.AvailInfo] -> [(SrcSpan, Name)]
nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
nameListFromAvails [AvailInfo]
as =
  forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> (Name -> SrcSpan
nameSrcSpan Name
n, Name
n)) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
Avail.availNames [AvailInfo]
as)


getModuleHash :: ModIface -> Fingerprint
getModuleHash :: ModIface -> Fingerprint
getModuleHash = ModIfaceBackend -> Fingerprint
mi_mod_hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts


disableWarningsAsErrors :: DynFlags -> DynFlags
disableWarningsAsErrors :: DynFlags -> DynFlags
disableWarningsAsErrors DynFlags
df =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_WarnIsError forall a b. (a -> b) -> a -> b
$! forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> WarningFlag -> DynFlags
wopt_unset_fatal DynFlags
df [forall a. Enum a => TypeIndex -> a
toEnum TypeIndex
0 ..]

isQualifiedImport :: ImportDecl a -> Bool
isQualifiedImport :: forall a. ImportDecl a -> Bool
isQualifiedImport ImportDecl{ideclQualified :: forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified = ImportDeclQualifiedStyle
NotQualified} = Bool
False
isQualifiedImport ImportDecl{}                              = Bool
True
isQualifiedImport ImportDecl a
_                                         = Bool
False



getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a)
getNodeIds :: forall a. HieAST a -> Map Identifier (IdentifierDetails a)
getNodeIds = forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' forall a.
Map Identifier (IdentifierDetails a)
-> NodeInfo a -> Map Identifier (IdentifierDetails a)
combineNodeIds forall k a. Map k a
Map.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo

combineNodeIds :: Map.Map Identifier (IdentifierDetails a)
                        -> NodeInfo a -> Map.Map Identifier (IdentifierDetails a)
Map Identifier (IdentifierDetails a)
ad combineNodeIds :: forall a.
Map Identifier (IdentifierDetails a)
-> NodeInfo a -> Map Identifier (IdentifierDetails a)
`combineNodeIds` (NodeInfo Set NodeAnnotation
_ [a]
_ Map Identifier (IdentifierDetails a)
bd) = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) Map Identifier (IdentifierDetails a)
ad Map Identifier (IdentifierDetails a)
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' :: HieAST TypeIndex -> NodeInfo TypeIndex
nodeInfo' = forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' forall a. Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a
combineNodeInfo' forall a. NodeInfo a
emptyNodeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo

combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a
(NodeInfo Set NodeAnnotation
as [a]
ai NodeIdentifiers a
ad) combineNodeInfo' :: forall a. Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a
`combineNodeInfo'` (NodeInfo Set NodeAnnotation
bs [a]
bi NodeIdentifiers a
bd) =
  forall a.
Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a
NodeInfo (forall a. Ord a => Set a -> Set a -> Set a
S.union Set NodeAnnotation
as Set NodeAnnotation
bs) (forall a. Ord a => [a] -> [a] -> [a]
mergeSorted [a]
ai [a]
bi) (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) NodeIdentifiers a
ad NodeIdentifiers a
bd)
  where
    mergeSorted :: Ord a => [a] -> [a] -> [a]
    mergeSorted :: forall a. Ord a => [a] -> [a] -> [a]
mergeSorted la :: [a]
la@(a
a:[a]
axs) lb :: [a]
lb@(a
b:[a]
bxs) = case forall a. Ord a => a -> a -> Ordering
compare a
a a
b of
                                        Ordering
LT -> a
a forall a. a -> [a] -> [a]
: forall a. Ord a => [a] -> [a] -> [a]
mergeSorted [a]
axs [a]
lb
                                        Ordering
EQ -> a
a forall a. a -> [a] -> [a]
: forall a. Ord a => [a] -> [a] -> [a]
mergeSorted [a]
axs [a]
bxs
                                        Ordering
GT -> a
b forall a. a -> [a] -> [a]
: forall a. Ord a => [a] -> [a] -> [a]
mergeSorted [a]
la [a]
bxs
    mergeSorted [a]
axs [] = [a]
axs
    mergeSorted [] [a]
bxs = [a]
bxs

sourceNodeInfo :: HieAST a -> Maybe (NodeInfo a)
sourceNodeInfo :: forall a. HieAST a -> Maybe (NodeInfo a)
sourceNodeInfo = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeOrigin
SourceInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo

generatedNodeInfo :: HieAST a -> Maybe (NodeInfo a)
generatedNodeInfo :: forall a. HieAST a -> Maybe (NodeInfo a)
generatedNodeInfo = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeOrigin
GeneratedInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo

data GhcVersion
  = GHC810
  | GHC90
  | GHC92
  | GHC94
  | GHC96
  | GHC98
  deriving (GhcVersion -> GhcVersion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GhcVersion -> GhcVersion -> Bool
$c/= :: GhcVersion -> GhcVersion -> Bool
== :: GhcVersion -> GhcVersion -> Bool
$c== :: GhcVersion -> GhcVersion -> Bool
Eq, Eq GhcVersion
GhcVersion -> GhcVersion -> Bool
GhcVersion -> GhcVersion -> Ordering
GhcVersion -> GhcVersion -> GhcVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GhcVersion -> GhcVersion -> GhcVersion
$cmin :: GhcVersion -> GhcVersion -> GhcVersion
max :: GhcVersion -> GhcVersion -> GhcVersion
$cmax :: GhcVersion -> GhcVersion -> GhcVersion
>= :: GhcVersion -> GhcVersion -> Bool
$c>= :: GhcVersion -> GhcVersion -> Bool
> :: GhcVersion -> GhcVersion -> Bool
$c> :: GhcVersion -> GhcVersion -> Bool
<= :: GhcVersion -> GhcVersion -> Bool
$c<= :: GhcVersion -> GhcVersion -> Bool
< :: GhcVersion -> GhcVersion -> Bool
$c< :: GhcVersion -> GhcVersion -> Bool
compare :: GhcVersion -> GhcVersion -> Ordering
$ccompare :: GhcVersion -> GhcVersion -> Ordering
Ord, TypeIndex -> GhcVersion -> ShowS
[GhcVersion] -> ShowS
GhcVersion -> String
forall a.
(TypeIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhcVersion] -> ShowS
$cshowList :: [GhcVersion] -> ShowS
show :: GhcVersion -> String
$cshow :: GhcVersion -> String
showsPrec :: TypeIndex -> GhcVersion -> ShowS
$cshowsPrec :: TypeIndex -> GhcVersion -> ShowS
Show)

ghcVersionStr :: String
ghcVersionStr :: String
ghcVersionStr = VERSION_ghc

ghcVersion :: GhcVersion
#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0)
ghcVersion = GHC98
#elif MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
ghcVersion = GHC96
#elif MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
ghcVersion = GHC94
#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
ghcVersion :: GhcVersion
ghcVersion = GhcVersion
GHC92
#endif

simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a
simpleNodeInfoCompat :: forall a. FastStringCompat -> FastStringCompat -> NodeInfo a
simpleNodeInfoCompat FastStringCompat
ctor FastStringCompat
typ = forall a. FastString -> FastString -> NodeInfo a
simpleNodeInfo (coerce :: forall a b. Coercible a b => a -> b
coerce FastStringCompat
ctor) (coerce :: forall a b. Coercible a b => a -> b
coerce FastStringCompat
typ)

isAnnotationInNodeInfo :: (FastStringCompat, FastStringCompat) -> NodeInfo a -> Bool
isAnnotationInNodeInfo :: forall a.
(FastStringCompat, FastStringCompat) -> NodeInfo a -> Bool
isAnnotationInNodeInfo (FastStringCompat, FastStringCompat)
p = forall a. Ord a => a -> Set a -> Bool
S.member (FastStringCompat, FastStringCompat)
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set (FastStringCompat, FastStringCompat)
nodeAnnotations

nodeAnnotations :: NodeInfo a -> S.Set (FastStringCompat, FastStringCompat)
nodeAnnotations :: forall a. NodeInfo a -> Set (FastStringCompat, FastStringCompat)
nodeAnnotations = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (\(NodeAnnotation FastString
ctor FastString
typ) -> (coerce :: forall a b. Coercible a b => a -> b
coerce FastString
ctor, coerce :: forall a b. Coercible a b => a -> b
coerce FastString
typ)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
GHC.nodeAnnotations

newtype FastStringCompat = FastStringCompat LexicalFastString
    deriving (TypeIndex -> FastStringCompat -> ShowS
[FastStringCompat] -> ShowS
FastStringCompat -> String
forall a.
(TypeIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FastStringCompat] -> ShowS
$cshowList :: [FastStringCompat] -> ShowS
show :: FastStringCompat -> String
$cshow :: FastStringCompat -> String
showsPrec :: TypeIndex -> FastStringCompat -> ShowS
$cshowsPrec :: TypeIndex -> FastStringCompat -> ShowS
Show, FastStringCompat -> FastStringCompat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FastStringCompat -> FastStringCompat -> Bool
$c/= :: FastStringCompat -> FastStringCompat -> Bool
== :: FastStringCompat -> FastStringCompat -> Bool
$c== :: FastStringCompat -> FastStringCompat -> Bool
Eq, Eq FastStringCompat
FastStringCompat -> FastStringCompat -> Bool
FastStringCompat -> FastStringCompat -> Ordering
FastStringCompat -> FastStringCompat -> FastStringCompat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FastStringCompat -> FastStringCompat -> FastStringCompat
$cmin :: FastStringCompat -> FastStringCompat -> FastStringCompat
max :: FastStringCompat -> FastStringCompat -> FastStringCompat
$cmax :: FastStringCompat -> FastStringCompat -> FastStringCompat
>= :: FastStringCompat -> FastStringCompat -> Bool
$c>= :: FastStringCompat -> FastStringCompat -> Bool
> :: FastStringCompat -> FastStringCompat -> Bool
$c> :: FastStringCompat -> FastStringCompat -> Bool
<= :: FastStringCompat -> FastStringCompat -> Bool
$c<= :: FastStringCompat -> FastStringCompat -> Bool
< :: FastStringCompat -> FastStringCompat -> Bool
$c< :: FastStringCompat -> FastStringCompat -> Bool
compare :: FastStringCompat -> FastStringCompat -> Ordering
$ccompare :: FastStringCompat -> FastStringCompat -> Ordering
Ord)

instance IsString FastStringCompat where
    fromString :: String -> FastStringCompat
fromString = LexicalFastString -> FastStringCompat
FastStringCompat forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> LexicalFastString
LexicalFastString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a
mkAstNode :: forall a. NodeInfo a -> Span -> [HieAST a] -> HieAST a
mkAstNode NodeInfo a
n = forall a. SourcedNodeInfo a -> Span -> [HieAST a] -> HieAST a
Node (forall a. Map NodeOrigin (NodeInfo a) -> SourcedNodeInfo a
SourcedNodeInfo forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton NodeOrigin
GeneratedInfo NodeInfo a
n)

-- | Load modules, quickly. Input doesn't need to be desugared.
-- A module must be loaded before dependent modules can be typechecked.
-- This variant of loadModuleHome will *never* cause recompilation, it just
-- modifies the session.
-- The order modules are loaded is important when there are hs-boot files.
-- In particular you should make sure to load the .hs version of a file after the
-- .hs-boot version.
loadModulesHome
    :: [HomeModInfo]
    -> HscEnv
    -> HscEnv
loadModulesHome :: [HomeModInfo] -> HscEnv -> HscEnv
loadModulesHome [HomeModInfo]
mod_infos HscEnv
e =
#if MIN_VERSION_ghc(9,3,0)
  hscUpdateHUG (\hug -> foldl' (flip addHomeModInfoToHug) hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars })
#else
  let !new_modules :: HomePackageTable
new_modules = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
e) [(HomeModInfo -> ModuleName
mod_name HomeModInfo
x, HomeModInfo
x) | HomeModInfo
x <- [HomeModInfo]
mod_infos]
  in HscEnv
e { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_modules
       , hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = forall a. Maybe a
Nothing
       }
    where
      mod_name :: HomeModInfo -> ModuleName
mod_name = forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface
#endif

recDotDot :: HsRecFields (GhcPass p) arg -> Maybe Int
recDotDot :: forall (p :: Pass) arg.
HsRecFields (GhcPass p) arg -> Maybe TypeIndex
recDotDot HsRecFields (GhcPass p) arg
x =
#if MIN_VERSION_ghc(9,5,0)
            unRecFieldsDotDot <$>
#endif
            forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall p arg. HsRecFields p arg -> Maybe (Located TypeIndex)
rec_dotdot HsRecFields (GhcPass p) arg
x

#if MIN_VERSION_ghc(9,5,0)
extract_cons (NewTypeCon x) = [x]
extract_cons (DataTypeCons _ xs) = xs
#else
extract_cons :: a -> a
extract_cons = forall a. a -> a
id
#endif