{-# 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__ < 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.Types 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]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
forall p p. p -> p -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction
    , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
GHC.pluginRecompile = [CommandLineOption] -> IO PluginRecompile
GHC.purePlugin
    }
    where
        parsedResultAction :: p -> p -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction p
_cliOptions p
_modSummary HsParsedModule
x = do
            HscEnv
hscenv <- HscEnv -> HscEnv
dropRnTraceFlags (HscEnv -> HscEnv) -> Hsc HscEnv -> Hsc HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hsc HscEnv
HscMain.getHscEnv
            UniqSupply
uniqSupply <- IO UniqSupply -> Hsc UniqSupply
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (Char -> IO UniqSupply
GHC.mkSplitUniqSupply Char
'0')
            IORef UniqSupply
uniqSupplyRef <- IO (IORef UniqSupply) -> Hsc (IORef UniqSupply)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO (IORef UniqSupply) -> Hsc (IORef UniqSupply))
-> IO (IORef UniqSupply) -> Hsc (IORef UniqSupply)
forall a b. (a -> b) -> a -> b
$ UniqSupply -> IO (IORef UniqSupply)
forall a. a -> IO (IORef a)
newIORef UniqSupply
uniqSupply
            let ?hscenv = hscenv
            let ?uniqSupply = uniqSupplyRef
            HsParsedModule -> Hsc HsParsedModule
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsParsedModule
x{hpm_module :: Located (HsModule GhcPs)
GHC.hpm_module = PluginEnv => HsModule GhcPs -> HsModule GhcPs
HsModule GhcPs -> HsModule GhcPs
onModule (HsModule GhcPs -> HsModule GhcPs)
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsParsedModule -> Located (HsModule GhcPs)
GHC.hpm_module HsParsedModule
x}


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

setL :: SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL :: SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL SrcSpan
l (L SrcSpan
_ e
x) = SrcSpan -> e -> GenLocated SrcSpan e
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 (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkClsOcc CommandLineOption
"HasField"
var_hasField :: RdrName
var_hasField = OccName -> RdrName
GHC.mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
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 (OccName -> RdrName) -> OccName -> RdrName
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 (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"setField"
var_dot :: RdrName
var_dot = OccName -> RdrName
GHC.mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"."


onModule :: PluginEnv => Module -> Module
onModule :: HsModule GhcPs -> HsModule GhcPs
onModule HsModule GhcPs
x = HsModule GhcPs
x { hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs] -> [LImportDecl GhcPs]
onImports ([LImportDecl GhcPs] -> [LImportDecl GhcPs])
-> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports HsModule GhcPs
x
               , hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = (LHsDecl GhcPs -> [LHsDecl GhcPs])
-> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs]
PluginEnv => Maybe ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs]
onDecl (Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> Maybe (Located ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule GhcPs -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
hsmodName HsModule GhcPs
x)) ([LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule GhcPs
x
               }


onImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
onImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
onImports = (:) (LImportDecl GhcPs -> [LImportDecl GhcPs] -> [LImportDecl GhcPs])
-> LImportDecl GhcPs -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ ModuleName -> LImportDecl GhcPs
qualifiedImplicitImport ModuleName
mod_records

{-
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 = XClsInstD GhcPs -> ClsInstDecl GhcPs -> InstDecl GhcPs
forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD NoExtField
XClsInstD GhcPs
noE (ClsInstDecl GhcPs -> InstDecl GhcPs)
-> ClsInstDecl GhcPs -> InstDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XCClsInstDecl GhcPs
-> LHsSigType GhcPs
-> LHsBinds GhcPs
-> [LSig GhcPs]
-> [LTyFamInstDecl GhcPs]
-> [LDataFamInstDecl GhcPs]
-> Maybe (Located OverlapMode)
-> ClsInstDecl GhcPs
forall pass.
XCClsInstDecl pass
-> LHsSigType pass
-> LHsBinds pass
-> [LSig pass]
-> [LTyFamInstDecl pass]
-> [LDataFamInstDecl pass]
-> Maybe (Located OverlapMode)
-> ClsInstDecl pass
ClsInstDecl NoExtField
XCClsInstDecl GhcPs
noE (XHsIB GhcPs (GenLocated SrcSpan (HsType GhcPs))
-> GenLocated SrcSpan (HsType GhcPs) -> LHsSigType GhcPs
forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB NoExtField
XHsIB GhcPs (GenLocated SrcSpan (HsType GhcPs))
noE GenLocated SrcSpan (HsType GhcPs)
typ) (LHsBindLR GhcPs GhcPs -> LHsBinds GhcPs
forall a. a -> Bag a
unitBag LHsBindLR GhcPs GhcPs
has) [] [] [] Maybe (Located OverlapMode)
forall a. Maybe a
Nothing
    where
        typ' :: HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
typ' HsType GhcPs
a = GenLocated SrcSpan (HsType GhcPs)
-> [GenLocated SrcSpan (HsType GhcPs)]
-> GenLocated SrcSpan (HsType GhcPs)
forall (p :: Pass).
LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
mkHsAppTys
            (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcPs
noE PromotionFlag
GHC.NotPromoted (RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL RdrName
var_HasField)))
            [HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (XTyLit GhcPs -> HsTyLit -> HsType GhcPs
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
XTyLit GhcPs
noE (SourceText -> FastString -> HsTyLit
HsStrTy SourceText
GHC.NoSourceText (OccName -> FastString
GHC.occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
forall name. HasOccName name => name -> OccName
GHC.occName (RdrName -> OccName) -> RdrName -> OccName
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (GenLocated SrcSpan RdrName
 -> SrcSpanLess (GenLocated SrcSpan RdrName))
-> GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a b. (a -> b) -> a -> b
$ FieldOcc GhcPs -> GenLocated SrcSpan RdrName
forall pass. FieldOcc pass -> GenLocated SrcSpan RdrName
rdrNameFieldOcc FieldOcc GhcPs
selector)))
            ,HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL HsType GhcPs
record
            ,HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL HsType GhcPs
a
            ]

        typ :: GenLocated SrcSpan (HsType GhcPs)
typ = HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs
makeEqQualTy HsType GhcPs
field (GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs)
-> (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> HsType GhcPs
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
typ')

        has :: LHsBindLR GhcPs GhcPs
        has :: LHsBindLR GhcPs GhcPs
has = HsBind GhcPs -> LHsBindLR GhcPs GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsBind GhcPs -> LHsBindLR GhcPs GhcPs)
-> HsBind GhcPs -> LHsBindLR GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan RdrName
-> MatchGroup GhcPs (LHsExpr GhcPs) -> HsBind GhcPs
newFunBind (RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
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 :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match
                    { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext     = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noE
                    , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt    = GenLocated SrcSpan RdrName
-> LexicalFixity -> SrcStrictness -> HsMatchContext RdrName
forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs (RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL RdrName
var_hasField) LexicalFixity
GHC.Prefix SrcStrictness
NoSrcStrict
                    , m_pats :: [LPat GhcPs]
m_pats    = [Pat GhcPs] -> [LPat GhcPs]
compat_m_pats [XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noE (Located (IdP GhcPs) -> Pat GhcPs)
-> Located (IdP GhcPs) -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL RdrName
vR]
                    , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss   = XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noE [GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs))
-> GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (LHsExpr GhcPs)
-> [GuardLStmt GhcPs]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS NoExtField
XCGRHS GhcPs (LHsExpr GhcPs)
noE [] (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))
-> LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [LHsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple NoExtField
XExplicitTuple GhcPs
noE [HsTupArg GhcPs -> LHsTupArg GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsTupArg GhcPs -> LHsTupArg GhcPs)
-> HsTupArg GhcPs -> LHsTupArg GhcPs
forall a b. (a -> b) -> a -> b
$ XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present NoExtField
XPresent GhcPs
noE LHsExpr GhcPs
set, HsTupArg GhcPs -> LHsTupArg GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsTupArg GhcPs -> LHsTupArg GhcPs)
-> HsTupArg GhcPs -> LHsTupArg GhcPs
forall a b. (a -> b) -> a -> b
$ XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present NoExtField
XPresent GhcPs
noE LHsExpr GhcPs
get] Boxity
GHC.Boxed] (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs)
-> HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs
forall a b. (a -> b) -> a -> b
$ XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
noE)
                    }
                set :: LHsExpr GhcPs
set = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XLam GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
XLam GhcPs
noE (MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs)
-> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)
mg1 Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match
                    { m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext     = NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noE
                    , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt    = HsMatchContext (NameOrRdrName (IdP GhcPs))
forall id. HsMatchContext id
LambdaExpr
                    , m_pats :: [LPat GhcPs]
m_pats    = [Pat GhcPs] -> [LPat GhcPs]
compat_m_pats [XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noE (Located (IdP GhcPs) -> Pat GhcPs)
-> Located (IdP GhcPs) -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL RdrName
vX]
                    , m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss   = XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noE [GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs))
-> GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (LHsExpr GhcPs)
-> [GuardLStmt GhcPs]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS NoExtField
XCGRHS GhcPs (LHsExpr GhcPs)
noE [] (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))
-> LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL HsExpr GhcPs
update] (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs)
-> HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs
forall a b. (a -> b) -> a -> b
$ XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
noE)
                    }
                update :: HsExpr GhcPs
update = XRecordUpd GhcPs
-> LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
forall p.
XRecordUpd p -> LHsExpr p -> [LHsRecUpdField p] -> HsExpr p
RecordUpd NoExtField
XRecordUpd GhcPs
noE (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
GHC.HsVar NoExtField
XVar GhcPs
noE (Located (IdP GhcPs) -> HsExpr GhcPs)
-> Located (IdP GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL RdrName
vR)
                    [HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)
-> LHsRecUpdField GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)
 -> LHsRecUpdField GhcPs)
-> HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)
-> LHsRecUpdField GhcPs
forall a b. (a -> b) -> a -> b
$ Located (AmbiguousFieldOcc GhcPs)
-> LHsExpr GhcPs
-> Bool
-> HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)
forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField (AmbiguousFieldOcc GhcPs -> Located (AmbiguousFieldOcc GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (XUnambiguous GhcPs
-> GenLocated SrcSpan RdrName -> AmbiguousFieldOcc GhcPs
forall pass.
XUnambiguous pass
-> GenLocated SrcSpan RdrName -> AmbiguousFieldOcc pass
Unambiguous NoExtField
XUnambiguous GhcPs
noE (FieldOcc GhcPs -> GenLocated SrcSpan RdrName
forall pass. FieldOcc pass -> GenLocated SrcSpan RdrName
rdrNameFieldOcc FieldOcc GhcPs
selector))) (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
GHC.HsVar NoExtField
XVar GhcPs
noE (Located (IdP GhcPs) -> HsExpr GhcPs)
-> Located (IdP GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL RdrName
vX) Bool
False]
                get :: LHsExpr GhcPs
get = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp
                    (LHsExpr GhcPs -> LHsExpr GhcPs
mkParen (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> GenLocated SrcSpan (HsType GhcPs) -> LHsExpr GhcPs
mkTypeAnn (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
GHC.HsVar NoExtField
XVar GhcPs
noE (Located (IdP GhcPs) -> HsExpr GhcPs)
-> Located (IdP GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ FieldOcc GhcPs -> GenLocated SrcSpan RdrName
forall pass. FieldOcc pass -> GenLocated SrcSpan RdrName
rdrNameFieldOcc FieldOcc GhcPs
selector) (GenLocated SrcSpan (HsType GhcPs)
-> GenLocated SrcSpan (HsType GhcPs)
-> GenLocated SrcSpan (HsType GhcPs)
mkFunTy (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL HsType GhcPs
record) (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL HsType GhcPs
field)))
                    (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
GHC.HsVar NoExtField
XVar GhcPs
noE (Located (IdP GhcPs) -> HsExpr GhcPs)
-> Located (IdP GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL RdrName
vR)

        mg1 :: Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)
        mg1 :: Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)
mg1 Match GhcPs (LHsExpr GhcPs)
x = XMG GhcPs (LHsExpr GhcPs)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
-> Origin
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG NoExtField
XMG GhcPs (LHsExpr GhcPs)
noE ([LMatch GhcPs (LHsExpr GhcPs)]
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall e. e -> GenLocated SrcSpan e
noL [Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall e. e -> GenLocated SrcSpan e
noL Match GhcPs (LHsExpr GhcPs)
x]) Origin
GHC.Generated

        vR :: RdrName
vR = OccName -> RdrName
GHC.mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"r"
        vX :: RdrName
vX = OccName -> RdrName
GHC.mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkVarOcc CommandLineOption
"x"


onDecl :: PluginEnv => Maybe GHC.ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs]
onDecl :: Maybe ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs]
onDecl Maybe ModuleName
modName o :: LHsDecl GhcPs
o@(L SrcSpan
_ (GHC.TyClD XTyClD GhcPs
_ TyClDecl GhcPs
x)) = LHsDecl GhcPs
o LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
:
    [ HsDecl GhcPs -> LHsDecl GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
XInstD GhcPs
noE (InstDecl GhcPs -> HsDecl GhcPs) -> InstDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs
instanceTemplate FieldOcc GhcPs
field (GenLocated SrcSpan (HsType GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsType GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan (HsType GhcPs)
record) (HsType GhcPs -> HsType GhcPs
unbang HsType GhcPs
typ)
    | let fields :: [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
  HsType GhcPs)]
fields = ((GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
  HsType GhcPs)
 -> FastString)
-> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
     HsType GhcPs)]
-> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
     HsType GhcPs)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (\(GenLocated SrcSpan (HsType GhcPs)
_,RdrName
_,FieldOcc GhcPs
x,HsType GhcPs
_) -> OccName -> FastString
GHC.occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
GHC.rdrNameOcc (RdrName -> OccName) -> RdrName -> OccName
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (GenLocated SrcSpan RdrName
 -> SrcSpanLess (GenLocated SrcSpan RdrName))
-> GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a b. (a -> b) -> a -> b
$ FieldOcc GhcPs -> GenLocated SrcSpan RdrName
forall pass. FieldOcc pass -> GenLocated SrcSpan RdrName
rdrNameFieldOcc FieldOcc GhcPs
x) ([(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
   HsType GhcPs)]
 -> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
      HsType GhcPs)])
-> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
     HsType GhcPs)]
-> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
     HsType GhcPs)]
forall a b. (a -> b) -> a -> b
$ Maybe ModuleName
-> TyClDecl GhcPs
-> [(GenLocated SrcSpan (HsType GhcPs), IdP GhcPs, FieldOcc GhcPs,
     HsType GhcPs)]
PluginEnv =>
Maybe ModuleName
-> TyClDecl GhcPs
-> [(GenLocated SrcSpan (HsType GhcPs), IdP GhcPs, FieldOcc GhcPs,
     HsType GhcPs)]
getFields Maybe ModuleName
modName TyClDecl GhcPs
x
    , (GenLocated SrcSpan (HsType GhcPs)
record, RdrName
_, FieldOcc GhcPs
field, HsType GhcPs
typ) <- [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
  HsType GhcPs)]
