{-# LANGUAGE CPP                    #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE PatternSynonyms        #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE TupleSections          #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE ViewPatterns           #-}

-- | Thin compatibility layer around GHC
--
-- This should be the only module with GHC-specific CPP directives, and the
-- rest of the plugin should not import from any GHC modules directly.
module Data.Record.Internal.GHC.Shim (
    -- * Names
    lookupVarName
  , lookupTcName

    -- * Miscellaneous
  , importDecl
  , conPat
  , mkFunBind
  , HsModule
  , LHsModule
  , LRdrName
  , pattern GHC.HsModule

    -- * Annotations
#if __GLASGOW_HASKELL__ < 902
  , reLoc
  , reLocA
  , noLocA
#endif

    -- * Extensions
  , HasDefaultExt(..)
  , withDefExt

    -- * Generalized @forall@
#if __GLASGOW_HASKELL__ >= 900
  , HsTyVarBndr
  , LHsTyVarBndr
#endif
  , hsFunTy
  , userTyVar
  , kindedTyVar
  , hsTyVarLName
  , setDefaultSpecificity

    -- * Locations
  , ToSrcSpan(..)
  , InheritLoc(..)
  , withoutLoc

    -- * New functionality
  , compareHs

    -- * NameCache
  , NameCacheIO
  , hscNameCacheIO
  , takeUniqFromNameCacheIO

    -- * Records
  , simpleRecordUpdates

    -- * Re-exports

    -- The whole-sale module exports are not ideal for preserving compatibility
    -- across ghc versions, but we'll deal with this on a case by case basis.
#if __GLASGOW_HASKELL__ < 900
  , module Bag
  , module BasicTypes
  , module ErrUtils
  , module GHC
  , module GhcPlugins
  , module HscMain
  , module NameCache
  , module TcEvidence
#else
  , module GHC.Data.Bag
  , module GHC.Driver.Main
  , module GHC.Hs
  , module GHC.Plugins
  , module GHC.Tc.Types.Evidence
  , module GHC.Utils.Error
#if __GLASGOW_HASKELL__ >= 902
  , module GHC.Types.SourceText
  , module GHC.Types.Fixity
#endif
#endif
  ) where

import Control.Monad
import Data.List.NonEmpty (NonEmpty(..))
import Data.Generics (Data, GenericQ, cast, toConstr, gzipWithQ)

import qualified Data.List.NonEmpty as NE

#if __GLASGOW_HASKELL__ < 900

import Data.IORef

import Bag (Bag, listToBag, emptyBag)
import BasicTypes (SourceText (NoSourceText))
import ConLike (ConLike)
import ErrUtils (mkErrMsg, mkWarnMsg)
import Finder (findImportedModule)
import GHC hiding (AnnKeywordId(..), HsModule, exprType, typeKind, mkFunBind)
import GhcPlugins hiding ((<>), getHscEnv,)
import HscMain (getHscEnv)
import IfaceEnv (lookupOrigIO)
import NameCache (NameCache(nsUniqs))
import PatSyn (PatSyn)
import TcEvidence (HsWrapper(WpHole))

import qualified GHC
import qualified GhcPlugins as GHC

#else

import GHC.Hs hiding (LHsTyVarBndr, HsTyVarBndr, HsModule, mkFunBind)
import qualified GHC.Hs as GHC

import GHC.Core.Class (Class)
import GHC.Core.ConLike (ConLike)
import GHC.Core.PatSyn (PatSyn)
import GHC.Data.Bag (Bag, listToBag, emptyBag)
import GHC.Driver.Main (getHscEnv)
import GHC.Tc.Types.Evidence (HsWrapper(WpHole))
import GHC.Utils.Error (Severity(SevError, SevWarning))

import GHC.Plugins hiding ((<>), getHscEnv
#if __GLASGOW_HASKELL__ >= 902
    , AnnType, AnnLet, AnnRec, AnnLam, AnnCase
    , Exception
#endif
#if __GLASGOW_HASKELL__ < 904
    , trace
#endif
    )

#if __GLASGOW_HASKELL__ < 902
import GHC.Driver.Finder (findImportedModule)
import GHC.Parser.Annotation (IsUnicodeSyntax(NormalSyntax))
import GHC.Utils.Error (mkErrMsg, mkWarnMsg)
#else
import GHC.Types.Fixity
import GHC.Types.SourceText (SourceText(NoSourceText), mkIntegralLit)
import GHC.Unit.Finder (findImportedModule, FindResult(Found))
#endif

#if __GLASGOW_HASKELL__ < 904
import Data.IORef
import GHC.Iface.Env (lookupOrigIO)
import GHC.Types.Name.Cache (NameCache(nsUniqs))
#else
import GHC.Iface.Env (lookupNameCache)
import GHC.Rename.Names (renamePkgQual)
import GHC.Types.Name.Cache (NameCache, takeUniqFromNameCache)
#endif

#endif

{-------------------------------------------------------------------------------
  Name resolution
-------------------------------------------------------------------------------}

lookupVarName ::
     HasCallStack
  => ModuleName
  -> Maybe FastString -- ^ Optional package name
  -> String -> Hsc Name
lookupVarName :: HasCallStack =>
ModuleName -> Maybe FastString -> String -> Hsc Name
lookupVarName ModuleName
modl Maybe FastString
pkg = HasCallStack =>
ModuleName -> Maybe FastString -> OccName -> Hsc Name
lookupOccName ModuleName
modl Maybe FastString
pkg forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkVarOcc

lookupTcName ::
     HasCallStack
  => ModuleName
  -> Maybe FastString -- ^ Optional package name
  -> String -> Hsc Name
lookupTcName :: HasCallStack =>
ModuleName -> Maybe FastString -> String -> Hsc Name
lookupTcName ModuleName
modl Maybe FastString
pkg = HasCallStack =>
ModuleName -> Maybe FastString -> OccName -> Hsc Name
lookupOccName ModuleName
modl Maybe FastString
pkg forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkTcOcc

lookupOccName ::
     HasCallStack
  => ModuleName
  -> Maybe FastString -- ^ Optional package name
  -> OccName -> Hsc Name
lookupOccName :: HasCallStack =>
ModuleName -> Maybe FastString -> OccName -> Hsc Name
lookupOccName ModuleName
modlName Maybe FastString
mPkgName OccName
name = do
    HscEnv
env <- Hsc HscEnv
getHscEnv

#if __GLASGOW_HASKELL__ >= 904
    let pkgq :: PkgQual
        pkgq = renamePkgQual (hsc_unit_env env) modlName mPkgName
#else
    let pkgq :: Maybe FastString
        pkgq :: Maybe FastString
pkgq = Maybe FastString
mPkgName
#endif

    FindResult
mModl <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
env ModuleName
modlName Maybe FastString
pkgq
    case FindResult
mModl of
      Found ModLocation
_ Module
modl -> forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> OccName -> IO Name
lookupOrigIO HscEnv
env Module
modl OccName
name
      FindResult
_otherwise   -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [
          String
"lookupName: could not find "
        , OccName -> String
occNameString OccName
name
        , String
" in module "
        , ModuleName -> String
moduleNameString ModuleName
modlName
        , String
". This might be due to an undeclared package dependency"
        , case Maybe FastString
mPkgName of
            Maybe FastString
Nothing  -> String
""
            Just FastString
pkg -> String
" on " forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
pkg
        , String
"."
        ]

#if __GLASGOW_HASKELL__ >= 904
lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
lookupOrigIO env modl occ = lookupNameCache (hsc_NC env) modl occ
#endif

{-------------------------------------------------------------------------------
  Miscellaneous
-------------------------------------------------------------------------------}

-- | Optionally @qualified@ import declaration
importDecl :: ModuleName -> Bool -> LImportDecl GhcPs
importDecl :: ModuleName -> Bool -> LImportDecl GhcPs
importDecl ModuleName
name Bool
qualified = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ ImportDecl {
      ideclExt :: XCImportDecl GhcPs
ideclExt       = forall a. HasDefaultExt a => a
defExt
    , ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText
    , ideclName :: XRec GhcPs ModuleName
ideclName      = forall a an. a -> LocatedAn an a
noLocA ModuleName
name
#if __GLASGOW_HASKELL__ >= 904
    , ideclPkgQual   = NoRawPkgQual
#else
    , ideclPkgQual :: Maybe StringLiteral
ideclPkgQual   = forall a. Maybe a
Nothing
#endif
    , ideclSafe :: Bool
ideclSafe      = Bool
False
    , ideclImplicit :: Bool
ideclImplicit  = Bool
False
    , ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclAs        = forall a. Maybe a
Nothing
    , ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding    = forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ < 810
    , ideclQualified = qualified
#else
    , ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = if Bool
qualified then ImportDeclQualifiedStyle
QualifiedPre else ImportDeclQualifiedStyle
NotQualified
#endif
#if __GLASGOW_HASKELL__ < 900
    , ideclSource    = False
#else
    , ideclSource :: IsBootInterface
ideclSource    = IsBootInterface
NotBoot
#endif
    }

conPat :: Located RdrName -> HsConPatDetails GhcPs -> Pat GhcPs
#if __GLASGOW_HASKELL__ < 900
conPat x y = ConPatIn x y
#else
conPat :: Located RdrName -> HsConPatDetails GhcPs -> Pat GhcPs
conPat Located RdrName
x HsConPatDetails GhcPs
y = forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat forall a. HasDefaultExt a => a
defExt (forall e ann. Located e -> LocatedAn ann e
reLocA Located RdrName
x) HsConPatDetails GhcPs
y
#endif

mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
#if __GLASGOW_HASKELL__ < 810
mkFunBind = GHC.mkFunBind
#else
mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
mkFunBind (forall e ann. Located e -> LocatedAn ann e
reLocA -> LocatedAn NameAnn RdrName
n) = Origin
-> LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
GHC.mkFunBind Origin
Generated LocatedAn NameAnn RdrName
n
#endif

#if __GLASGOW_HASKELL__ < 900
type HsModule = GHC.HsModule GhcPs
#else
type HsModule = GHC.HsModule
#endif

type LHsModule = Located HsModule
type LRdrName  = Located RdrName

{-------------------------------------------------------------------------------
  NameCache
-------------------------------------------------------------------------------}

#if __GLASGOW_HASKELL__ < 904
type NameCacheIO = IORef NameCache

takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique
takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique
takeUniqFromNameCacheIO = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef NameCache -> (NameCache, Unique)
aux
  where
    aux :: NameCache -> (NameCache, Unique)
    aux :: NameCache -> (NameCache, Unique)
aux NameCache
nc = let (Unique
newUniq, UniqSupply
us) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
nc)
             in (NameCache
nc { nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us }, Unique
newUniq)
#else
type NameCacheIO = NameCache

takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique
takeUniqFromNameCacheIO = takeUniqFromNameCache
#endif

hscNameCacheIO :: HscEnv -> NameCacheIO
hscNameCacheIO :: HscEnv -> NameCacheIO
hscNameCacheIO = HscEnv -> NameCacheIO
hsc_NC

{-------------------------------------------------------------------------------
  Exact-print annotations
-------------------------------------------------------------------------------}

#if __GLASGOW_HASKELL__ < 902
reLoc :: Located a -> Located a
reLoc = id

reLocA :: Located a -> Located a
reLocA = id

noLocA :: e -> Located e
noLocA = noLoc

#if __GLASGOW_HASKELL__ >= 900
mapXRec :: forall pass f g l. (f pass -> g pass) -> GenLocated l (f pass) -> GenLocated l (g pass)
mapXRec = fmap
#endif
#endif

{-------------------------------------------------------------------------------
  Extensions
-------------------------------------------------------------------------------}

class HasDefaultExt a where
  defExt :: a

#if __GLASGOW_HASKELL__ < 810
instance HasDefaultExt NoExt where
  defExt = noExt
#else
instance HasDefaultExt NoExtField where
  defExt :: NoExtField
defExt = NoExtField
noExtField
#endif

#if __GLASGOW_HASKELL__ >= 900
instance HasDefaultExt LayoutInfo where
  defExt :: LayoutInfo
