liquidhaskell-0.8.10.7: src/Language/Haskell/Liquid/GHC/API.hs
{-| This module re-exports a bunch of the GHC API.
The intended use of this module is to shelter LiquidHaskell from changes to the GHC API, so this is the
/only/ module LiquidHaskell should import when trying to access any ghc-specific functionality.
--}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}
module Language.Haskell.Liquid.GHC.API (
module Ghc
, module StableModule
-- Specific exports for 8.6.5
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
, pattern Bndr
, pattern LitString
, pattern LitFloat
, pattern LitDouble
, pattern LitChar
, VarBndr
#endif
#endif
-- Specific exports for 8.6.5 and 8.8.x
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
, AnonArgFlag(..)
, pattern FunTy
, pattern AnonTCB
, ft_af, ft_mult, ft_arg, ft_res
, bytesFS
, mkFunTy
, isEvVarType
, isEqPrimPred
, noExtField
, Mult
, pattern Many
#endif
#endif
, tyConRealArity
, dataConExTyVars
-- Specific exports for 8.8.x
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
, isEqPred
#endif
#endif
-- Specific exports for 8.10.x
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
, Mult
, pattern Many
, pattern FunTy
, mkFunTy
, ft_af, ft_mult, ft_arg, ft_res
#endif
#endif
-- Shared exports for GHC < 9
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
, pattern RealSrcSpan
, pattern UnhelpfulSpan
, UnhelpfulSpanReason(..)
, scaledThing
, Scaled(..)
, mkScaled
, irrelevantMult
, dataConInstArgTys
, dataConOrigArgTys
, dataConRepArgTys
, mkLocalVar
, DataConAppContext(..)
, deepSplitProductType_maybe
, splitFunTys
, mkUserLocal
, dataConWrapperType
, apiAnnComments
, getDependenciesModuleNames
, GenWithIsBoot(..)
, ModuleNameWithIsBoot
, IsBootInterface
, isBootSummary
, mkIntExprInt
, dataConFullSig
#endif
#endif
-- Specific exports for 9.x
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
, fsToUnitId
, moduleUnitId
, thisPackage
, renderWithStyle
, mkUserStyle
, pattern LitNumber
, dataConSig
, getDependenciesModuleNames
, gcatch
#endif
#endif
) where
import Language.Haskell.Liquid.GHC.API.StableModule as StableModule
import GHC as Ghc hiding ( Warning
, SrcSpan(RealSrcSpan, UnhelpfulSpan)
, exprType
, dataConInstArgTys
)
-- Shared imports for GHC < 9
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import CoreFVs as Ghc (exprFreeVarsList)
import OccurAnal as Ghc (occurAnalysePgm)
import Annotations as Ghc
import ApiAnnotation as Ghc
import Avail as Ghc
import Bag as Ghc
import BasicTypes as Ghc
import Class as Ghc
import CoAxiom as Ghc
import Coercion as Ghc
import ConLike as Ghc
import CoreLint as Ghc hiding (dumpIfSet)
import CoreMonad as Ghc (CoreToDo(..))
import CoreSubst as Ghc (deShadowBinds, substExpr, emptySubst, extendCvSubst)
import CoreSyn as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)
import CoreUtils as Ghc (exprType)
import CostCentre as Ghc
import Data.Map.Strict (Map)
import DataCon as Ghc hiding (dataConInstArgTys, dataConOrigArgTys, dataConRepArgTys, dataConFullSig)
import qualified DataCon as Ghc
import Digraph as Ghc
import DriverPhases as Ghc (Phase(StopLn))
import DriverPipeline as Ghc hiding (P, getLocation)
import DsMonad as Ghc
import DynFlags as Ghc
import ErrUtils as Ghc
import FamInst as Ghc
import FamInstEnv as Ghc hiding (pprFamInst)
import Finder as Ghc
import ForeignCall (CType)
import GHC as Ghc (SrcSpan)
import GhcMonad as Ghc (withSession)
import GhcPlugins as Ghc (deserializeWithData , fromSerialized , toSerialized, extendIdSubst)
import HscMain as Ghc
import HscTypes as Ghc hiding (IsBootInterface, isBootSummary)
import Id as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported, mkUserLocal)
import IdInfo as Ghc
import IfaceSyn as Ghc
import InstEnv as Ghc
import Literal as Ghc
import MkCore as Ghc hiding (mkIntExprInt)
import MkId (mkDataConWorkId)
import Module as Ghc
import Name as Ghc hiding (varName)
import NameEnv (lookupNameEnv_NF)
import NameSet as Ghc
import Outputable as Ghc hiding ((<>))
import Pair as Ghc
import Panic as Ghc
import Plugins as Ghc (defaultPlugin, Plugin(..), CommandLineOption, purePlugin)
import PrelInfo as Ghc
import PrelNames as Ghc hiding (wildCardName)
import RdrName as Ghc
import SrcLoc as Ghc hiding (RealSrcSpan, SrcSpan(UnhelpfulSpan))
import TcRnDriver as Ghc
import TcRnMonad as Ghc hiding (getGHCiMonad)
import TcRnTypes as Ghc
import TysPrim as Ghc
import TysWiredIn as Ghc
import Unify as Ghc
import UniqDFM as Ghc
import UniqFM as Ghc
import UniqSet as Ghc
import UniqSupply as Ghc
import Unique as Ghc
import Var as Ghc hiding (mkLocalVar)
import VarEnv as Ghc
import VarSet as Ghc
import qualified SrcLoc
import qualified Data.Bifunctor as Bi
import qualified Data.Data as Data
import qualified DataCon as Ghc
import qualified GhcMake
import qualified HscTypes as Ghc
import qualified Id as Ghc
import qualified MkCore as Ghc
import qualified Var as Ghc
import qualified WwLib as Ghc
import RnExpr as Ghc (rnLExpr)
import TcExpr as Ghc (tcInferSigma)
import TcBinds as Ghc (tcValBinds)
import Inst as Ghc (deeplyInstantiate)
import TcSimplify as Ghc ( simplifyInfer, simplifyInteractive
, InferMode (..))
import TcHsSyn as Ghc (zonkTopLExpr)
import TcEvidence as Ghc ( TcEvBinds (EvBinds))
import DsExpr as Ghc (dsLExpr)
#endif
#endif
--
-- Compatibility layer for different GHC versions.
--
--
-- Specific imports for GHC 8.6.5
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
import qualified Literal as Lit
import FastString as Ghc hiding (bytesFS, LitString)
import TcType as Ghc hiding (typeKind, mkFunTy)
import Type as Ghc hiding (typeKind, mkFunTy, splitFunTys, extendCvSubst)
import qualified Type as Ghc
import qualified Var as Var
import qualified GHC.Real
-- import PrelNames (eqPrimTyConKey, eqReprPrimTyConKey, gHC_REAL, varQual_RDR)
#endif
#endif
--
-- Specific imports for GHC 8.6.5 & 8.8.x
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
import Binary
import Data.ByteString (ByteString)
import Data.Data (Data)
import Kind as Ghc
import TyCoRep as Ghc hiding (Type (FunTy), mkFunTy, extendCvSubst)
import TyCon as Ghc hiding (mkAnonTyConBinders, TyConBndrVis(AnonTCB))
import qualified TyCoRep as Ty hiding (extendCvSubst)
import qualified TyCon as Ty
import Platform as Ghc
import qualified HsExtension
-- import PrelNames (eqPrimTyConKey, eqReprPrimTyConKey, gHC_REAL, varQual_RDR)
#endif
#endif
--
-- Specific imports for 8.8.x
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
import FastString as Ghc hiding (bytesFS)
import TcType as Ghc hiding (typeKind, mkFunTy, isEqPred)
import Type as Ghc hiding (typeKind, mkFunTy, isEvVarType, isEqPred, splitFunTys, extendCvSubst)
import qualified Type as Ghc
import qualified Type as Ghc (isEvVarType)
import qualified PrelNames as Ghc
import Data.Foldable (asum)
-- import PrelNames (eqPrimTyConKey, eqReprPrimTyConKey, gHC_REAL, varQual_RDR)
#endif
#endif
--
-- Specific imports for GHC 8.10
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) && !MIN_VERSION_GLASGOW_HASKELL (9,0,0,0)
import DynFlags as Ghc (targetPlatform)
import GHC.Platform as Ghc (Platform)
import Type as Ghc hiding (typeKind , isPredTy, splitFunTys, extendCvSubst)
import qualified Type as Ghc hiding (extendCvSubst)
import TyCon as Ghc
import qualified TyCoRep as Ty
import TcType as Ghc
import TyCoRep as Ghc hiding (Type (FunTy), mkFunTy, ft_arg, ft_res, ft_af)
import FastString as Ghc
import Predicate as Ghc (getClassPredTys_maybe, isEvVarType, getClassPredTys, isDictId)
import TcOrigin as Ghc (lexprCtOrigin)
import Data.Foldable (asum)
import Util (lengthIs)
-- import PrelNames (eqPrimTyConKey, eqReprPrimTyConKey, gHC_REAL, varQual_RDR)
#endif
#endif
--
-- Specific imports for GHC 9
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) && !MIN_VERSION_GLASGOW_HASKELL (9,1,0,0)
import Optics
import qualified Control.Monad.Catch as Ex
import Data.Foldable (asum)
import GHC.Builtin.Names as Ghc
import GHC.Builtin.Types as Ghc
import GHC.Builtin.Types.Prim as Ghc
import GHC.Builtin.Utils as Ghc
import GHC.Core as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)
import GHC.Core.Class as Ghc
import GHC.Core.Coercion as Ghc
import GHC.Core.Coercion.Axiom as Ghc
import GHC.Core.ConLike as Ghc
import GHC.Core.DataCon as Ghc
import GHC.Core.FamInstEnv as Ghc hiding (pprFamInst)
import GHC.Core.InstEnv as Ghc
import GHC.Core.Lint as Ghc hiding (dumpIfSet)
import GHC.Core.Make as Ghc
import GHC.Core.Opt.Monad as Ghc (CoreToDo(..))
import GHC.Core.Opt.WorkWrap.Utils as Ghc
import GHC.Core.Predicate as Ghc (getClassPredTys_maybe, getClassPredTys, isEvVarType, isEqPrimPred, isEqPred, isClassPred, isDictId)
import GHC.Core.Subst as Ghc (deShadowBinds, emptySubst, extendCvSubst)
import GHC.Core.TyCo.Rep as Ghc hiding (extendCvSubst)
import GHC.Core.TyCon as Ghc
import GHC.Core.Type as Ghc hiding (typeKind , isPredTy, extendCvSubst, linear)
import GHC.Core.Unify as Ghc
import GHC.Core.Utils as Ghc (exprType)
import GHC.Data.Bag as Ghc
import GHC.Data.FastString as Ghc
import GHC.Data.Graph.Directed as Ghc
import GHC.Data.Pair as Ghc
import GHC.Driver.Finder as Ghc
import GHC.Driver.Main as Ghc
import GHC.Driver.Phases as Ghc (Phase(StopLn))
import GHC.Driver.Pipeline as Ghc (compileFile)
import GHC.Driver.Session as Ghc
import GHC.Driver.Types as Ghc
import GHC.Driver.Monad as Ghc (withSession)
import GHC.HsToCore.Monad as Ghc
import GHC.Iface.Syntax as Ghc
import GHC.Plugins as Ghc ( deserializeWithData
, fromSerialized
, toSerialized
, defaultPlugin
, Plugin(..)
, CommandLineOption
, purePlugin
, extendIdSubst
, substExpr
)
import GHC.Tc.Instance.Family as Ghc
import GHC.Tc.Module as Ghc
import GHC.Tc.Types as Ghc
import GHC.Tc.Utils.Monad as Ghc hiding (getGHCiMonad)
import GHC.Tc.Utils.TcType as Ghc (tcSplitDFunTy, tcSplitMethodTy)
import GHC.Types.Annotations as Ghc
import GHC.Types.Avail as Ghc
import GHC.Types.Basic as Ghc
import GHC.Types.CostCentre as Ghc
import GHC.Types.Id as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported)
import GHC.Types.Id.Info as Ghc
import GHC.Types.Literal as Ghc hiding (LitNumber)
import GHC.Types.Name as Ghc hiding (varName, isWiredIn)
import GHC.Types.Name.Reader as Ghc
import GHC.Types.Name.Set as Ghc
import GHC.Types.SrcLoc as Ghc
import GHC.Types.Unique as Ghc
import GHC.Types.Unique.DFM as Ghc
import GHC.Types.Unique.FM as Ghc
import GHC.Types.Unique.Set as Ghc
import GHC.Types.Unique.Supply as Ghc
import GHC.Types.Var as Ghc
import GHC.Types.Var.Env as Ghc
import GHC.Types.Var.Set as Ghc
import GHC.Unit.Module as Ghc
import GHC.Utils.Error as Ghc
import GHC.Utils.Outputable as Ghc hiding ((<>), renderWithStyle, mkUserStyle)
import GHC.Utils.Panic as Ghc
import qualified GHC.Types.Literal as Ghc
import qualified GHC.Utils.Outputable as Ghc
import GHC.Tc.Types.Origin as Ghc (lexprCtOrigin)
import GHC.Rename.Expr as Ghc (rnLExpr)
import GHC.Tc.Gen.Expr as Ghc (tcInferSigma, tcInferRho)
import GHC.Tc.Gen.Bind as Ghc (tcValBinds)
import GHC.Tc.Solver as Ghc
import GHC.Tc.Utils.Zonk as Ghc
import GHC.Core.FVs as Ghc (exprFreeVarsList)
import GHC.Tc.Types.Evidence as Ghc
import GHC.HsToCore.Expr as Ghc
import GHC.Core.Predicate as Ghc (mkClassPred)
import GHC.Core.Opt.OccurAnal as Ghc
#endif
#endif
--
-- Compat shim for GHC < 9 (shared parts)
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
data BufSpan
pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan
pattern RealSrcSpan rss mbSpan <- ((,Nothing) -> (SrcLoc.RealSrcSpan rss, mbSpan))
where
RealSrcSpan rss _mbSpan = SrcLoc.RealSrcSpan rss
data UnhelpfulSpanReason
= UnhelpfulNoLocationInfo
| UnhelpfulWiredIn
| UnhelpfulInteractive
| UnhelpfulGenerated
| UnhelpfulOther !FastString
deriving (Eq, Show)
pattern UnhelpfulSpan :: UnhelpfulSpanReason -> SrcLoc.SrcSpan
pattern UnhelpfulSpan reason <- (toUnhelpfulReason -> Just reason)
where
UnhelpfulSpan reason = SrcLoc.UnhelpfulSpan (fromUnhelpfulReason reason)
fromUnhelpfulReason :: UnhelpfulSpanReason -> FastString
fromUnhelpfulReason = \case
UnhelpfulNoLocationInfo -> fsLit "UnhelpfulNoLocationInfo"
UnhelpfulWiredIn -> fsLit "UnhelpfulWiredIn"
UnhelpfulInteractive -> fsLit "UnhelpfulInteractive"
UnhelpfulGenerated -> fsLit "UnhelpfulGenerated"
UnhelpfulOther fs -> fs
toUnhelpfulReason :: SrcLoc.SrcSpan -> Maybe UnhelpfulSpanReason
toUnhelpfulReason (SrcLoc.RealSrcSpan _) = Nothing
toUnhelpfulReason (SrcLoc.UnhelpfulSpan fs) = Just $ case unpackFS fs of
"UnhelpfulNoLocationInfo" -> UnhelpfulNoLocationInfo
"UnhelpfulWiredIn" -> UnhelpfulWiredIn
"UnhelpfulInteractive" -> UnhelpfulInteractive
"UnhelpfulGenerated" -> UnhelpfulGenerated
_ -> UnhelpfulOther fs
-- Backporting multiplicity
data Scaled a = Scaled Mult a
deriving (Data.Data)
instance (Outputable a) => Outputable (Scaled a) where
ppr (Scaled _cnt t) = ppr t
irrelevantMult :: Scaled a -> a
irrelevantMult = scaledThing
mkScaled :: Mult -> a -> Scaled a
mkScaled = Scaled
scaledThing :: Scaled a -> a
scaledThing (Scaled _ t) = t
type Mult = Type
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon n univs tys tycon = data_con
where
data_con = mkDataCon n
False
(mkPrelTyConRepName n)
(map (const (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)) tys)
[]
univs
[]
(error "[TyVarBinder]")
[]
[]
tys
(mkTyConApp tycon (mkTyVarTys univs))
NoRRI
tycon
(lookupNameEnv_NF (mkTyConTagMap tycon) n)
[]
(mkDataConWorkId (mkDataConWorkerName data_con (dataConWorkerUnique (nameUnique n))) data_con)
NoDataConRep
mkDataConWorkerName :: DataCon -> Unique -> Name
mkDataConWorkerName data_con wrk_key =
mkWiredInName modu wrk_occ wrk_key
(AnId (dataConWorkId data_con)) UserSyntax
where
modu = nameModule dc_name
dc_name = dataConName data_con
dc_occ = nameOccName dc_name
wrk_occ = mkDataConWorkerOcc dc_occ
pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon name cType tyvars cons
= mkAlgTyCon name
(mkAnonTyConBinders VisArg tyvars)
liftedTypeKind
(map (const Representational) tyvars)
cType
[] -- No stupid theta
(mkDataTyConRhs cons)
(VanillaAlgTyCon (mkPrelTyConRepName name))
False -- Not in GADT syntax
mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name
mkWiredInDataConName built_in modu fs unique datacon
= mkWiredInName modu (mkDataOccFS fs) unique
(AConLike (RealDataCon datacon)) -- Relevant DataCon
built_in
multiplicityTyConKey :: Unique
multiplicityTyConKey = mkPreludeTyConUnique 192
multiplicityTyConName :: Name
multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")
multiplicityTyConKey multiplicityTyCon
manyDataConName :: Name
manyDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon
multiplicityTyCon :: TyCon
multiplicityTyCon = pcTyCon multiplicityTyConName Nothing [] [manyDataCon]
manyDataCon :: DataCon
manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon
manyDataConKey :: Unique
manyDataConKey = mkPreludeDataConUnique 116
manyDataConTy :: Type
manyDataConTy = mkTyConTy manyDataConTyCon
manyDataConTyCon :: TyCon
manyDataConTyCon = promoteDataCon manyDataCon
pattern Many :: Mult
pattern Many <- (isManyDataConTy -> True)
where Many = manyDataConTy
isManyDataConTy :: Mult -> Bool
isManyDataConTy ty
| Just tc <- tyConAppTyCon_maybe ty
= tc `hasKey` manyDataConKey
isManyDataConTy _ = False
--
-- Dependencies and Boot
--
type IsBootInterface = GhcMake.IsBoot
-- | This data type just pairs a value 'mod' with an IsBootInterface flag. In
-- practice, 'mod' is usually a @Module@ or @ModuleName@'.
data GenWithIsBoot mod = GWIB
{ gwib_mod :: mod
, gwib_isBoot :: IsBootInterface
} deriving ( Eq, Ord, Show
, Functor, Foldable, Traversable
)
type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
isBootSummary :: ModSummary -> IsBootInterface
isBootSummary ms = case Ghc.isBootSummary ms of
True -> GhcMake.IsBoot
False -> GhcMake.NotBoot
getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]
getDependenciesModuleNames = map f . dep_mods
where
f :: (ModuleName, Bool) -> ModuleNameWithIsBoot
f (modName, b) = let isBoot = if b then GhcMake.IsBoot else GhcMake.NotBoot in GWIB modName isBoot
dataConInstArgTys :: DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys dc tys = map (mkScaled Many) (Ghc.dataConInstArgTys dc tys)
dataConOrigArgTys :: DataCon -> [Scaled Type]
dataConOrigArgTys dc = map (mkScaled Many) (Ghc.dataConOrigArgTys dc)
dataConRepArgTys :: DataCon -> [Scaled Type]
dataConRepArgTys dc = map (mkScaled Many) (Ghc.dataConRepArgTys dc)
mkLocalVar :: IdDetails -> Name -> Mult -> Type -> IdInfo -> Id
mkLocalVar idDetails name _ ty info = Ghc.mkLocalVar idDetails name ty info
mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id
mkUserLocal occName u _mult ty srcSpan = Ghc.mkUserLocal occName u ty srcSpan
dataConWrapperType :: DataCon -> Type
dataConWrapperType = dataConUserType
-- WWlib
data DataConAppContext
= DataConAppContext
{ dcac_dc :: !DataCon
, dcac_tys :: ![Type]
, dcac_arg_tys :: ![(Scaled Type, StrictnessMark)]
, dcac_co :: !Coercion
}
deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext
deepSplitProductType_maybe famInstEnv ty = do
(dc, tys, tysWithStricts, co) <- Ghc.deepSplitProductType_maybe famInstEnv ty
pure $ DataConAppContext dc tys (map (Bi.first (mkScaled Many)) tysWithStricts) co
splitFunTys :: Type -> ([Scaled Type], Type)
splitFunTys ty = Bi.first (map (mkScaled Many)) $ Ghc.splitFunTys ty
apiAnnComments :: (Map ApiAnnKey [SrcSpan], Map SrcSpan [Located AnnotationComment])
-> Map SrcSpan [Located AnnotationComment]
apiAnnComments = snd
mkIntExprInt :: Platform -> Int -> CoreExpr
mkIntExprInt _ int = Ghc.mkIntExprInt unsafeGlobalDynFlags int
dataConFullSig :: DataCon -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)
dataConFullSig dc =
let (tyvars, tycovars, eqspecs, theta, tys, ty) = Ghc.dataConFullSig dc
in (tyvars, tycovars, eqspecs, theta, map (mkScaled Many) tys, ty)
#endif
#endif
--
-- Compat shim for GHC 8.6.5
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
pattern LitString :: ByteString -> Lit.Literal
pattern LitString bs <- Lit.MachStr bs where
LitString bs = Lit.MachStr bs
pattern LitFloat :: GHC.Real.Ratio Integer -> Lit.Literal
pattern LitFloat f <- Lit.MachFloat f where
LitFloat f = Lit.MachFloat f
pattern LitDouble :: GHC.Real.Ratio Integer -> Lit.Literal
pattern LitDouble d <- Lit.MachDouble d where
LitDouble d = Lit.MachDouble d
pattern LitChar :: Char -> Lit.Literal
pattern LitChar c <- Lit.MachChar c where
LitChar c = Lit.MachChar c
pattern Bndr :: var -> argf -> Var.TyVarBndr var argf
pattern Bndr var argf <- TvBndr var argf where
Bndr var argf = TvBndr var argf
type VarBndr = TyVarBndr
isEqPrimPred :: Type -> Bool
isEqPrimPred = Ghc.isPredTy
-- See NOTE [isEvVarType].
isEvVarType :: Type -> Bool
isEvVarType = Ghc.isPredTy
tyConRealArity :: TyCon -> Int
tyConRealArity = tyConArity
#endif
#endif
--
-- Compat shim for GHC-8.6.5 and GHC-8.8.x
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
-- | The non-dependent version of 'ArgFlag'.
-- Appears here partly so that it's together with its friend ArgFlag,
-- but also because it is used in IfaceType, rather early in the
-- compilation chain
-- See Note [AnonArgFlag vs. ForallVisFlag]
data AnonArgFlag
= VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow.
-- The argument is visible in source code.
| InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow.
-- The argument is invisible in source code.
deriving (Eq, Ord, Data)
instance Outputable AnonArgFlag where
ppr VisArg = text "[vis]"
ppr InvisArg = text "[invis]"
instance Binary AnonArgFlag where
put_ bh VisArg = putByte bh 0
put_ bh InvisArg = putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> return VisArg
_ -> return InvisArg
mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder]
mkAnonTyConBinders _ = Ty.mkAnonTyConBinders
bytesFS :: FastString -> ByteString
bytesFS = fastStringToByteString
mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type
mkFunTy _ _ = Ty.FunTy
pattern FunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type
pattern FunTy { ft_af, ft_mult, ft_arg, ft_res } <- ((VisArg,Many,) -> (ft_af, ft_mult, Ty.FunTy ft_arg ft_res)) where
FunTy _ft_af _ft_mult ft_arg ft_res = Ty.FunTy ft_arg ft_res
pattern AnonTCB :: AnonArgFlag -> Ty.TyConBndrVis
pattern AnonTCB af <- ((VisArg,) -> (af, Ty.AnonTCB)) where
AnonTCB _af = Ty.AnonTCB
noExtField :: NoExt
noExtField = NoExt
#endif
-- Compat shim for GHC 8.8.x
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) && !MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
isEqPrimPred :: Type -> Bool
isEqPrimPred ty
| Just tc <- tyConAppTyCon_maybe ty
= tc `hasKey` Ghc.eqPrimTyConKey || tc `hasKey` Ghc.eqReprPrimTyConKey
| otherwise
= False
isEqPred :: Type -> Bool
isEqPred ty
| Just tc <- tyConAppTyCon_maybe ty
, Just cls <- tyConClass_maybe tc
= cls `hasKey` Ghc.eqTyConKey || cls `hasKey` Ghc.heqTyConKey
| otherwise
= False
-- See NOTE [isEvVarType].
isEvVarType :: Type -> Bool
isEvVarType = Ghc.isEvVarType
#endif
#endif
{- | [NOTE:tyConRealArity]
The semantics of 'tyConArity' changed between GHC 8.6.5 and GHC 8.10, mostly due to the
Visible Dependent Quantification (VDQ). As a result, given the following:
data family EntityField record :: * -> *
Calling `tyConArity` on this would yield @2@ for 8.6.5 but @1@ an 8.10, so we try to backport
the old behaviour in 8.10 by \"looking\" at the 'Kind' of the input 'TyCon' and trying to recursively
split the type apart with either 'splitFunTy_maybe' or 'splitForAllTy_maybe'.
-}
{- | [NOTE:isEvVarType]
For GHC < 8.8.1 'isPredTy' is effectively the same as the new 'isEvVarType', which covers the cases
for coercion types and \"normal\" type coercions. The 8.6.5 version of 'isPredTy' had a special case to
handle a 'TyConApp' in the case of type equality (i.e. ~ ) which was removed in the implementation
for 8.8.1, which essentially calls 'tcIsConstraintKind' straight away.
-}
--
-- Support for GHC >= 8.8
--
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) && !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
-- See NOTE [tyConRealArity].
tyConRealArity :: TyCon -> Int
tyConRealArity tc = go 0 (tyConKind tc)
where
go :: Int -> Kind -> Int
go !acc k =
case asum [fmap snd (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of
Nothing -> acc
Just ks -> go (acc + 1) ks
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyVars = dataConExTyCoVars
#endif
--
-- Compat shim for 8.10.x
--
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
pattern FunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type
pattern FunTy { ft_af, ft_mult, ft_arg, ft_res } <- ((Many,) -> (ft_mult, Ty.FunTy ft_af ft_arg ft_res)) where
FunTy ft_af _ft_mult ft_arg ft_res = Ty.FunTy ft_af ft_arg ft_res
mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type
mkFunTy af _ arg res = Ty.FunTy af arg res
#endif
--
-- Compat shim for 9.0.x
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
-- 'fsToUnitId' is gone in GHC 9, but we can bring code it in terms of 'fsToUnit' and 'toUnitId'.
fsToUnitId :: FastString -> UnitId
fsToUnitId = toUnitId . fsToUnit
moduleUnitId :: Module -> UnitId
moduleUnitId = toUnitId . moduleUnit
thisPackage :: DynFlags -> UnitId
thisPackage = toUnitId . homeUnit
-- See NOTE [tyConRealArity].
tyConRealArity :: TyCon -> Int
tyConRealArity tc = go 0 (tyConKind tc)
where
go :: Int -> Kind -> Int
go !acc k =
case asum [fmap (view _3) (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of
Nothing -> acc
Just ks -> go (acc + 1) ks
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyVars = dataConExTyCoVars
getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]
getDependenciesModuleNames = dep_mods
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
renderWithStyle dynflags sdoc style = Ghc.renderWithStyle (Ghc.initSDocContext dynflags style) sdoc
mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle _ = Ghc.mkUserStyle
--
-- Literal
--
-- In GHC 9 'LitNumber' doesn't have the extra 3rd argument, so we simply ignore it in the construction.
pattern LitNumber :: Ghc.LitNumType -> Integer -> Ghc.Type -> Ghc.Literal
pattern LitNumber numType integer ty <- ((intPrimTy,) -> (ty, Ghc.LitNumber numType integer))
where
LitNumber numType integer _ = Ghc.LitNumber numType integer
-- This function is gone in GHC 9.
dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)
dataConSig dc
= (dataConUnivAndExTyCoVars dc, dataConTheta dc, map irrelevantMult $ dataConOrigArgTys dc, dataConOrigResTy dc)
gcatch :: (Ex.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a
gcatch = Ex.catch
#endif
--
-- End of compatibility shim.
--
#endif