fields]
onDecl Maybe ModuleName
_ LHsDecl GhcPs
x = [(LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsDecl GhcPs -> LHsDecl GhcPs
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
_ GenLocated SrcSpan (HsType GhcPs)
x) = GenLocated SrcSpan (HsType GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsType GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan (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 :: Maybe ModuleName
-> TyClDecl GhcPs
-> [(GenLocated SrcSpan (HsType GhcPs), IdP GhcPs, FieldOcc GhcPs,
     HsType GhcPs)]
getFields Maybe ModuleName
modName DataDecl{tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn=HsDataDefn{[LConDecl GhcPs]
Maybe (GenLocated SrcSpan (HsType GhcPs))
Maybe (Located CType)
NewOrData
XCHsDataDefn GhcPs
HsDeriving GhcPs
LHsContext GhcPs
dd_ext :: forall pass. HsDataDefn pass -> XCHsDataDefn pass
dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ctxt :: forall pass. HsDataDefn pass -> LHsContext pass
dd_cType :: forall pass. HsDataDefn pass -> Maybe (Located CType)
dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs :: HsDeriving GhcPs
dd_cons :: [LConDecl GhcPs]
dd_kindSig :: Maybe (GenLocated SrcSpan (HsType GhcPs))
dd_cType :: Maybe (Located CType)
dd_ctxt :: LHsContext GhcPs
dd_ND :: NewOrData
dd_ext :: XCHsDataDefn GhcPs
..}, LHsQTyVars GhcPs
XDataDecl GhcPs
LexicalFixity
Located (IdP GhcPs)
tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdDExt :: forall pass. TyClDecl pass -> XDataDecl pass
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars GhcPs
tcdLName :: Located (IdP GhcPs)
tcdDExt :: XDataDecl GhcPs
..} = (LConDecl GhcPs
 -> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
      HsType GhcPs)])
-> [LConDecl GhcPs]
-> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
     HsType GhcPs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LConDecl GhcPs
-> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
     HsType GhcPs)]
forall l.
(?hscenv::HscEnv, ?uniqSupply::IORef UniqSupply) =>
GenLocated l (ConDecl GhcPs)
-> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
     HsType GhcPs)]
ctor [LConDecl GhcPs]
dd_cons
    where
        ctor :: GenLocated l (ConDecl GhcPs)
-> [(GenLocated SrcSpan (HsType GhcPs), RdrName, FieldOcc GhcPs,
     HsType GhcPs)]
ctor (L l
_ ConDecl GhcPs
con) = [(GenLocated SrcSpan (HsType GhcPs)
result, RdrName
name, FieldOcc GhcPs
fld, HsType GhcPs
ty) | (RdrName
name, FieldOcc GhcPs
fld, HsType GhcPs
ty) <- [RdrName]
-> ConDecl GhcPs -> [(IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]
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 SrcSpan
_ RdrName
v <- LHsQTyVars GhcPs -> [Located (IdP GhcPs)]
forall (p :: Pass).
LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))]
hsLTyVarLocNames LHsQTyVars GhcPs
vars]

        -- A value of this data declaration will have this type.
        result :: GenLocated SrcSpan (HsType GhcPs)