defExt = LayoutInfo
NoLayoutInfo
#endif

instance (HasDefaultExt a, HasDefaultExt b) => HasDefaultExt (a, b) where
  defExt :: (a, b)
defExt = (forall a. HasDefaultExt a => a
defExt, forall a. HasDefaultExt a => a
defExt)

instance (HasDefaultExt a, HasDefaultExt b, HasDefaultExt c) => HasDefaultExt (a, b, c) where
  defExt :: (a, b, c)
defExt = (forall a. HasDefaultExt a => a
defExt, forall a. HasDefaultExt a => a
defExt, forall a. HasDefaultExt a => a
defExt)

#if __GLASGOW_HASKELL__ >= 902
instance HasDefaultExt (EpAnn ann) where
  defExt :: EpAnn ann
defExt = forall ann. EpAnn ann
noAnn

instance HasDefaultExt AnnSortKey where
  defExt :: AnnSortKey
defExt = AnnSortKey
NoAnnSortKey

instance HasDefaultExt EpAnnComments where
  defExt :: EpAnnComments
defExt = forall an. EpAnn an -> EpAnnComments
epAnnComments forall ann. EpAnn ann
noAnn
#endif

-- In GHC-9.2 some things have extension fields.
#if __GLASGOW_HASKELL__ >= 902
withDefExt :: HasDefaultExt a => (a -> b) -> b
withDefExt :: forall a b. HasDefaultExt a => (a -> b) -> b
withDefExt a -> b
f = a -> b
f forall a. HasDefaultExt a => a
defExt
#else
withDefExt :: a -> a
withDefExt a = a
#endif

