{-# 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

#if __GLASGOW_HASKELL__ >= 906
import Language.Haskell.Syntax.Basic (FieldLabelString (..))
import qualified GHC.Types.Basic
#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
ModuleName -> Maybe FastString -> OccName -> Hsc Name
lookupOccName ModuleName
modl Maybe FastString
pkg (OccName -> Hsc Name) -> (String -> OccName) -> String -> Hsc Name
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
ModuleName -> Maybe FastString -> OccName -> Hsc Name
lookupOccName ModuleName
modl Maybe FastString
pkg (OccName -> Hsc Name) -> (String -> OccName) -> String -> Hsc Name
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 :: PkgQual
pkgq = UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
renamePkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env) ModuleName
modlName Maybe FastString
mPkgName
#else
    let pkgq :: Maybe FastString
        pkgq = mPkgName
#endif

    FindResult
mModl <- IO FindResult -> Hsc FindResult
forall a. IO a -> Hsc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> Hsc FindResult)
-> IO FindResult -> Hsc FindResult
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
env ModuleName
modlName PkgQual
pkgq
    case FindResult
mModl of
      Found ModLocation
_ Module
modl -> IO Name -> Hsc Name
forall a. IO a -> Hsc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Name -> Hsc Name) -> IO Name -> Hsc Name
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> OccName -> IO Name
lookupOrigIO HscEnv
env Module
modl OccName
name
      FindResult
_otherwise   -> String -> Hsc Name
forall a. HasCallStack => String -> a
error (String -> Hsc Name) -> String -> Hsc Name
forall a b. (a -> b) -> a -> b
$ [String] -> String
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
pkg
        , String
"."
        ]

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

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

-- | Optionally @qualified@ import declaration
importDecl :: Bool -> ModuleName -> LImportDecl GhcPs
importDecl :: Bool -> ModuleName -> LImportDecl GhcPs
importDecl Bool
qualified ModuleName
name = Located (ImportDecl GhcPs)
-> LocatedAn AnnListItem (ImportDecl GhcPs)
forall e ann. Located e -> LocatedAn ann e
reLocA (Located (ImportDecl GhcPs)
 -> LocatedAn AnnListItem (ImportDecl GhcPs))
