-- 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 #-}
#include "ghc-api-version.h"

-- | Attempt at hiding the GHC version differences we can.

module Development.IDE.GHC.Compat(
    HieFileResult(..),
    HieFile(..),
    NameCacheUpdater(..),
    hieExportNames,
    mkHieFile,
    mkHieFile',
    enrichHie,
    RefMap,
    writeHieFile,
    readHieFile,
    supportsHieFiles,
    setHieDir,
    dontWriteHieFiles,
#if !MIN_GHC_API_VERSION(8,8,0)
    ml_hie_file,
    addBootSuffixLocnOut,
#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_GHC_API_VERSION(8,10,0)
    module GHC.Hs.Extension,
    module LinkerTypes,
#else
    module HsExtension,
    noExtField,
    linkableTime,
#endif

    module GHC,
    module DynFlags,
    initializePlugins,
    applyPluginsParsedResultAction,
    module Compat.HieTypes,
    module Compat.HieUtils,
    dropForAll
    ,isQualifiedImport) where

#if MIN_GHC_API_VERSION(8,10,0)
import LinkerTypes
#endif

import StringBuffer
import qualified DynFlags
import DynFlags hiding (ExposePackage)
import Fingerprint (Fingerprint)
import qualified Module
import Packages
import Data.IORef
import HscTypes
import NameCache
import qualified Data.ByteString as BS
import MkIface
import TcRnTypes
import Compat.HieAst (mkHieFile,enrichHie)
import Compat.HieBin
import Compat.HieTypes
import Compat.HieUtils

#if MIN_GHC_API_VERSION(8,10,0)
import GHC.Hs.Extension
#else
import HsExtension
#endif

import qualified GHC
import qualified TyCoRep
import GHC hiding (
      ModLocation,
      HasSrcSpan,
      lookupName,
      getLoc
    )
import Avail
#if MIN_GHC_API_VERSION(8,8,0)
import Data.List (foldl')
#else
import Data.List (foldl', isSuffixOf)
#endif

import DynamicLoading
import Plugins (Plugin(parsedResultAction), withPlugins)
import Data.Map.Strict (Map)

#if !MIN_GHC_API_VERSION(8,8,0)
import System.FilePath ((-<.>))
#endif

#if !MIN_GHC_API_VERSION(8,8,0)
import qualified EnumSet

import System.IO
import Foreign.ForeignPtr


hPutStringBuffer :: Handle -> StringBuffer -> IO ()
hPutStringBuffer hdl (StringBuffer buf len cur)
    = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
             hPutBuf hdl ptr len

#endif

#if !MIN_GHC_API_VERSION(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_GHC_API_VERSION(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_GHC_API_VERSION(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


type RefMap a = Map Identifier [(Span, IdentifierDetails a)]

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
pattern $bModLocation :: Maybe FilePath -> FilePath -> FilePath -> ModLocation
$mModLocation :: forall r.
ModLocation
-> (Maybe FilePath -> FilePath -> FilePath -> r)
-> (Void# -> r)
-> r
ModLocation a b c <-
#if MIN_GHC_API_VERSION(8,8,0)
    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
    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_GHC_API_VERSION(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_GHC_API_VERSION(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_GHC_API_VERSION(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_GHC_API_VERSION(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_GHC_API_VERSION(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

getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName
getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName
getPackageName DynFlags
dfs InstalledUnitId
i = InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> PackageName
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> srcpkgname
packageName (InstalledPackageInfo
   ComponentId
   SourcePackageId
   PackageName
   InstalledUnitId
   UnitId
   ModuleName
   Module
 -> PackageName)
-> Maybe
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
-> Maybe PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags
-> UnitId
-> Maybe
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
lookupPackage DynFlags
dfs (DefUnitId -> UnitId
Module.DefiniteUnitId (InstalledUnitId -> DefUnitId
Module.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_GHC_API_VERSION(8,8,0)
wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags
wopt_unset_fatal dfs f
    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }
#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_GHC_API_VERSION(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_GHC_API_VERSION(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_GHC_API_VERSION(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