result = (GenLocated SrcSpan (HsType GhcPs)
 -> LHsTyVarBndr GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> GenLocated SrcSpan (HsType GhcPs)
-> [LHsTyVarBndr GhcPs]
-> GenLocated SrcSpan (HsType GhcPs)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\GenLocated SrcSpan (HsType GhcPs)
x LHsTyVarBndr GhcPs
y -> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XAppTy GhcPs
-> GenLocated SrcSpan (HsType GhcPs)
-> GenLocated SrcSpan (HsType GhcPs)
-> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
XAppTy GhcPs
noE GenLocated SrcSpan (HsType GhcPs)
x (GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs)
-> GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ LHsTyVarBndr GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall (p :: Pass). LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType LHsTyVarBndr GhcPs
y) (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcPs
noE PromotionFlag
GHC.NotPromoted Located (IdP GhcPs)
GenLocated SrcSpan RdrName
tyName) ([LHsTyVarBndr GhcPs] -> GenLocated SrcSpan (HsType GhcPs))
-> [LHsTyVarBndr GhcPs] -> GenLocated SrcSpan (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsq_explicit LHsQTyVars GhcPs
tcdTyVars
        tyName :: GenLocated SrcSpan RdrName
tyName = case (Located (IdP GhcPs)
GenLocated SrcSpan RdrName
tcdLName, Maybe ModuleName
modName) of
            (L SrcSpan
l (GHC.Unqual OccName
name), Just ModuleName
modName') -> SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (ModuleName -> OccName -> RdrName
GHC.Qual ModuleName
modName' OccName
name)
            (GenLocated SrcSpan RdrName, Maybe ModuleName)
_ -> Located (IdP GhcPs)
GenLocated SrcSpan RdrName
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 :: [RdrName]
-> ConDecl GhcPs -> [(IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]
conClosedFields [RdrName]
resultVars = \case
    ConDeclH98 {con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args = RecCon (L SrcSpan
_ [LConDeclField GhcPs]
args), Located (IdP GhcPs)
con_name :: forall pass. ConDecl pass -> Located (IdP pass)
con_name :: Located (IdP GhcPs)
con_name, [LHsTyVarBndr GhcPs]
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr pass]
con_ex_tvs :: [LHsTyVarBndr GhcPs]
con_ex_tvs} ->
        [ (GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcPs)
GenLocated SrcSpan RdrName
con_name, LFieldOcc GhcPs -> SrcSpanLess (LFieldOcc GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LFieldOcc GhcPs
name, GenLocated SrcSpan (HsType GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsType GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan (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 = GenLocated SrcSpan (HsType GhcPs)
ty} <- [LConDeclField GhcPs] -> [ConDeclField GhcPs]
forall from to. Biplate from to => from -> [to]
universeBi [LConDeclField GhcPs]
args,
                [RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((?hscenv::HscEnv, ?uniqSupply::IORef UniqSupply) =>
GenLocated SrcSpan (HsType GhcPs) -> [RdrName]
GenLocated SrcSpan (HsType GhcPs) -> [RdrName]
freeTyVars' GenLocated SrcSpan (HsType GhcPs)
ty [RdrName] -> [RdrName] -> [RdrName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [RdrName]
resultVars),
                LFieldOcc GhcPs
name <- [LFieldOcc GhcPs]
cd_fld_names
        ]
    ConDeclGADT {con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args = RecCon (L SrcSpan
_ [LConDeclField GhcPs]
args), GenLocated SrcSpan (HsType GhcPs)
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty :: GenLocated SrcSpan (HsType GhcPs)
con_res_ty, [Located (IdP GhcPs)]
con_names :: forall pass. ConDecl pass -> [Located (IdP pass)]
con_names :: [Located (IdP GhcPs)]
con_names} ->
         [ (GenLocated SrcSpan RdrName
-> SrcSpanLess (GenLocated SrcSpan RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan RdrName
con_name, LFieldOcc GhcPs -> SrcSpanLess (LFieldOcc GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LFieldOcc GhcPs
name, GenLocated SrcSpan (HsType GhcPs)
-> SrcSpanLess (GenLocated SrcSpan (HsType GhcPs))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan (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 = GenLocated SrcSpan (HsType GhcPs)
ty} <- [LConDeclField GhcPs] -> [ConDeclField GhcPs]
forall from to. Biplate from to => from -> [to]
universeBi [LConDeclField GhcPs]
args,
             [GenLocated SrcSpan RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PluginEnv =>
GenLocated SrcSpan (HsType GhcPs) -> [GenLocated SrcSpan RdrName]
GenLocated SrcSpan (HsType GhcPs) -> [GenLocated SrcSpan RdrName]
freeTyVars GenLocated SrcSpan (HsType GhcPs)
ty [GenLocated SrcSpan RdrName]
-> [GenLocated SrcSpan RdrName] -> [GenLocated SrcSpan RdrName]
forall a. Eq a => [a] -> [a] -> [a]
\\ PluginEnv =>
GenLocated SrcSpan (HsType GhcPs) -> [GenLocated SrcSpan RdrName]
GenLocated SrcSpan (HsType GhcPs) -> [GenLocated SrcSpan RdrName]
freeTyVars GenLocated SrcSpan (HsType GhcPs)
con_res_ty),
             LFieldOcc GhcPs
name <- [LFieldOcc GhcPs]
cd_fld_names,
             GenLocated SrcSpan RdrName
con_name <- [Located (IdP GhcPs)]
[GenLocated SrcSpan RdrName]
con_names
         ]
    ConDecl GhcPs
_ -> []
    where
        freeTyVars' :: GenLocated SrcSpan (HsType GhcPs) -> [RdrName]
freeTyVars' GenLocated SrcSpan (HsType GhcPs)
ty = GenLocated SrcSpan RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (GenLocated SrcSpan RdrName -> RdrName)
-> [GenLocated SrcSpan RdrName] -> [RdrName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginEnv =>
GenLocated SrcSpan (HsType GhcPs) -> [GenLocated SrcSpan RdrName]
GenLocated SrcSpan (HsType GhcPs) -> [GenLocated SrcSpan RdrName]
freeTyVars GenLocated SrcSpan (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 (L SrcSpan
o (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs mid :: LHsExpr GhcPs
mid@(LHsExpr GhcPs -> Bool
isDot -> Bool
True) LHsExpr GhcPs
rhs))
    | LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a b. Located a -> Located b -> Bool
adjacent LHsExpr GhcPs
lhs LHsExpr GhcPs
mid, LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a b. Located a -> Located 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 (LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs))
-> LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
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 GenLocated SrcSpan (HsType GhcPs)
sel <- LHsExpr GhcPs -> Maybe (GenLocated SrcSpan (HsType GhcPs))
getSelector LHsExpr GhcPs
rhs
    = LHsExpr GhcPs -> LHsExpr GhcPs
onExp (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
forall e. SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL SrcSpan
o (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
lhsOp (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
rhsApp (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
lhsApp (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
rhsRec (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
mkParen (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> LHsExpr GhcPs
mkVar RdrName
var_getField LHsExpr GhcPs -> GenLocated SrcSpan (HsType GhcPs) -> LHsExpr GhcPs
`mkAppType` GenLocated SrcSpan (HsType GhcPs)
sel LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`mkApp` LHsExpr GhcPs
lhs

-- Turn (.foo.bar) into getField calls
onExp (L SrcSpan
o (SectionR XSectionR GhcPs
_ mid :: LHsExpr GhcPs
mid@(LHsExpr GhcPs -> Bool
isDot -> Bool
True) LHsExpr GhcPs
rhs))
    | LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a b. Located a -> Located b -> Bool
adjacent LHsExpr GhcPs
mid LHsExpr GhcPs
rhs
    , SrcSpan -> SrcLoc
srcSpanStart SrcSpan
o SrcLoc -> SrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> SrcLoc
srcSpanStart (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
mid)
    , SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
o SrcLoc -> SrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> SrcLoc
srcSpanEnd (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
rhs)
    , Just [GenLocated SrcSpan (HsType GhcPs)]
sels <- LHsExpr GhcPs -> Maybe [GenLocated SrcSpan (HsType GhcPs)]
getSelectors LHsExpr GhcPs
rhs
    -- Don't bracket here. The argument came in as a section so it's
    -- already enclosed in brackets.
    = SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
forall e. SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL SrcSpan
o (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\LHsExpr GhcPs
x LHsExpr GhcPs
y -> HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExtField
XOpApp GhcPs
noE LHsExpr GhcPs
x (RdrName -> LHsExpr GhcPs
mkVar RdrName
var_dot) LHsExpr GhcPs
y) ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan (HsType GhcPs) -> LHsExpr GhcPs)
-> [GenLocated SrcSpan (HsType GhcPs)] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (RdrName -> LHsExpr GhcPs
mkVar RdrName
var_getField LHsExpr GhcPs -> GenLocated SrcSpan (HsType GhcPs) -> LHsExpr GhcPs
`mkAppType`) ([GenLocated SrcSpan (HsType GhcPs)] -> [LHsExpr GhcPs])
-> [GenLocated SrcSpan (HsType GhcPs)] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpan (HsType GhcPs)]
-> [GenLocated SrcSpan (HsType GhcPs)]
forall a. [a] -> [a]
reverse [GenLocated SrcSpan (HsType GhcPs)]
sels

-- Turn a{b=c, ...} into setField calls
onExp (L SrcSpan
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 -> [LHsRecUpdField p]
rupd_flds=LHsRecUpdField GhcPs
fld:[LHsRecUpdField GhcPs]
flds})
    | Int -> LHsExpr GhcPs -> LHsRecUpdField GhcPs -> Bool
forall a b. Int -> Located a -> Located b -> Bool
adjacentBy Int
1 LHsExpr GhcPs
rupd_expr LHsRecUpdField GhcPs
fld
    = LHsExpr GhcPs -> LHsExpr GhcPs
onExp (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> LHsExpr GhcPs
forall l (p :: Pass).
LHsExpr GhcPs
-> [GenLocated
      l (HsRecField' (AmbiguousFieldOcc (GhcPass p)) (LHsExpr GhcPs))]
-> LHsExpr GhcPs
f LHsExpr GhcPs
rupd_expr ([LHsRecUpdField GhcPs] -> LHsExpr GhcPs)
-> [LHsRecUpdField GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsRecUpdField GhcPs
fldLHsRecUpdField GhcPs
-> [LHsRecUpdField GhcPs] -> [LHsRecUpdField GhcPs]
forall a. a -> [a] -> [a]
:[LHsRecUpdField GhcPs]
flds
    where
        f :: LHsExpr GhcPs
-> [GenLocated
      l (HsRecField' (AmbiguousFieldOcc (GhcPass p)) (LHsExpr GhcPs))]
-> LHsExpr GhcPs
f LHsExpr GhcPs
expr [] = LHsExpr GhcPs
expr
        f LHsExpr GhcPs
expr (L l
_ (HsRecField ((AmbiguousFieldOcc (GhcPass p) -> RdrName)
-> Located (AmbiguousFieldOcc (GhcPass p))
-> GenLocated SrcSpan RdrName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AmbiguousFieldOcc (GhcPass p) -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc -> GenLocated SrcSpan RdrName
lbl) LHsExpr GhcPs
arg Bool
pun) : [GenLocated
   l (HsRecField' (AmbiguousFieldOcc (GhcPass p)) (LHsExpr GhcPs))]
flds)
            | let sel :: GenLocated SrcSpan (HsType GhcPs)
sel = GenLocated SrcSpan RdrName -> GenLocated SrcSpan (HsType GhcPs)
mkSelector GenLocated SrcSpan RdrName
lbl
            , let arg2 :: LHsExpr GhcPs
arg2 = if Bool
pun then HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noE Located (IdP GhcPs)
GenLocated SrcSpan RdrName
lbl else LHsExpr GhcPs
arg
            , let expr2 :: LHsExpr GhcPs
expr2 = LHsExpr GhcPs -> LHsExpr GhcPs
mkParen (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> LHsExpr GhcPs
mkVar RdrName
var_setField LHsExpr GhcPs -> GenLocated SrcSpan (HsType GhcPs) -> LHsExpr GhcPs
`mkAppType` GenLocated SrcSpan (HsType GhcPs)
sel LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`mkApp` LHsExpr GhcPs
expr LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`mkApp` LHsExpr GhcPs
arg2  -- 'expr' never needs bracketing.
            = LHsExpr GhcPs
-> [GenLocated
      l (HsRecField' (AmbiguousFieldOcc (GhcPass p)) (LHsExpr GhcPs))]
-> LHsExpr GhcPs
f LHsExpr GhcPs
expr2 [GenLocated
   l (HsRecField' (AmbiguousFieldOcc (GhcPass p)) (LHsExpr GhcPs))]
flds

onExp LHsExpr GhcPs
x = (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall on. Uniplate on => (on -> on) -> on -> on
descend LHsExpr GhcPs -> LHsExpr GhcPs
onExp LHsExpr GhcPs
x


mkSelector :: Located GHC.RdrName -> LHsType GhcPs
mkSelector :: GenLocated SrcSpan RdrName -> GenLocated SrcSpan (HsType GhcPs)
mkSelector (L SrcSpan
o RdrName
x) = SrcSpan -> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
o (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XTyLit GhcPs -> HsTyLit -> HsType GhcPs
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
XTyLit GhcPs
noE (HsTyLit -> HsType GhcPs) -> HsTyLit -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ SourceText -> FastString -> HsTyLit
HsStrTy SourceText
GHC.NoSourceText (FastString -> HsTyLit) -> FastString -> HsTyLit
forall a b. (a -> b) -> a -> b
$ OccName -> FastString
GHC.occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
GHC.rdrNameOcc RdrName
x

getSelector :: LHsExpr GhcPs -> Maybe (LHsType GhcPs)
getSelector :: LHsExpr GhcPs -> Maybe (GenLocated SrcSpan (HsType GhcPs))
getSelector (L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
o IdP GhcPs
sym)))
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RdrName -> Bool
GHC.isQual IdP GhcPs
RdrName
sym
    = GenLocated SrcSpan (HsType GhcPs)
-> Maybe (GenLocated SrcSpan (HsType GhcPs))
forall a. a -> Maybe a
Just (GenLocated SrcSpan (HsType GhcPs)
 -> Maybe (GenLocated SrcSpan (HsType GhcPs)))
-> GenLocated SrcSpan (HsType GhcPs)
-> Maybe (GenLocated SrcSpan (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan RdrName -> GenLocated SrcSpan (HsType GhcPs)
mkSelector (GenLocated SrcSpan RdrName -> GenLocated SrcSpan (HsType GhcPs))
-> GenLocated SrcSpan RdrName -> GenLocated SrcSpan (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
o IdP GhcPs
RdrName
sym
getSelector LHsExpr GhcPs
_ = Maybe (GenLocated SrcSpan (HsType 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 [GenLocated SrcSpan (HsType GhcPs)]
getSelectors (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs mid :: LHsExpr GhcPs
mid@(LHsExpr GhcPs -> Bool
isDot -> Bool
True) LHsExpr GhcPs
rhs))
    | LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a b. Located a -> Located b -> Bool
adjacent LHsExpr GhcPs
lhs LHsExpr GhcPs
mid, LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a b. Located a -> Located b -> Bool
adjacent LHsExpr GhcPs
mid LHsExpr GhcPs
rhs
    , Just GenLocated SrcSpan (HsType GhcPs)
post <- LHsExpr GhcPs -> Maybe (GenLocated SrcSpan (HsType GhcPs))
getSelector LHsExpr GhcPs
rhs
    , Just [GenLocated SrcSpan (HsType GhcPs)]
pre <- LHsExpr GhcPs -> Maybe [GenLocated SrcSpan (HsType GhcPs)]
getSelectors LHsExpr GhcPs
lhs
    = [GenLocated SrcSpan (HsType GhcPs)]
-> Maybe [GenLocated SrcSpan (HsType GhcPs)]
forall a. a -> Maybe a
Just ([GenLocated SrcSpan (HsType GhcPs)]
 -> Maybe [GenLocated SrcSpan (HsType GhcPs)])
-> [GenLocated SrcSpan (HsType GhcPs)]
-> Maybe [GenLocated SrcSpan (HsType GhcPs)]
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpan (HsType GhcPs)]
pre [GenLocated SrcSpan (HsType GhcPs)]
-> [GenLocated SrcSpan (HsType GhcPs)]
-> [GenLocated SrcSpan (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpan (HsType GhcPs)
post]
getSelectors LHsExpr GhcPs
x = (GenLocated SrcSpan (HsType GhcPs)
-> [GenLocated SrcSpan (HsType GhcPs)]
-> [GenLocated SrcSpan (HsType GhcPs)]
forall a. a -> [a] -> [a]
:[]) (GenLocated SrcSpan (HsType GhcPs)
 -> [GenLocated SrcSpan (HsType GhcPs)])
-> Maybe (GenLocated SrcSpan (HsType GhcPs))
-> Maybe [GenLocated SrcSpan (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcPs -> Maybe (GenLocated SrcSpan (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 SrcSpan
l (HsApp XApp GhcPs
e LHsExpr GhcPs
x LHsExpr GhcPs
y)) = (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
e LHsExpr GhcPs
x, LHsExpr GhcPs
y)
getAppRHS LHsExpr GhcPs
x = (LHsExpr GhcPs -> LHsExpr GhcPs
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 SrcSpan
l (HsApp XApp GhcPs
e LHsExpr GhcPs
x LHsExpr GhcPs
y)) = ((LHsExpr GhcPs -> LHsExpr GhcPs)
 -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (\LHsExpr GhcPs -> LHsExpr GhcPs
c -> SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\LHsExpr GhcPs
x -> XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
e LHsExpr GhcPs
x LHsExpr GhcPs
y) (LHsExpr GhcPs -> HsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs
c) ((LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
 -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getAppLHS LHsExpr GhcPs
x
getAppLHS LHsExpr GhcPs
x = (LHsExpr GhcPs -> LHsExpr GhcPs
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 SrcSpan
l (OpApp XOpApp GhcPs
x LHsExpr GhcPs
y LHsExpr GhcPs
p LHsExpr GhcPs
z)) = (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
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 = (LHsExpr GhcPs -> LHsExpr GhcPs
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 SrcSpan
l r :: HsExpr GhcPs
r@RecordUpd{}) = ((LHsExpr GhcPs -> LHsExpr GhcPs)
 -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (\LHsExpr GhcPs -> LHsExpr GhcPs
c LHsExpr GhcPs
x -> SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcPs
r{rupd_expr :: LHsExpr GhcPs
rupd_expr=SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs
forall e. SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e
setL (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsExpr GhcPs -> SrcSpan) -> LHsExpr GhcPs -> SrcSpan
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall p. HsExpr p -> LHsExpr p
rupd_expr HsExpr GhcPs
r) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
c LHsExpr GhcPs
x}) ((LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
 -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
getRec (LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs))
-> LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> LHsExpr GhcPs
forall p. HsExpr p -> LHsExpr p
rupd_expr HsExpr GhcPs
r
getRec LHsExpr GhcPs
x = (LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id, LHsExpr GhcPs
x)

-- | Is it equal to: .
isDot :: LHsExpr GhcPs -> Bool
isDot :: LHsExpr GhcPs -> Bool
isDot (L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
op))) = IdP GhcPs
RdrName
op RdrName -> RdrName -> Bool
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 = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs)
-> (RdrName -> HsExpr GhcPs) -> RdrName -> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noE (GenLocated SrcSpan RdrName -> HsExpr GhcPs)
-> (RdrName -> GenLocated SrcSpan RdrName)
-> RdrName
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL

mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs
mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs
mkParen = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noE

mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp LHsExpr GhcPs
x LHsExpr GhcPs
y = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> GenLocated SrcSpan e
noL (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcPs
noE LHsExpr GhcPs
x LHsExpr GhcPs
y

-- | Are the end of a and the start of b next to each other, no white space
adjacent :: Located a -> Located b -> Bool
adjacent :: Located a -> Located b -> Bool
adjacent = Int -> Located a -> Located b -> Bool
forall a b. Int -> Located a -> Located b -> Bool
adjacentBy Int
0

-- | Are the end of a and the start of b next to each other, no white space
adjacentBy :: Int -> Located a -> Located b -> Bool
adjacentBy :: Int -> Located a -> Located b -> Bool
adjacentBy Int
i (L (SrcLoc -> Maybe RealSrcLoc
realSrcLoc (SrcLoc -> Maybe RealSrcLoc)
-> (SrcSpan -> SrcLoc) -> SrcSpan -> Maybe RealSrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcLoc
srcSpanEnd -> Just RealSrcLoc
a) a
_) (L (SrcLoc -> Maybe RealSrcLoc
realSrcLoc (SrcLoc -> Maybe RealSrcLoc)
-> (SrcSpan -> SrcLoc) -> SrcSpan -> Maybe RealSrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcLoc
srcSpanStart -> Just RealSrcLoc
b) b
_) =
    RealSrcLoc -> FastString
srcLocFile RealSrcLoc
a FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcLoc -> FastString
srcLocFile RealSrcLoc
b Bool -> Bool -> Bool
&&
    RealSrcLoc -> Int
srcLocLine RealSrcLoc
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcLoc -> Int
srcLocLine RealSrcLoc
b Bool -> Bool -> Bool
&&
    RealSrcLoc -> Int
srcLocCol RealSrcLoc
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcLoc -> Int
srcLocCol RealSrcLoc
b
adjacentBy Int
_ Located a
_ Located 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 = XQualTy GhcPs
-> LHsContext GhcPs
-> GenLocated SrcSpan (HsType GhcPs)
-> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy NoExtField
XQualTy GhcPs
noE ([GenLocated SrcSpan (HsType GhcPs)] -> LHsContext GhcPs
forall e. e -> GenLocated SrcSpan e
noL [GenLocated SrcSpan (HsType GhcPs)]
qualCtx) (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (HsType GhcPs -> HsType GhcPs
fAbs HsType GhcPs
tyVar))
    where
        var :: RdrName
var = Name -> RdrName
GHC.nameRdrName (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> Name
GHC.mkUnboundName (OccName -> Name) -> OccName -> Name
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkTyVarOcc CommandLineOption
"aplg"

        tyVar :: HsType GhcPs
        tyVar :: HsType GhcPs
tyVar = XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcPs
noE PromotionFlag
GHC.NotPromoted (RdrName -> GenLocated SrcSpan RdrName
forall e. e -> GenLocated SrcSpan e
noL RdrName
var)

        var_tilde :: RdrName
var_tilde = Module -> OccName -> RdrName
GHC.mkOrig Module
GHC.gHC_TYPES (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> OccName
GHC.mkClsOcc CommandLineOption
"~"

        eqQual :: HsType GhcPs
        eqQual :: HsType GhcPs
eqQual = XOpTy GhcPs
-> GenLocated SrcSpan (HsType GhcPs)
-> Located (IdP GhcPs)
-> GenLocated SrcSpan (HsType GhcPs)
-> HsType GhcPs
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy NoExtField
XOpTy GhcPs
noE (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (XParTy GhcPs -> GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy NoExtField
XParTy GhcPs
noE (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL HsType GhcPs
rArg))) (SrcSpanLess (GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc RdrName
SrcSpanLess (GenLocated SrcSpan RdrName)
var_tilde) (SrcSpanLess (GenLocated SrcSpan (HsType GhcPs))
-> GenLocated SrcSpan (HsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcPs
SrcSpanLess (GenLocated SrcSpan (HsType GhcPs))
tyVar)

        qualCtx :: HsContext GhcPs
        qualCtx :: [GenLocated SrcSpan (HsType GhcPs)]
qualCtx = [HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL (XParTy GhcPs -> GenLocated SrcSpan (HsType GhcPs) -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy NoExtField
XParTy GhcPs
noE (HsType GhcPs -> GenLocated SrcSpan (HsType GhcPs)
forall e. e -> GenLocated SrcSpan e
noL HsType GhcPs
eqQual))]