-> Located (ImportDecl GhcPs)
-> LocatedAn AnnListItem (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> Located (ImportDecl GhcPs)
forall e. e -> Located e
noLoc (ImportDecl GhcPs -> Located (ImportDecl GhcPs))
-> ImportDecl GhcPs -> Located (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ImportDecl {
#if __GLASGOW_HASKELL__ < 906
      ideclExt       = defExt
#else
      ideclExt :: XCImportDecl GhcPs
ideclExt       = XImportDeclPass {
                           ideclAnn :: EpAnn EpAnnImportDecl
ideclAnn        = EpAnn EpAnnImportDecl
forall a. HasDefaultExt a => a
defExt
                         , ideclSourceText :: SourceText
ideclSourceText = SourceText
NoSourceText
                         , ideclImplicit :: Bool
ideclImplicit   = Bool
False
                         }
#endif
#if __GLASGOW_HASKELL__ < 906
    , ideclSourceSrc = NoSourceText
#endif
    , ideclName :: XRec GhcPs ModuleName
ideclName      = Located ModuleName -> LocatedAn AnnListItem ModuleName
forall e ann. Located e -> LocatedAn ann e
reLocA (Located ModuleName -> LocatedAn AnnListItem ModuleName)
-> Located ModuleName -> LocatedAn AnnListItem ModuleName
forall a b. (a -> b) -> a -> b
$ ModuleName -> Located ModuleName
forall e. e -> Located e
noLoc ModuleName
name
#if __GLASGOW_HASKELL__ >= 904
    , ideclPkgQual :: ImportDeclPkgQual GhcPs
ideclPkgQual   = ImportDeclPkgQual GhcPs
RawPkgQual
NoRawPkgQual
#else
    , ideclPkgQual   = Nothing
#endif
    , ideclSafe :: Bool
ideclSafe      = Bool
False
#if __GLASGOW_HASKELL__ < 906
    , ideclImplicit  = False
#endif
    , ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclAs        = Maybe (XRec GhcPs ModuleName)
Maybe (LocatedAn AnnListItem ModuleName)
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ < 906
    , ideclHiding    = Nothing
#endif
    , ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = if Bool
qualified then ImportDeclQualifiedStyle
QualifiedPre else ImportDeclQualifiedStyle
NotQualified
#if __GLASGOW_HASKELL__ < 900
    , ideclSource    = False
#else
    , ideclSource :: IsBootInterface
ideclSource    = IsBootInterface
NotBoot
#endif
#if __GLASGOW_HASKELL__ >= 906
    , ideclImportList :: Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
ideclImportList = Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
Maybe
  (ImportListInterpretation,
   GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. Maybe a
Nothing
#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 = XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConPatDetails GhcPs
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
EpAnn [AddEpAnn]
forall a. HasDefaultExt a => a
defExt (Located RdrName -> LocatedAn NameAnn RdrName
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
mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
mkFunBind (Located RdrName -> LocatedAn NameAnn RdrName
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

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

#if __GLASGOW_HASKELL__ >= 906
type LHsModule = Located (HsModule GhcPs)
#else
type LHsModule = Located HsModule
#endif
type LRdrName  = Located RdrName

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

#if __GLASGOW_HASKELL__ < 904
type NameCacheIO = IORef NameCache

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

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

hscNameCacheIO :: HscEnv -> NameCacheIO
hscNameCacheIO :: HscEnv -> NameCache
hscNameCacheIO = HscEnv -> NameCache
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

instance HasDefaultExt NoExtField where
  defExt :: NoExtField
defExt = NoExtField
noExtField

#if __GLASGOW_HASKELL__ >= 906
instance HasDefaultExt (LayoutInfo GhcPs) where
  defExt :: LayoutInfo GhcPs
defExt = LayoutInfo GhcPs
forall pass. LayoutInfo pass
NoLayoutInfo
instance HasDefaultExt GHC.Types.Basic.Origin where
  defExt :: Origin
defExt = Origin
Generated
instance HasDefaultExt SourceText where
  defExt :: SourceText
defExt = SourceText
NoSourceText
#elif __GLASGOW_HASKELL__ >= 900
instance HasDefaultExt LayoutInfo where
  defExt = NoLayoutInfo
#endif

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

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

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

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

instance HasDefaultExt EpAnnComments where
  defExt :: EpAnnComments
defExt = EpAnn Any -> EpAnnComments
forall an. EpAnn an -> EpAnnComments
epAnnComments EpAnn Any
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 a
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 ext = HsFunTy ext (HsUnrestrictedArrow NormalSyntax)
#else
hsFunTy :: XFunTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
hsFunTy XFunTy GhcPs
ext = XFunTy GhcPs
-> HsArrow GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
ext (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs
forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow (TokenLocation
-> HsUniToken "->" "\8594"
-> GenLocated TokenLocation (HsUniToken "->" "\8594")
forall l e. l -> e -> GenLocated l e
L TokenLocation
NoTokenLoc HsUniToken "->" "\8594"
forall (tok :: Symbol) (utok :: Symbol). HsUniToken tok utok
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 = XUserTyVar GhcPs -> () -> LIdP GhcPs -> HsTyVarBndr () GhcPs
forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
ext () (Located RdrName -> LocatedAn NameAnn RdrName
forall e ann. Located e -> LocatedAn ann e
reLocA Located (IdP GhcPs)
Located RdrName
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 = XKindedTyVar GhcPs
-> () -> LIdP GhcPs -> LHsType GhcPs -> HsTyVarBndr () GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
ext () (Located RdrName -> LocatedAn NameAnn RdrName
forall e ann. Located e -> LocatedAn ann e
reLocA Located (IdP GhcPs)
Located RdrName
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  ) = LocatedAn NameAnn RdrName -> Located RdrName
forall a e. LocatedAn a e -> Located e
reLoc LIdP GhcPs
LocatedAn NameAnn RdrName
n
hsTyVarLName (KindedTyVar XKindedTyVar GhcPs
_ ()
_ LIdP GhcPs
n LHsType GhcPs
_) = LocatedAn NameAnn RdrName -> Located RdrName
forall a e. LocatedAn a e -> Located e
reLoc LIdP GhcPs
LocatedAn NameAnn RdrName
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 ((HsTyVarBndr () GhcPs -> HsTyVarBndr Specificity GhcPs)
 -> LHsTyVarBndr GhcPs -> LHsTyVarBndr Specificity GhcPs)
-> (HsTyVarBndr () GhcPs -> HsTyVarBndr Specificity GhcPs)
-> LHsTyVarBndr GhcPs
-> LHsTyVarBndr Specificity GhcPs
forall a b. (a -> b) -> a -> b
$ \HsTyVarBndr () GhcPs
v -> case HsTyVarBndr () GhcPs
v of
    UserTyVar   XUserTyVar GhcPs
ext () LIdP GhcPs
name      -> XUserTyVar GhcPs
-> Specificity -> LIdP GhcPs -> HsTyVarBndr Specificity GhcPs
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 -> XKindedTyVar GhcPs
-> Specificity
-> LIdP GhcPs
-> LHsType GhcPs
-> HsTyVarBndr Specificity GhcPs
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') <- (a -> Maybe ConLike
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe ConLike
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') <- (a -> Maybe PatSyn
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe PatSyn
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') <- (a -> Maybe Class
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe Class
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') <- (a -> Maybe DataCon
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe DataCon
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') <- (a -> Maybe FastString
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe FastString
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') <- (a -> Maybe Module
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe Module
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') <- (a -> Maybe ModuleName
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe ModuleName
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') <- (a -> Maybe Name
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe Name
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') <- (a -> Maybe OccName
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe OccName
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') <- (a -> Maybe TyCon
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe TyCon
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') <- (a -> Maybe UnitId
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe UnitId
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') <- (a -> Maybe Var
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe Var
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') <- (a -> Maybe Unit
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe Unit
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') <- (a -> Maybe RealSrcSpan
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe RealSrcSpan
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') <- (a -> Maybe SrcSpan
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x, a -> Maybe SrcSpan
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 = (a -> Constr
forall a. Data a => a -> Constr
toConstr a
x Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Constr
forall a. Data a => a -> Constr
toConstr a
y)
               Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
and (GenericQ (GenericQ Bool) -> GenericQ (GenericQ [Bool])
forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
gzipWithQ a -> a -> Bool
a -> GenericQ Bool
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 = a -> GenericQ Bool
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 = SrcSpan -> SrcSpan
forall a. a -> a
id

#if __GLASGOW_HASKELL__ >= 902
instance ToSrcSpan (SrcSpanAnn' a) where
  toSrcSpan :: SrcSpanAnn' a -> SrcSpan
toSrcSpan = SrcSpanAnn' a -> SrcSpan
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
_) = l -> SrcSpan
forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan l
l

instance ToSrcSpan a => ToSrcSpan (NonEmpty a) where
  toSrcSpan :: NonEmpty a -> SrcSpan
toSrcSpan = a -> SrcSpan
forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan (a -> SrcSpan) -> (NonEmpty a -> a) -> NonEmpty a -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> a
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]
_) = a -> SrcSpan
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 = SrcSpan -> a -> GenLocated SrcSpan a
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> a -> GenLocated SrcSpan a)
-> (x -> SrcSpan) -> x -> a -> GenLocated SrcSpan a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> SrcSpan
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 = SrcAnn ann -> a -> GenLocated (SrcAnn ann) a
forall l e. l -> e -> GenLocated l e
L (SrcAnn ann -> a -> GenLocated (SrcAnn ann) a)
-> (x -> SrcAnn ann) -> x -> a -> GenLocated (SrcAnn ann) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnn ann -> SrcSpan -> SrcAnn ann
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn ann
forall a. HasDefaultExt a => a
defExt (SrcSpan -> SrcAnn ann) -> (x -> SrcSpan) -> x -> SrcAnn ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> SrcSpan
forall a. ToSrcSpan a => a -> SrcSpan
toSrcSpan
#endif

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

withoutLoc :: InheritLoc SrcSpan a b => a -> b
withoutLoc :: forall a b. InheritLoc SrcSpan a b => a -> b
withoutLoc = SrcSpan -> a -> b
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 :: RupdFlds -> Maybe [(Located RdrName, LHsExpr GhcPs)]
simpleRecordUpdates =
    \case
      Left  [LHsRecUpdField GhcPs]
flds -> (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Maybe (Located RdrName, GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe [(Located RdrName, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ((GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs)
 -> Maybe (Located RdrName))
-> LHsFieldBind
     GhcPs
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Located RdrName, GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall lhs rhs.
(lhs -> Maybe (Located RdrName))
-> LHsFieldBind GhcPs lhs rhs -> Maybe (Located RdrName, rhs)
aux (AmbiguousFieldOcc GhcPs -> Maybe (Located RdrName)
isUnambigous  (AmbiguousFieldOcc GhcPs -> Maybe (Located RdrName))
-> (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs)
    -> AmbiguousFieldOcc GhcPs)
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs)
-> Maybe (Located RdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs)
-> AmbiguousFieldOcc GhcPs
forall l e. GenLocated l e -> e
unLoc)) [LHsRecUpdField GhcPs]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds
      Right [LHsRecUpdProj GhcPs]
flds -> (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Maybe (Located RdrName, GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe [(Located RdrName, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ((GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcPs)
 -> Maybe (Located RdrName))
-> LHsFieldBind
     GhcPs
     (GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Located RdrName, GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall lhs rhs.
(lhs -> Maybe (Located RdrName))
-> LHsFieldBind GhcPs lhs rhs -> Maybe (Located RdrName, rhs)
aux (FieldLabelStrings GhcPs -> Maybe (Located RdrName)
isSingleLabel (FieldLabelStrings GhcPs -> Maybe (Located RdrName))
-> (GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcPs)
    -> FieldLabelStrings GhcPs)
-> GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcPs)
-> Maybe (Located RdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcPs)
-> FieldLabelStrings GhcPs
forall l e. GenLocated l e -> e
unLoc)) [LHsRecUpdProj GhcPs]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds
  where
    aux :: forall lhs rhs.
         (lhs -> Maybe LRdrName)
      -> LHsFieldBind GhcPs lhs rhs
      -> Maybe (LRdrName, rhs)
    aux :: forall lhs rhs.
(lhs -> Maybe (Located RdrName))
-> LHsFieldBind GhcPs lhs rhs -> Maybe (Located RdrName, rhs)
aux lhs -> Maybe (Located RdrName)
f (L SrcSpanAnnA
_ (HsFieldBind { hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = lhs
lbl
                            , hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = rhs
val
                            , hfbPun :: forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun = Bool
pun
                            })) = do
        Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
pun
        (, rhs
val) (Located RdrName -> (Located RdrName, rhs))
-> Maybe (Located RdrName) -> Maybe (Located RdrName, rhs)
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
_ XRec GhcPs RdrName
name) = Located RdrName -> Maybe (Located RdrName)
forall a. a -> Maybe a
Just (Located RdrName -> Maybe (Located RdrName))
-> Located RdrName -> Maybe (Located RdrName)
forall a b. (a -> b) -> a -> b
$ LocatedAn NameAnn RdrName -> Located RdrName
forall a e. LocatedAn a e -> Located e
reLoc XRec GhcPs RdrName
LocatedAn NameAnn RdrName
name
    isUnambigous AmbiguousFieldOcc GhcPs
_                    = Maybe (Located RdrName)
forall a. Maybe a
Nothing

    isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName
    isSingleLabel :: FieldLabelStrings GhcPs -> Maybe (Located RdrName)
isSingleLabel (FieldLabelStrings [XRec GhcPs (DotFieldOcc GhcPs)]
labels) =
        case [XRec GhcPs (DotFieldOcc GhcPs)]
labels of
#if __GLASGOW_HASKELL__ >= 906
          [L SrcAnn NoEpAnns
_ (DotFieldOcc XCDotFieldOcc GhcPs
_ (L SrcAnn NameAnn
l (FieldLabelString FastString
label)))] ->
#else
          [L _ (DotFieldOcc _ (L l label))] ->
#endif
            Located RdrName -> Maybe (Located RdrName)
forall a. a -> Maybe a
Just (Located RdrName -> Maybe (Located RdrName))
-> Located RdrName -> Maybe (Located RdrName)
forall a b. (a -> b) -> a -> b
$ LocatedAn NameAnn RdrName -> Located RdrName
forall a e. LocatedAn a e -> Located e
reLoc (LocatedAn NameAnn RdrName -> Located RdrName)
-> LocatedAn NameAnn RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ SrcAnn NameAnn -> RdrName -> LocatedAn NameAnn RdrName
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
l (OccName -> RdrName
Unqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ FastString -> OccName
mkVarOccFS FastString
label)
          [XRec GhcPs (DotFieldOcc GhcPs)]
_otherwise ->
            Maybe (Located RdrName)
forall a. Maybe a
Nothing

#elif __GLASGOW_HASKELL__ == 902

simpleRecordUpdates =
    \case
      Left  flds -> mapM (aux isUnambigous)  flds
      Right flds -> mapM (aux isSingleLabel) flds
  where
    aux :: forall lhs rhs.
         (lhs -> Maybe LRdrName)
      -> LHsRecField' GhcPs 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

    isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName
    isSingleLabel (FieldLabelStrings labels) =
        case labels of
          [L _ (HsFieldLabel _ (L l label))] ->
            Just $ L l (Unqual $ mkVarOccFS label)
          _otherwise ->
            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