{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns, OverloadedStrings, LambdaCase #-}
{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-}
module RecordDotPreprocessor(plugin) where
import Data.Generics.Uniplate.Data
import Data.List.Extra
import Data.Tuple.Extra
import Compat
import qualified GHC
#if __GLASGOW_HASKELL__ > 901
import qualified GHC.Types.SourceText as GHC
#elif __GLASGOW_HASKELL__ >= 900
import qualified GHC.Driver.Types as GHC
#endif
#if __GLASGOW_HASKELL__ < 900
import Bag
import qualified GhcPlugins as GHC
import qualified HscMain
import qualified PrelNames as GHC
import SrcLoc
#else
import GHC.Data.Bag
import qualified GHC.Driver.Plugins as GHC
import qualified GHC.Driver.Main as HscMain
import qualified GHC.Builtin.Names as GHC
import qualified GHC.Plugins as GHC
import GHC.Types.SrcLoc
#endif
plugin :: GHC.Plugin
plugin :: Plugin
plugin = Plugin
GHC.defaultPlugin
{ parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
GHC.parsedResultAction = \[CommandLineOption]
_cliOptions ModSummary
_modSummary -> forall {a}. a -> a
ignoreMessages HsParsedModule -> Hsc HsParsedModule
parsedResultAction
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
GHC.pluginRecompile = [CommandLineOption] -> IO PluginRecompile
GHC.purePlugin
}
where
#if __GLASGOW_HASKELL__ >= 904
ignoreMessages :: (HsParsedModule -> GHC.Hsc HsParsedModule) -> GHC.ParsedResult -> GHC.Hsc GHC.ParsedResult
ignoreMessages f (GHC.ParsedResult modl msgs) =
(\modl' -> GHC.ParsedResult modl' msgs) <$> f modl
#else
ignoreMessages :: a -> a
ignoreMessages = forall {a}. a -> a
id
#endif
parsedResultAction :: HsParsedModule -> Hsc HsParsedModule
parsedResultAction HsParsedModule
x = do
HscEnv
hscenv <- HscEnv -> HscEnv
dropRnTraceFlags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hsc HscEnv
HscMain.getHscEnv
UniqSupply
uniqSupply <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (Char -> IO UniqSupply
GHC.mkSplitUniqSupply Char
'0')
IORef UniqSupply
uniqSupplyRef <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef UniqSupply
uniqSupply
let ?hscenv = HscEnv
hscenv
let ?uniqSupply = IORef UniqSupply
uniqSupplyRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsParsedModule
x{hpm_module :: Located HsModule
GHC.hpm_module = PluginEnv => HsModule -> HsModule
onModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsParsedModule -> Located HsModule
GHC.hpm_module HsParsedModule
x}
setL :: SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL :: forall e. SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL SrcSpan
l (L SrcSpan
_ e
x) = forall l e. l -> e -> GenLocated l e
L SrcSpan
l e
x
mod_records :: GHC.ModuleName
mod_records :: ModuleName
mod_records = CommandLineOption -> ModuleName
GHC.mkModuleName CommandLineOption
"GHC.Records.Extra"
var_HasField, var_hasField, var_getField, var_setField, var_dot :: GHC.RdrName
var_HasField :: RdrName
var_HasField = ModuleName -> OccName -> RdrName
GHC.mkRdrQual ModuleName
mod_records forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkClsOcc CommandLineOption
"HasField"
var_hasField :: RdrName
var_hasField = OccName -> RdrName
GHC.mkRdrUnqual forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"hasField"
var_getField :: RdrName
var_getField = ModuleName -> OccName -> RdrName
GHC.mkRdrQual ModuleName
mod_records forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"getField"
var_setField :: RdrName
var_setField = ModuleName -> OccName -> RdrName
GHC.mkRdrQual ModuleName
mod_records forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"setField"
var_dot :: RdrName
var_dot = OccName -> RdrName
GHC.mkRdrUnqual forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"."
#if __GLASGOW_HASKELL__ >= 904
mod_base_records :: GHC.ModuleName
mod_base_records = GHC.mkModuleName "GHC.Records"
var_base_getField :: GHC.RdrName
var_base_getField = GHC.mkRdrQual mod_base_records $ GHC.mkVarOcc "getField"
#endif
onModule :: PluginEnv => Module -> Module
onModule :: PluginEnv => HsModule -> HsModule
onModule HsModule
x = HsModule
x { hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs] -> [LImportDecl GhcPs]
onImports forall a b. (a -> b) -> a -> b
$ HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
x
, hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PluginEnv => Maybe ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs]
onDecl (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule -> Maybe (LocatedA ModuleName)
hsmodName HsModule
x)) forall a b. (a -> b) -> a -> b
$ HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
x
}
onImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
onImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
onImports = forall a. [a] -> [a] -> [a]
(++) [
ModuleName -> LImportDecl GhcPs
qualifiedImplicitImport ModuleName
mod_records
#if __GLASGOW_HASKELL__ >= 904
, qualifiedImplicitImport mod_base_records
#endif
]
instanceTemplate :: FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs
instanceTemplate :: FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs
instanceTemplate FieldOcc GhcPs
selector HsType GhcPs
record HsType GhcPs
field = forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ forall pass.
XCClsInstDecl pass
-> LHsSigType pass
-> LHsBinds pass
-> [LSig pass]
-> [LTyFamInstDecl pass]
-> [LDataFamInstDecl pass]
-> Maybe (XRec pass OverlapMode)
-> ClsInstDecl pass
ClsInstDecl
#if __GLASGOW_HASKELL__ >= 902
(forall a. WithoutExt a => a
noE, forall a. Monoid a => a
mempty) (XRec GhcPs (HsType GhcPs) -> LHsSigType GhcPs
hsTypeToHsSigType forall a b. (a -> b) -> a -> b
$ forall e ann. Located e -> LocatedAn ann e
reLocA Located (HsType GhcPs)
typ)
#else
noE (HsIB noE typ)
#endif
(forall a. a -> Bag a
unitBag LHsBindLR GhcPs GhcPs
has) [] [] [] forall a. Maybe a
Nothing
where
typ' :: HsType GhcPs -> LHsType GhcPs
typ' :: HsType GhcPs -> XRec GhcPs (HsType GhcPs)
typ' HsType GhcPs
a = forall (p :: Pass).
LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
mkHsAppTys
(forall a b. WithoutLoc a b => a -> b
noL (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. WithoutExt a => a
noE PromotionFlag
GHC.NotPromoted (forall a b. WithoutLoc a b => a -> b
noL RdrName
var_HasField)))
[XRec GhcPs (HsType GhcPs)
fieldNameAsType
,forall a b. WithoutLoc a b => a -> b
noL HsType GhcPs
record
,forall a b. WithoutLoc a b => a -> b
noL HsType GhcPs
a
]
typ :: Located (HsType GhcPs)
typ = forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs
makeEqQualTy HsType GhcPs
field (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> XRec GhcPs (HsType GhcPs)
typ')
fieldNameAsType :: LHsType GhcPs
fieldNameAsType :: XRec GhcPs (HsType GhcPs)
fieldNameAsType = forall a b. WithoutLoc a b => a -> b
noL (forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit forall a. WithoutExt a => a
noE (SourceText -> FastString -> HsTyLit
HsStrTy SourceText
GHC.NoSourceText (OccName -> FastString
GHC.occNameFS forall a b. (a -> b) -> a -> b
$ forall name. HasOccName name => name -> OccName
GHC.occName forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall pass. FieldOcc pass -> GenLocated SrcSpanAnnN RdrName
rdrNameFieldOcc FieldOcc GhcPs
selector)))
has :: LHsBindLR GhcPs GhcPs
has :: LHsBindLR GhcPs GhcPs
has = forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ Located RdrName -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsBind GhcPs
newFunBind (forall a b. WithoutLoc a b => a -> b
noL RdrName
var_hasField) (Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)
mg1 Match GhcPs (LHsExpr GhcPs)
eqn)
where
eqn :: Match GhcPs (LHsExpr GhcPs)
eqn :: Match GhcPs (LHsExpr GhcPs)
eqn = Match
{ m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = forall a. WithoutExt a => a
noE
, m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = forall p.
LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs (forall a b. WithoutLoc a b => a -> b
noL RdrName
var_hasField) LexicalFixity
GHC.Prefix SrcStrictness
NoSrcStrict
, m_pats :: [LPat GhcPs]
m_pats = [Pat GhcPs] -> [LPat GhcPs]
compat_m_pats [forall p. XVarPat p -> LIdP p -> Pat p
VarPat forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ forall a b. WithoutLoc a b => a -> b
noL RdrName
vR]
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs forall a. WithoutExt a => a
noE [forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. WithoutExt a => a
noE [] forall a b. (a -> b) -> a -> b
$ forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple forall a. WithoutExt a => a
noE [ forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present forall a. WithoutExt a => a
noE LHsExpr GhcPs
set, forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present forall a. WithoutExt a => a
noE GenLocated SrcSpanAnnA (HsExpr GhcPs)
get] Boxity
GHC.Boxed] (forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds forall a. WithoutExt a => a
noE)
}
set :: LHsExpr GhcPs
set = forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)
mg1 Match
{ m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext = forall a. WithoutExt a => a
noE
, m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt = forall p. HsMatchContext p
LambdaExpr
, m_pats :: [LPat GhcPs]
m_pats = [Pat GhcPs] -> [LPat GhcPs]
compat_m_pats [forall p. XVarPat p -> LIdP p -> Pat p
VarPat forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ forall a b. WithoutLoc a b => a -> b
noL RdrName
vX]
, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss = forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs forall a. WithoutExt a => a
noE [forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. WithoutExt a => a
noE [] forall a b. (a -> b) -> a -> b
$ forall a b. WithoutLoc a b => a -> b
noL HsExpr GhcPs
update] (forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds forall a. WithoutExt a => a
noE)
}
update :: HsExpr GhcPs
update :: HsExpr GhcPs
update = forall p.
XRecordUpd p
-> LHsExpr p
-> Either [LHsRecUpdField p] [LHsRecUpdProj p]
-> HsExpr p
RecordUpd forall a. WithoutExt a => a
noE (forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
GHC.HsVar forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ forall a b. WithoutLoc a b => a -> b
noL RdrName
vR)
#if __GLASGOW_HASKELL__ >= 902
forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
#endif
#if __GLASGOW_HASKELL__ >= 904
[noL $ HsFieldBind
#else
[forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall id arg.
XHsRecField id -> Located id -> arg -> Bool -> HsRecField' id arg
HsRecField
#endif
#if __GLASGOW_HASKELL__ >= 902
forall a. WithoutExt a => a
noE
#endif
(forall a b. WithoutLoc a b => a -> b
noL (forall pass.
XUnambiguous pass
-> GenLocated SrcSpanAnnN RdrName -> AmbiguousFieldOcc pass
Unambiguous forall a. WithoutExt a => a
noE (forall pass. FieldOcc pass -> GenLocated SrcSpanAnnN RdrName
rdrNameFieldOcc FieldOcc GhcPs
selector))) (forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
GHC.HsVar forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ forall a b. WithoutLoc a b => a -> b
noL RdrName
vX) Bool
False]
#if __GLASGOW_HASKELL__ >= 904
get :: LHsExpr GhcPs
get =
(noL $ GHC.HsVar noE $ noL $ var_base_getField)
`mkAppType`
fieldNameAsType
`mkApp`
(noL $ GHC.HsVar noE $ noL $ vR)
#else
get :: LHsExpr GhcPs
get = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp
(LHsExpr GhcPs -> LHsExpr GhcPs
mkParen forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> XRec GhcPs (HsType GhcPs) -> LHsExpr GhcPs
mkTypeAnn (forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
GHC.HsVar forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ forall pass. FieldOcc pass -> GenLocated SrcSpanAnnN RdrName
rdrNameFieldOcc FieldOcc GhcPs
selector) (XRec GhcPs (HsType GhcPs)
-> XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
mkFunTy (forall a b. WithoutLoc a b => a -> b
noL HsType GhcPs
record) (forall a b. WithoutLoc a b => a -> b
noL HsType GhcPs
field)))
(forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
GHC.HsVar forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ forall a b. WithoutLoc a b => a -> b
noL RdrName
vR)
#endif
mg1 :: Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)
mg1 :: Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)
mg1 Match GhcPs (LHsExpr GhcPs)
x = forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
MG forall a. WithoutExt a => a
noE (forall a b. WithoutLoc a b => a -> b
noL [forall a b. WithoutLoc a b => a -> b
noL Match GhcPs (LHsExpr GhcPs)
x]) Origin
GHC.Generated
vR :: RdrName
vR = OccName -> RdrName
GHC.mkRdrUnqual forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"r"
vX :: RdrName
vX = OccName -> RdrName
GHC.mkRdrUnqual forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"x"
onDecl :: PluginEnv => Maybe GHC.ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs]
onDecl :: PluginEnv => Maybe ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs]
onDecl Maybe ModuleName
modName o :: LHsDecl GhcPs
o@(L SrcSpanAnnA
_ (GHC.TyClD XTyClD GhcPs
_ TyClDecl GhcPs
x)) = LHsDecl GhcPs
o forall a. a -> [a] -> [a]
:
[ forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XInstD p -> InstDecl p -> HsDecl p
InstD forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs
instanceTemplate FieldOcc GhcPs
field (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
record) (HsType GhcPs -> HsType GhcPs
unbang HsType GhcPs
typ)
| let fields :: [(XRec GhcPs (HsType GhcPs), IdP GhcPs, FieldOcc GhcPs,
HsType GhcPs)]
fields = forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (\(XRec GhcPs (HsType GhcPs)
_,IdP GhcPs
_,FieldOcc GhcPs
x,HsType GhcPs
_) -> FastString -> NonDetFastString
mkNonDetFastString forall a b. (a -> b) -> a -> b
$ OccName -> FastString
GHC.occNameFS forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
GHC.rdrNameOcc forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall pass. FieldOcc pass -> GenLocated SrcSpanAnnN RdrName
rdrNameFieldOcc FieldOcc GhcPs
x) forall a b. (a -> b) -> a -> b
$ PluginEnv =>
Maybe ModuleName
-> TyClDecl GhcPs
-> [(XRec GhcPs (HsType GhcPs), IdP GhcPs, FieldOcc GhcPs,
HsType GhcPs)]
getFields Maybe ModuleName
modName TyClDecl GhcPs
x
, (GenLocated SrcSpanAnnA (HsType GhcPs)
record, RdrName
_, FieldOcc GhcPs
field, HsType GhcPs
typ) <- [(GenLocated SrcSpanAnnA (HsType GhcPs), RdrName, FieldOcc GhcPs,
HsType GhcPs)]
fields]
onDecl Maybe ModuleName
_ LHsDecl GhcPs
x = [forall from to. Biplate from to => (to -> to) -> from -> from
descendBi LHsExpr GhcPs -> LHsExpr GhcPs
onExp LHsDecl GhcPs
x]
unbang :: HsType GhcPs -> HsType GhcPs
unbang :: HsType GhcPs -> HsType GhcPs
unbang (HsBangTy XBangTy GhcPs
_ HsSrcBang
_ XRec GhcPs (HsType GhcPs)
x) = forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsType GhcPs)
x
unbang HsType GhcPs
x = HsType GhcPs
x
getFields :: PluginEnv => Maybe GHC.ModuleName -> TyClDecl GhcPs -> [(LHsType GhcPs, IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]
getFields :: PluginEnv =>
Maybe ModuleName
-> TyClDecl GhcPs
-> [(XRec GhcPs (HsType GhcPs), IdP GhcPs, FieldOcc GhcPs,
HsType GhcPs)]
getFields Maybe ModuleName
modName DataDecl{tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn=HsDataDefn{HsDeriving GhcPs
[LConDecl GhcPs]
Maybe (LHsContext GhcPs)
Maybe (XRec GhcPs (HsType GhcPs))
Maybe (XRec GhcPs CType)
NewOrData
XCHsDataDefn GhcPs
dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_ext :: forall pass. HsDataDefn pass -> XCHsDataDefn pass
dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_derivs :: HsDeriving GhcPs
dd_cons :: [LConDecl GhcPs]
dd_kindSig :: Maybe (XRec GhcPs (HsType GhcPs))
dd_cType :: Maybe (XRec GhcPs CType)
dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ND :: NewOrData
dd_ext :: XCHsDataDefn GhcPs
..}, LHsQTyVars GhcPs
XRec GhcPs (IdP GhcPs)
XDataDecl GhcPs
LexicalFixity
tcdDExt :: forall pass. TyClDecl pass -> XDataDecl pass
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars GhcPs
tcdLName :: XRec GhcPs (IdP GhcPs)
tcdDExt :: XDataDecl GhcPs
..} = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LConDecl GhcPs
-> [(XRec GhcPs (HsType GhcPs), RdrName, FieldOcc GhcPs,
HsType GhcPs)]
ctor [LConDecl GhcPs]
dd_cons
where
ctor :: LConDecl GhcPs -> [(LHsType GhcPs, GHC.RdrName, FieldOcc GhcPs, HsType GhcPs)]
ctor :: LConDecl GhcPs
-> [(XRec GhcPs (HsType GhcPs), RdrName, FieldOcc GhcPs,
HsType GhcPs)]
ctor (L SrcSpanAnnA
_ ConDecl GhcPs
con) = [(forall e ann. Located e -> LocatedAn ann e
reLocA Located (HsType GhcPs)
result, RdrName
name, FieldOcc GhcPs
fld, HsType GhcPs
ty) | (RdrName
name, FieldOcc GhcPs
fld, HsType GhcPs
ty) <- PluginEnv =>
[RdrName]
-> ConDecl GhcPs -> [(IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]
conClosedFields (LHsQTyVars GhcPs -> [RdrName]
defVars LHsQTyVars GhcPs
tcdTyVars) ConDecl GhcPs
con]
defVars :: LHsQTyVars GhcPs -> [GHC.RdrName]
defVars :: LHsQTyVars GhcPs -> [RdrName]
defVars LHsQTyVars GhcPs
vars = [RdrName
v | L SrcSpanAnnN
_ RdrName
v <- forall (p :: Pass).
LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
hsLTyVarLocNames LHsQTyVars GhcPs
vars]
result :: Located (HsType GhcPs)
result = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Located (HsType GhcPs)
x GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
y -> forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy forall a. WithoutExt a => a
noE (forall e ann. Located e -> LocatedAn ann e
reLocA Located (HsType GhcPs)
x) forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) flag.
(Anno (IdP (GhcPass p)) ~ SrcSpanAnnN) =>
LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
y) (forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. WithoutExt a => a
noE PromotionFlag
GHC.NotPromoted GenLocated SrcSpanAnnN RdrName
tyName) forall a b. (a -> b) -> a -> b
$ forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit LHsQTyVars GhcPs
tcdTyVars
tyName :: GenLocated SrcSpanAnnN RdrName
tyName = case (XRec GhcPs (IdP GhcPs)
tcdLName, Maybe ModuleName
modName) of
(L SrcSpanAnnN
l (GHC.Unqual OccName
name), Just ModuleName
modName') -> forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l (ModuleName -> OccName -> RdrName
GHC.Qual ModuleName
modName' OccName
name)
(GenLocated SrcSpanAnnN RdrName, Maybe ModuleName)
_ -> XRec GhcPs (IdP GhcPs)
tcdLName
getFields Maybe ModuleName
_ TyClDecl GhcPs
_ = []
conClosedFields :: PluginEnv => [GHC.RdrName] -> ConDecl GhcPs -> [(IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]
conClosedFields :: PluginEnv =>
[RdrName]
-> ConDecl GhcPs -> [(IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]
conClosedFields [RdrName]
resultVars = \case
ConDeclH98 {con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = RecCon (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
args), XRec GhcPs (IdP GhcPs)
con_name :: forall pass. ConDecl pass -> LIdP pass
con_name :: XRec GhcPs (IdP GhcPs)
con_name, [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs} ->
[ (forall l e. GenLocated l e -> e
unLoc XRec GhcPs (IdP GhcPs)
con_name, forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (FieldOcc GhcPs)
name, forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsType GhcPs)
ty)
| ConDeclField {[LFieldOcc GhcPs]
cd_fld_names :: forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_names, cd_fld_type :: forall pass. ConDeclField pass -> LBangType pass
cd_fld_type = XRec GhcPs (HsType GhcPs)
ty} <- forall from to. Biplate from to => from -> [to]
universeBi [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
args,
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((?hscenv::HscEnv, ?uniqSupply::IORef UniqSupply) =>
GenLocated SrcSpanAnnA (HsType GhcPs) -> [RdrName]
freeTyVars' XRec GhcPs (HsType GhcPs)
ty forall a. Eq a => [a] -> [a] -> [a]
\\ [RdrName]
resultVars),
Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsType GhcPs) -> Bool
isLHsForAllTy XRec GhcPs (HsType GhcPs)
ty,
GenLocated SrcSpan (FieldOcc GhcPs)
name <- [LFieldOcc GhcPs]
cd_fld_names
]
#if __GLASGOW_HASKELL__ >= 904
ConDeclGADT {con_g_args = RecConGADT (L _ args) _, con_res_ty, con_names} ->
#elif __GLASGOW_HASKELL__ >= 901
ConDeclGADT {con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = RecConGADT (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
args), XRec GhcPs (HsType GhcPs)
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty :: XRec GhcPs (HsType GhcPs)
con_res_ty, [XRec GhcPs (IdP GhcPs)]
con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_names :: [XRec GhcPs (IdP GhcPs)]
con_names} ->
#else
ConDeclGADT {con_args = RecCon (L _ args), con_res_ty, con_names} ->
#endif
[ (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
con_name, forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (FieldOcc GhcPs)
name, forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsType GhcPs)
ty)
| ConDeclField {[LFieldOcc GhcPs]
cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_names :: forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names, cd_fld_type :: forall pass. ConDeclField pass -> LBangType pass
cd_fld_type = XRec GhcPs (HsType GhcPs)
ty} <- forall from to. Biplate from to => from -> [to]
universeBi [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
args,
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PluginEnv => XRec GhcPs (HsType GhcPs) -> [Located RdrName]
freeTyVars XRec GhcPs (HsType GhcPs)
ty forall a. Eq a => [a] -> [a] -> [a]
\\ PluginEnv => XRec GhcPs (HsType GhcPs) -> [Located RdrName]
freeTyVars XRec GhcPs (HsType GhcPs)
con_res_ty),
Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsType GhcPs) -> Bool
isLHsForAllTy XRec GhcPs (HsType GhcPs)
ty,
GenLocated SrcSpan (FieldOcc GhcPs)
name <- [LFieldOcc GhcPs]
cd_fld_names,
GenLocated SrcSpanAnnN RdrName
con_name <- [XRec GhcPs (IdP GhcPs)]
con_names
]
ConDecl GhcPs
_ -> []
where
freeTyVars' :: GenLocated SrcSpanAnnA (HsType GhcPs) -> [RdrName]
freeTyVars' GenLocated SrcSpanAnnA (HsType GhcPs)
ty = forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginEnv => XRec GhcPs (HsType GhcPs) -> [Located RdrName]
freeTyVars GenLocated SrcSpanAnnA (HsType GhcPs)
ty
onExp :: LHsExpr GhcPs -> LHsExpr GhcPs
onExp :: LHsExpr GhcPs -> LHsExpr GhcPs
onExp (forall a e. LocatedAn a e -> Located e
reLoc -> L SrcSpan
o (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs mid :: LHsExpr GhcPs
mid@(LHsExpr GhcPs -> Bool
isDot -> Bool
True) LHsExpr GhcPs
rhs))
| forall ann a b.
GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacent LHsExpr GhcPs
lhs LHsExpr GhcPs
mid, forall ann a b.
GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacent LHsExpr GhcPs
mid LHsExpr GhcPs
rhs
, (LHsExpr GhcPs -> LHsExpr GhcPs
lhsOp, LHsExpr GhcPs
lhs) <- LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getOpRHS forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
onExp LHsExpr GhcPs
lhs
, (LHsExpr GhcPs -> LHsExpr GhcPs
lhsApp, LHsExpr GhcPs
lhs) <- LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getAppRHS LHsExpr GhcPs
lhs
, (LHsExpr GhcPs -> LHsExpr GhcPs
rhsApp, LHsExpr GhcPs
rhs) <- LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getAppLHS LHsExpr GhcPs
rhs
, (LHsExpr GhcPs -> LHsExpr GhcPs
rhsRec, LHsExpr GhcPs
rhs) <- LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getRec LHsExpr GhcPs
rhs
, Just XRec GhcPs (HsType GhcPs)
sel <- LHsExpr GhcPs -> Maybe (XRec GhcPs (HsType GhcPs))
getSelector LHsExpr GhcPs
rhs
= LHsExpr GhcPs -> LHsExpr GhcPs
onExp forall a b. (a -> b) -> a -> b
$ forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall e. SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL SrcSpan
o forall a b. (a -> b) -> a -> b
$ forall a e. LocatedAn a e -> Located e
reLoc forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
lhsOp forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
rhsApp forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
lhsApp forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
rhsRec forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
mkParen forall a b. (a -> b) -> a -> b
$ RdrName -> LHsExpr GhcPs
mkVar RdrName
var_getField LHsExpr GhcPs -> XRec GhcPs (HsType GhcPs) -> LHsExpr GhcPs
`mkAppType` XRec GhcPs (HsType GhcPs)
sel LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`mkApp` LHsExpr GhcPs
lhs
onExp (forall a e. LocatedAn a e -> Located e
reLoc -> L SrcSpan
o (SectionR XSectionR GhcPs
_ mid :: LHsExpr GhcPs
mid@(LHsExpr GhcPs -> Bool
isDot -> Bool
True) LHsExpr GhcPs
rhs))
| forall ann a b.
GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacent LHsExpr GhcPs
mid LHsExpr GhcPs
rhs
, SrcSpan -> SrcLoc
srcSpanStart SrcSpan
o forall a. Eq a => a -> a -> Bool
== SrcSpan -> SrcLoc
srcSpanStart (forall l e. GenLocated l e -> l
getLoc forall a b. (a -> b) -> a -> b
$ forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
mid)
, SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
o forall a. Eq a => a -> a -> Bool
== SrcSpan -> SrcLoc
srcSpanEnd (forall l e. GenLocated l e -> l
getLoc forall a b. (a -> b) -> a -> b
$ forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
rhs)
, Just [XRec GhcPs (HsType GhcPs)]
sels <- LHsExpr GhcPs -> Maybe [XRec GhcPs (HsType GhcPs)]
getSelectors LHsExpr GhcPs
rhs
= forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall e. SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL SrcSpan
o forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\GenLocated SrcSpan (HsExpr GhcPs)
x GenLocated SrcSpan (HsExpr GhcPs)
y -> forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp forall a. WithoutExt a => a
noE (forall e ann. Located e -> LocatedAn ann e
reLocA GenLocated SrcSpan (HsExpr GhcPs)
x) (RdrName -> LHsExpr GhcPs
mkVar RdrName
var_dot) (forall e ann. Located e -> LocatedAn ann e
reLocA GenLocated SrcSpan (HsExpr GhcPs)
y))
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ( \ GenLocated SrcSpanAnnA (HsType GhcPs)
sel -> forall a e. LocatedAn a e -> Located e
reLoc forall a b. (a -> b) -> a -> b
$ RdrName -> LHsExpr GhcPs
mkVar RdrName
var_getField LHsExpr GhcPs -> XRec GhcPs (HsType GhcPs) -> LHsExpr GhcPs
`mkAppType` GenLocated SrcSpanAnnA (HsType GhcPs)
sel) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [XRec GhcPs (HsType GhcPs)]
sels
#if __GLASGOW_HASKELL__ >= 902
onExp (L SrcSpanAnnA
o upd :: HsExpr GhcPs
upd@RecordUpd{LHsExpr GhcPs
rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr :: LHsExpr GhcPs
rupd_expr,rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds= Left (LHsRecUpdField GhcPs
fld:[LHsRecUpdField GhcPs]
flds)})
#else
onExp (L o upd@RecordUpd{rupd_expr,rupd_flds= fld:flds})
#endif
| forall ann a b.
Int
-> GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacentBy Int
1 LHsExpr GhcPs
rupd_expr LHsRecUpdField GhcPs
fld
= LHsExpr GhcPs -> LHsExpr GhcPs
onExp forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [HsRecUpdField GhcPs] -> LHsExpr GhcPs
f LHsExpr GhcPs
rupd_expr forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ LHsRecUpdField GhcPs
fldforall a. a -> [a] -> [a]
:[LHsRecUpdField GhcPs]
flds
where
f :: LHsExpr GhcPs -> [HsRecUpdField GhcPs] -> LHsExpr GhcPs
f :: LHsExpr GhcPs -> [HsRecUpdField GhcPs] -> LHsExpr GhcPs
f LHsExpr GhcPs
expr [] = LHsExpr GhcPs
expr
#if __GLASGOW_HASKELL__ >= 904
f expr (HsFieldBind { hfbLHS = (fmap rdrNameAmbiguousFieldOcc . reLoc) -> lbl
, hfbRHS = arg
, hfbPun = pun
} : flds)
#else
f LHsExpr GhcPs
expr (HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc -> Located RdrName
lbl
, hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LHsExpr GhcPs
arg
, hsRecPun :: forall id arg. HsRecField' id arg -> Bool
hsRecPun = Bool
pun
} : [HsRecUpdField GhcPs]
flds)
#endif
| let sel :: XRec GhcPs (HsType GhcPs)
sel = Located RdrName -> XRec GhcPs (HsType GhcPs)
mkSelector Located RdrName
lbl
, let arg2 :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg2 = if Bool
pun then forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar forall a. WithoutExt a => a
noE (forall e ann. Located e -> LocatedAn ann e
reLocA Located RdrName
lbl) else LHsExpr GhcPs
arg
, let expr2 :: LHsExpr GhcPs
expr2 = LHsExpr GhcPs -> LHsExpr GhcPs
mkParen forall a b. (a -> b) -> a -> b
$ RdrName -> LHsExpr GhcPs
mkVar RdrName
var_setField LHsExpr GhcPs -> XRec GhcPs (HsType GhcPs) -> LHsExpr GhcPs
`mkAppType` GenLocated SrcSpanAnnA (HsType GhcPs)
sel LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`mkApp` LHsExpr GhcPs
expr LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`mkApp` GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg2
= LHsExpr GhcPs -> [HsRecUpdField GhcPs] -> LHsExpr GhcPs
f GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr2 [HsRecUpdField GhcPs]
flds
onExp LHsExpr GhcPs
x = forall on. Uniplate on => (on -> on) -> on -> on
descend LHsExpr GhcPs -> LHsExpr GhcPs
onExp LHsExpr GhcPs
x
mkSelector :: Located GHC.RdrName -> LHsType GhcPs
mkSelector :: Located RdrName -> XRec GhcPs (HsType GhcPs)
mkSelector (L SrcSpan
o RdrName
x) = forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
o forall a b. (a -> b) -> a -> b
$ forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit forall a. WithoutExt a => a
noE forall a b. (a -> b) -> a -> b
$ SourceText -> FastString -> HsTyLit
HsStrTy SourceText
GHC.NoSourceText forall a b. (a -> b) -> a -> b
$ OccName -> FastString
GHC.occNameFS forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
GHC.rdrNameOcc RdrName
x
getSelector :: LHsExpr GhcPs -> Maybe (LHsType GhcPs)
getSelector :: LHsExpr GhcPs -> Maybe (XRec GhcPs (HsType GhcPs))
getSelector (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (forall a e. LocatedAn a e -> Located e
reLoc -> L SrcSpan
o RdrName
sym)))
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ RdrName -> Bool
GHC.isQual RdrName
sym
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Located RdrName -> XRec GhcPs (HsType GhcPs)
mkSelector forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
o RdrName
sym
getSelector LHsExpr GhcPs
_ = forall a. Maybe a
Nothing
getSelectors :: LHsExpr GhcPs -> Maybe [LHsType GhcPs]
getSelectors :: LHsExpr GhcPs -> Maybe [XRec GhcPs (HsType GhcPs)]
getSelectors (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs mid :: LHsExpr GhcPs
mid@(LHsExpr GhcPs -> Bool
isDot -> Bool
True) LHsExpr GhcPs
rhs))
| forall ann a b.
GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacent LHsExpr GhcPs
lhs LHsExpr GhcPs
mid, forall ann a b.
GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacent LHsExpr GhcPs
mid LHsExpr GhcPs
rhs
, Just XRec GhcPs (HsType GhcPs)
post <- LHsExpr GhcPs -> Maybe (XRec GhcPs (HsType GhcPs))
getSelector LHsExpr GhcPs
rhs
, Just [XRec GhcPs (HsType GhcPs)]
pre <- LHsExpr GhcPs -> Maybe [XRec GhcPs (HsType GhcPs)]
getSelectors LHsExpr GhcPs
lhs
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [XRec GhcPs (HsType GhcPs)]
pre forall a. [a] -> [a] -> [a]
++ [XRec GhcPs (HsType GhcPs)
post]
getSelectors LHsExpr GhcPs
x = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcPs -> Maybe (XRec GhcPs (HsType GhcPs))
getSelector LHsExpr GhcPs
x
getAppRHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getAppRHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getAppRHS (L SrcSpanAnnA
l (HsApp XApp GhcPs
e LHsExpr GhcPs
x LHsExpr GhcPs
y)) = (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
e LHsExpr GhcPs
x, LHsExpr GhcPs
y)
getAppRHS LHsExpr GhcPs
x = (forall {a}. a -> a
id, LHsExpr GhcPs
x)
getAppLHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getAppLHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getAppLHS (L SrcSpanAnnA
l (HsApp XApp GhcPs
e LHsExpr GhcPs
x LHsExpr GhcPs
y)) = forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (\LHsExpr GhcPs -> LHsExpr GhcPs
c -> forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\GenLocated SrcSpanAnnA (HsExpr GhcPs)
x -> forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
e GenLocated SrcSpanAnnA (HsExpr GhcPs)
x LHsExpr GhcPs
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs
c) forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getAppLHS LHsExpr GhcPs
x
getAppLHS LHsExpr GhcPs
x = (forall {a}. a -> a
id, LHsExpr GhcPs
x)
getOpRHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getOpRHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getOpRHS (L SrcSpanAnnA
l (OpApp XOpApp GhcPs
x LHsExpr GhcPs
y LHsExpr GhcPs
p LHsExpr GhcPs
z)) = (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
x LHsExpr GhcPs
y LHsExpr GhcPs
p, LHsExpr GhcPs
z)
getOpRHS LHsExpr GhcPs
x = (forall {a}. a -> a
id, LHsExpr GhcPs
x)
getRec :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getRec :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getRec (L SrcSpanAnnA
l r :: HsExpr GhcPs
r@RecordUpd{}) = forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (\GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
c LHsExpr GhcPs
x -> forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr GhcPs
r{rupd_expr :: LHsExpr GhcPs
rupd_expr=forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall e. SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL (forall l e. GenLocated l e -> l
getLoc forall a b. (a -> b) -> a -> b
$ forall a e. LocatedAn a e -> Located e
reLoc forall a b. (a -> b) -> a -> b
$ forall p. HsExpr p -> LHsExpr p
rupd_expr HsExpr GhcPs
r) forall a b. (a -> b) -> a -> b
$ forall a e. LocatedAn a e -> Located e
reLoc forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
c LHsExpr GhcPs
x }) forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getRec forall a b. (a -> b) -> a -> b
$ forall p. HsExpr p -> LHsExpr p
rupd_expr HsExpr GhcPs
r
getRec LHsExpr GhcPs
x = (forall {a}. a -> a
id, LHsExpr GhcPs
x)
isDot :: LHsExpr GhcPs -> Bool
isDot :: LHsExpr GhcPs -> Bool
isDot (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
op))) = RdrName
op forall a. Eq a => a -> a -> Bool
== RdrName
var_dot
isDot LHsExpr GhcPs
_ = Bool
False
mkVar :: GHC.RdrName -> LHsExpr GhcPs
mkVar :: RdrName -> LHsExpr GhcPs
mkVar = forall a b. WithoutLoc a b => a -> b
noL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XVar p -> LIdP p -> HsExpr p
HsVar forall a. WithoutExt a => a
noE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. WithoutLoc a b => a -> b
noL
mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs
mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs
mkParen = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar
mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp LHsExpr GhcPs
x LHsExpr GhcPs
y = forall a b. WithoutLoc a b => a -> b
noL forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. WithoutExt a => a
noE LHsExpr GhcPs
x LHsExpr GhcPs
y
#if __GLASGOW_HASKELL__ >= 902
adjacent :: GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacentBy :: Int -> GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
#else
adjacent :: Located a -> Located b -> Bool
adjacentBy :: Int -> Located a -> Located b -> Bool
#endif
adjacent :: forall ann a b.
GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacent = forall ann a b.
Int
-> GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacentBy Int
0
adjacentBy :: forall ann a b.
Int
-> GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool
adjacentBy Int
i (forall a e. LocatedAn a e -> Located e
reLoc -> L (SrcLoc -> Maybe RealSrcLoc
realSrcLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcLoc
srcSpanEnd -> Just RealSrcLoc
a) a
_) (forall a e. LocatedAn a e -> Located e
reLoc -> L (SrcLoc -> Maybe RealSrcLoc
realSrcLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcLoc
srcSpanStart -> Just RealSrcLoc
b) b
_) =
RealSrcLoc -> FastString
srcLocFile RealSrcLoc
a forall a. Eq a => a -> a -> Bool
== RealSrcLoc -> FastString
srcLocFile RealSrcLoc
b Bool -> Bool -> Bool
&&
RealSrcLoc -> Int
srcLocLine RealSrcLoc
a forall a. Eq a => a -> a -> Bool
== RealSrcLoc -> Int
srcLocLine RealSrcLoc
b Bool -> Bool -> Bool
&&
RealSrcLoc -> Int
srcLocCol RealSrcLoc
a forall a. Num a => a -> a -> a
+ Int
i forall a. Eq a => a -> a -> Bool
== RealSrcLoc -> Int
srcLocCol RealSrcLoc
b
adjacentBy Int
_ GenLocated (SrcAnn ann) a
_ GenLocated (SrcAnn ann) b
_ = Bool
False
makeEqQualTy :: HsType GhcPs -> (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs
makeEqQualTy :: HsType GhcPs -> (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs
makeEqQualTy HsType GhcPs
rArg HsType GhcPs -> HsType GhcPs
fAbs
= forall pass.
XQualTy pass
-> Maybe (LHsContext pass) -> LHsType pass -> HsType pass
HsQualTy forall a. WithoutExt a => a
noE
(
#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
#endif
forall a b. WithoutLoc a b => a -> b
noL [XRec GhcPs (HsType GhcPs)]
qualCtx
)
(forall a b. WithoutLoc a b => a -> b
noL (HsType GhcPs -> HsType GhcPs
fAbs HsType GhcPs
tyVar))
where
var :: RdrName
var = Name -> RdrName
GHC.nameRdrName forall a b. (a -> b) -> a -> b
$ OccName -> Name
GHC.mkUnboundName forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkTyVarOcc CommandLineOption
"aplg"
tyVar :: HsType GhcPs
tyVar :: HsType GhcPs
tyVar = forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. WithoutExt a => a
noE PromotionFlag
GHC.NotPromoted (forall a b. WithoutLoc a b => a -> b
noL RdrName
var)
var_tilde :: RdrName
var_tilde = Module -> OccName -> RdrName
GHC.mkOrig Module
GHC.gHC_TYPES forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkClsOcc CommandLineOption
"~"
eqQual :: HsType GhcPs
eqQual :: HsType GhcPs
eqQual =
forall pass.
XOpTy pass
-> LHsType pass -> LIdP pass -> LHsType pass -> HsType pass
HsOpTy
#if __GLASGOW_HASKELL__ >= 904
EpAnnNotUsed
GHC.NotPromoted
#else
forall a. WithoutExt a => a
noE
#endif
(forall a b. WithoutLoc a b => a -> b
noL (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. WithoutExt a => a
noE (forall a b. WithoutLoc a b => a -> b
noL HsType GhcPs
rArg)))
(forall a b. WithoutLoc a b => a -> b
noL RdrName
var_tilde)
(forall a b. WithoutLoc a b => a -> b
noL HsType GhcPs
tyVar)
qualCtx :: HsContext GhcPs
qualCtx :: [XRec GhcPs (HsType GhcPs)]
qualCtx = [forall a b. WithoutLoc a b => a -> b
noL (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. WithoutExt a => a
noE (forall a b. WithoutLoc a b => a -> b
noL HsType GhcPs
eqQual))]