{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns, OverloadedStrings, LambdaCase #-}
{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-}
{- HLINT ignore "Use camelCase" -}

-- | Module containing the plugin.
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 WRAPPER

-- | GHC plugin.
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}

---------------------------------------------------------------------
-- PLUGIN GUTS

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"

-- | GHC.Records.getField (as opposed to GHC.Records.Extra.getField)
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
    ]

{-
instance Z.HasField "name" (Company) (String) where hasField _r = (\_x -> _r{name=_x}, (name:: (Company) -> String) _r)

instance HasField "selector" Record Field where
    hasField r = (\x -> r{selector=x}, (name :: Record -> Field) r)
-}
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]

        -- A value of this data declaration will have this type.
        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
_ = []

-- Extract filed and its type from declaration, omitting fields with existential/higher-kind types.
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

-- At this point infix expressions have not had associativity/fixity applied, so they are bracketed
-- a + b + c ==> (a + b) + c
-- Therefore we need to deal with, in general:
-- x.y, where
-- x := a | a b | a.b | a + b
-- y := a | a b | a{b=1}
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

-- Turn (.foo.bar) into getField calls
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
    -- Don't bracket here. The argument came in as a section so it's
    -- already enclosed in brackets.
    = 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

-- Turn a{b=c, ...} into setField calls
#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  -- 'expr' never needs bracketing.
            = 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

-- | Turn a.b.c into Just [a,b,c]
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

-- | Lens on: f [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)

-- | Lens on: [f] x y z
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)

-- | Lens on: a + [b]
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)

-- | Lens on: [r]{f1=x1}{f2=x2}
getRec :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
-- important to copy the location back over, since we check the whitespace hasn't changed
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)

-- | Is it equal to: .
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
-- | Are the end of a and the start of b next to each other, no white space
adjacent :: GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool

-- | Are the end of a and the start of b next to each other, no white space
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


--  Given:
--   C f Int    and     \x -> HasField "field" Entity x
--   Returns:
--   ((C f Int) ~ aplg) => HasField "field" Entity aplg
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 -- TODO: Is this right?
#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))]