{-------------------------------------------------------------------------------
  Generalized @forall@ in 9.0
-------------------------------------------------------------------------------}

#if __GLASGOW_HASKELL__ >= 900
type  HsTyVarBndr pass =  GHC.HsTyVarBndr () pass
type LHsTyVarBndr pass = GHC.LHsTyVarBndr () pass
#endif

hsFunTy :: XFunTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
#if __GLASGOW_HASKELL__ < 900
hsFunTy = HsFunTy
#elif __GLASGOW_HASKELL__ < 904
hsFunTy :: XFunTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
hsFunTy XFunTy GhcPs
ext = forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
ext (forall pass. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
NormalSyntax)
#else
hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow (L NoTokenLoc HsNormalTok))
#endif

userTyVar ::
     XUserTyVar GhcPs
  -> Located (IdP GhcPs)
  -> HsTyVarBndr GhcPs
#if __GLASGOW_HASKELL__ < 900
userTyVar = UserTyVar
#else
userTyVar :: XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr () GhcPs
userTyVar XUserTyVar GhcPs
ext Located (IdP GhcPs)
x = forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
ext () (forall e ann. Located e -> LocatedAn ann e
reLocA Located (IdP GhcPs)
x)
#endif

kindedTyVar ::
     XKindedTyVar GhcPs
  -> Located (IdP GhcPs)
  -> LHsKind GhcPs
  -> HsTyVarBndr GhcPs
#if __GLASGOW_HASKELL__ < 900
kindedTyVar = KindedTyVar
#else
kindedTyVar :: XKindedTyVar GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr () GhcPs
kindedTyVar XKindedTyVar GhcPs
ext Located (IdP GhcPs)
k = forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
ext () (forall e ann. Located e -> LocatedAn ann e
reLocA Located (IdP GhcPs)
k)
#endif

-- | Like 'hsTyVarName', but don't throw away the location information
hsTyVarLName :: HsTyVarBndr GhcPs -> LRdrName
#if __GLASGOW_HASKELL__ < 900
hsTyVarLName (UserTyVar   _ n  ) = n
hsTyVarLName (KindedTyVar _ n _) = n
hsTyVarLName _ = panic "hsTyVarLName"
#else
hsTyVarLName :: HsTyVarBndr () GhcPs -> Located RdrName
hsTyVarLName (UserTyVar   XUserTyVar GhcPs
_ ()
_ LIdP GhcPs
n  ) = forall a e. LocatedAn a e -> Located e
reLoc LIdP GhcPs
n
hsTyVarLName (KindedTyVar XKindedTyVar GhcPs
_ ()
_ LIdP GhcPs
n LHsType GhcPs
_) = forall a e. LocatedAn a e -> Located e
reLoc LIdP GhcPs
n
#endif

