{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Record.Internal.GHC.Shim (
lookupVarName
, lookupTcName
, importDecl
, conPat
, mkFunBind
, HsModule
, LHsModule
, LRdrName
, pattern GHC.HsModule
#if __GLASGOW_HASKELL__ < 902
, reLoc
, reLocA
, noLocA
#endif
, HasDefaultExt(..)
, withDefExt
#if __GLASGOW_HASKELL__ >= 900
, HsTyVarBndr
, LHsTyVarBndr
#endif
, hsFunTy
, userTyVar
, kindedTyVar
, hsTyVarLName
, setDefaultSpecificity
, ToSrcSpan(..)
, InheritLoc(..)
, withoutLoc
, compareHs
, NameCacheIO
, hscNameCacheIO
, takeUniqFromNameCacheIO
, simpleRecordUpdates
#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
lookupVarName ::
HasCallStack
=> ModuleName
-> Maybe FastString
-> 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
-> 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
-> 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
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
#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
#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
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
#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
#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
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
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
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
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
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
#if __GLASGOW_HASKELL__ >= 902
type RupdFlds = Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
#else
type RupdFlds = [LHsRecUpdField GhcPs]
#endif
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