#if __GLASGOW_HASKELL__ < 900
setDefaultSpecificity :: LHsTyVarBndr pass -> GHC.LHsTyVarBndr pass
setDefaultSpecificity = id
#else
setDefaultSpecificity :: LHsTyVarBndr GhcPs -> GHC.LHsTyVarBndr Specificity GhcPs
setDefaultSpecificity :: LHsTyVarBndr GhcPs -> LHsTyVarBndr Specificity GhcPs
setDefaultSpecificity = forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @GhcPs forall a b. (a -> b) -> a -> b
$ \HsTyVarBndr () GhcPs
v -> case HsTyVarBndr () GhcPs
v of
    UserTyVar   XUserTyVar GhcPs
ext () LIdP GhcPs
name      -> forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar   XUserTyVar GhcPs
ext Specificity
SpecifiedSpec LIdP GhcPs
name
    KindedTyVar XKindedTyVar GhcPs
ext () LIdP GhcPs
name LHsType GhcPs
kind -> forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
ext Specificity
SpecifiedSpec LIdP GhcPs
name LHsType GhcPs
kind
#if __GLASGOW_HASKELL__ < 900
    XTyVarBndr  ext              -> XTyVarBndr  ext
#endif
#endif

{-------------------------------------------------------------------------------
  New functionality
-------------------------------------------------------------------------------}

-- | Generic comparison for (parts of) the AST
--
-- NOTE: Not all abstract types are given special treatment here; in particular,
-- types only used in type-checked code ignored. To extend/audit this function,
-- grep the @ghc@ source for @abstractConstr@. Without further extensions,
-- all values of these types are considered equal.
--
-- NOTE: Although @ghc@ declares the constructor of @Bag@ as abstract as well,
-- we don't actually need a special case here: the constructors will be
-- considered equal, but 'gfoldl' will traverse the /elements/ of the @Bag@
-- nonetheless, which is precisely what we want.
compareHs' :: GenericQ (GenericQ Bool)
compareHs' :: GenericQ (GenericQ Bool)
compareHs' a
x a
y
    | (Just ConLike
x', Just ConLike
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @ConLike     ConLike
x' ConLike
y'
    | (Just PatSyn
x', Just PatSyn
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @PatSyn      PatSyn
x' PatSyn
y'
    | (Just Class
x', Just Class
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @Class       Class
x' Class
y'
    | (Just DataCon
x', Just DataCon
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @DataCon     DataCon
x' DataCon
y'
    | (Just FastString
x', Just FastString
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @FastString  FastString
x' FastString
y'
    | (Just Module
x', Just Module
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @Module      Module
x' Module
y'
    | (Just ModuleName
x', Just ModuleName
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @ModuleName  ModuleName
x' ModuleName
y'
    | (Just Name
x', Just Name
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @Name        Name
x' Name
y'
    | (Just OccName
x', Just OccName
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @OccName     OccName
x' OccName
y'
    | (Just TyCon
x', Just TyCon
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @TyCon       TyCon
x' TyCon
y'
    | (Just UnitId
x', Just UnitId
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @UnitId      UnitId
x' UnitId
y'
    | (Just Var
x', Just Var
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @Var         Var
x' Var
y'
#if __GLASGOW_HASKELL__ >= 900
    | (Just Unit
x', Just Unit
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. Eq a => a -> a -> Bool
(==) @Unit        Unit
x' Unit
y'
#endif
    | (Just RealSrcSpan
x', Just RealSrcSpan
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. a -> a -> Bool
ignr @RealSrcSpan RealSrcSpan
x' RealSrcSpan
y'
    | (Just SrcSpan
x', Just SrcSpan
y') <- (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y) = forall a. a -> a -> Bool
ignr @SrcSpan     SrcSpan
x' SrcSpan
y'
    | Bool
otherwise = (forall a. Data a => a -> Constr
toConstr a
x forall a. Eq a => a -> a -> Bool
== forall a. Data a => a -> Constr
toConstr a
y)
               Bool -> Bool -> Bool
&& forall (t :: Type -> Type). Foldable t => t Bool -> Bool
and (forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
gzipWithQ GenericQ (GenericQ Bool)
compareHs' a
x a
y)
  where
    ignr :: a -> a -> Bool
    ignr :: forall a. a -> a -> Bool
ignr a
_ a
_ = Bool
True

-- | Compare two (parts) of a Haskell source tree for equality
--
-- The trees are compared for literal equality, but 'SrcSpan's are ignored.
compareHs :: Data a => a -> a -> Bool
compareHs :: forall a. Data a => a -> a -> Bool
compareHs a
x a
y = GenericQ (GenericQ Bool)
compareHs' a
x a
y

{-------------------------------------------------------------------------------
  Working with locations
-------------------------------------------------------------------------------}

class ToSrcSpan a where
  toSrcSpan :: a -> SrcSpan

instance ToSrcSpan SrcSpan where
  toSrcSpan :: SrcSpan -> SrcSpan
toSrcSpan = forall a. a -> a
id

#if __GLASGOW_HASKELL__ >= 902
instance ToSrcSpan (SrcSpanAnn' a) where
  toSrcSpan :: SrcSpanAnn' a -> SrcSpan
toSrcSpan = forall a. SrcSpanAnn' a -> SrcSpan
locA
#endif

instance ToSrcSpan l => ToSrcSpan (GenLocated l a) where
  toSrcSpan :: GenLocated l a -> SrcSpan
toSrcSpan (L l
l a
_) = forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan l
l

instance ToSrcSpan a => ToSrcSpan (NonEmpty a) where
  toSrcSpan :: NonEmpty a -> SrcSpan
toSrcSpan = forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head

-- | The instance for @[]@ is not ideal: we use 'noLoc' if the list is empty
--
-- For the use cases in this library, this is acceptable: typically these are
-- lists with elements for the record fields, and having slightly poorer error
-- messages for highly unusual "empty large" records is fine.
instance ToSrcSpan a => ToSrcSpan [a] where
   toSrcSpan :: [a] -> SrcSpan
toSrcSpan (a
a:[a]
_) = forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan a
a
   toSrcSpan []    = SrcSpan
noSrcSpan

class InheritLoc x a b | b -> a where
  inheritLoc :: x -> a -> b

instance ToSrcSpan x => InheritLoc x a (GenLocated SrcSpan a) where
  inheritLoc :: x -> a -> GenLocated SrcSpan a
inheritLoc = forall l e. l -> e -> GenLocated l e
L forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan

#if __GLASGOW_HASKELL__ >= 902
instance ToSrcSpan x => InheritLoc x a (GenLocated (SrcAnn ann) a) where
  inheritLoc :: x -> a -> GenLocated (SrcAnn ann) a
inheritLoc = forall l e. l -> e -> GenLocated l e
L forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn forall a. HasDefaultExt a => a
defExt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan
#endif

instance InheritLoc x [a]                  [a]                  where inheritLoc :: x -> [a] -> [a]
inheritLoc x
_ = forall a. a -> a
id
instance InheritLoc x Bool                 Bool                 where inheritLoc :: x -> Bool -> Bool
inheritLoc x
_ = forall a. a -> a
id
instance InheritLoc x (HsTupArg p)         (HsTupArg p)         where inheritLoc :: x -> HsTupArg p -> HsTupArg p
inheritLoc x
_ = forall a. a -> a
id
instance InheritLoc x (Pat p    )          (Pat p)              where inheritLoc :: x -> Pat p -> Pat p
inheritLoc x
_ = forall a. a -> a
id
instance InheritLoc x (HsLocalBindsLR p q) (HsLocalBindsLR p q) where inheritLoc :: x -> HsLocalBindsLR p q -> HsLocalBindsLR p q
inheritLoc x
_ = forall a. a -> a
id

withoutLoc :: InheritLoc SrcSpan a b => a -> b
withoutLoc :: forall a b. InheritLoc SrcSpan a b => a -> b
withoutLoc = forall x a b. InheritLoc x a b => x -> a -> b
inheritLoc SrcSpan
noSrcSpan

{-------------------------------------------------------------------------------
  Records
-------------------------------------------------------------------------------}

#if __GLASGOW_HASKELL__ >= 902
type RupdFlds = Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
#else
type RupdFlds = [LHsRecUpdField GhcPs]
#endif

-- | Pattern match against the @rupd_flds@ of @RecordUpd@
simpleRecordUpdates :: RupdFlds -> Maybe [(LRdrName, LHsExpr GhcPs)]

#if __GLASGOW_HASKELL__ >= 904

simpleRecordUpdates =
    \case
      Left  flds -> mapM (aux (isUnambigous  . unLoc)) flds
      Right flds -> mapM (aux (isSingleLabel . unLoc)) flds
  where
    aux :: forall lhs rhs.
         (lhs -> Maybe LRdrName)
      -> LHsFieldBind GhcPs lhs rhs
      -> Maybe (LRdrName, rhs)
    aux f (L _ (HsFieldBind { hfbLHS = lbl
                            , hfbRHS = val
                            , hfbPun = pun
                            })) = do
        guard $ not pun
        (, val) <$> f lbl

    isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName
    isUnambigous (Unambiguous _ name) = Just $ reLoc name
    isUnambigous _                    = Nothing

    isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName
    isSingleLabel (FieldLabelStrings labels) =
        case labels of
          [L _ (DotFieldOcc _ (L l label))] ->
            Just $ reLoc $ L l (Unqual $ mkVarOccFS label)
          _otherwise ->
            Nothing

#elif __GLASGOW_HASKELL__ == 902

simpleRecordUpdates :: RupdFlds -> Maybe [(Located RdrName, LHsExpr GhcPs)]
simpleRecordUpdates =
    \case
      Left  [LHsRecUpdField GhcPs]
flds -> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall lhs rhs.
(lhs -> Maybe (Located RdrName))
-> LHsRecField' GhcPs lhs rhs -> Maybe (Located RdrName, rhs)
aux AmbiguousFieldOcc GhcPs -> Maybe (Located RdrName)
isUnambigous)  [LHsRecUpdField GhcPs]
flds
      Right [LHsRecUpdProj GhcPs]
flds -> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall lhs rhs.
(lhs -> Maybe (Located RdrName))
-> LHsRecField' GhcPs lhs rhs -> Maybe (Located RdrName, rhs)
aux FieldLabelStrings GhcPs -> Maybe (Located RdrName)
isSingleLabel) [LHsRecUpdProj GhcPs]
flds
  where
    aux :: forall lhs rhs.
         (lhs -> Maybe LRdrName)
      -> LHsRecField' GhcPs lhs rhs
      -> Maybe (LRdrName, rhs)
    aux :: forall lhs rhs.
(lhs -> Maybe (Located RdrName))
-> LHsRecField' GhcPs lhs rhs -> Maybe (Located RdrName, rhs)
aux lhs -> Maybe (Located RdrName)
f (L SrcSpanAnnA
_ (HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = L SrcSpan
_ lhs
lbl
                           , hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = rhs
val
                           , hsRecPun :: forall id arg. HsRecField' id arg -> Bool
hsRecPun      = Bool
pun
                           })) = do
        forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
pun
        (, rhs
val) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> lhs -> Maybe (Located RdrName)
f lhs
lbl

    isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName
    isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe (Located RdrName)
isUnambigous (Unambiguous XUnambiguous GhcPs
_ LocatedAn NameAnn RdrName
name) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a e. LocatedAn a e -> Located e
reLoc LocatedAn NameAnn RdrName
name
    isUnambigous AmbiguousFieldOcc GhcPs
_                    = forall a. Maybe a
Nothing

    isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName
    isSingleLabel :: FieldLabelStrings GhcPs -> Maybe (Located RdrName)
isSingleLabel (FieldLabelStrings [Located (HsFieldLabel GhcPs)]
labels) =
        case [Located (HsFieldLabel GhcPs)]
labels of
          [L SrcSpan
_ (HsFieldLabel XCHsFieldLabel GhcPs
_ (L SrcSpan
l FastString
label))] ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
l (OccName -> RdrName
Unqual forall a b. (a -> b) -> a -> b
$ FastString -> OccName
mkVarOccFS FastString
label)
          [Located (HsFieldLabel GhcPs)]
_otherwise ->
            forall a. Maybe a
Nothing

#else

simpleRecordUpdates =
     mapM (aux isUnambigous)
  where
    aux :: forall lhs rhs.
         (lhs -> Maybe LRdrName)
      -> LHsRecField' lhs rhs
      -> Maybe (LRdrName, rhs)
    aux f (L _ (HsRecField { hsRecFieldLbl = L _ lbl
                           , hsRecFieldArg = val
                           , hsRecPun      = pun
                           })) = do
        guard $ not pun
        (, val) <$> f lbl

    isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName
    isUnambigous (Unambiguous _ name) = Just $ reLoc name
    isUnambigous _                    = Nothing

#endif