{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE ViewPatterns    #-}

module Data.Record.Anon.Internal.Plugin.Source (sourcePlugin) where

import Control.Monad
import Control.Monad.Trans
import Data.Generics (everywhereM, mkM)

import Data.Record.Anon.Internal.Plugin.Source.GhcShim
import Data.Record.Anon.Internal.Plugin.Source.Names
import Data.Record.Anon.Internal.Plugin.Source.NamingT
import Data.Record.Anon.Internal.Plugin.Source.Options

{-------------------------------------------------------------------------------
  Top-level
-------------------------------------------------------------------------------}

sourcePlugin :: [String] -> HsParsedModule -> Hsc HsParsedModule
sourcePlugin :: [String] -> HsParsedModule -> Hsc HsParsedModule
sourcePlugin [String]
opts
             parsed :: HsParsedModule
parsed@HsParsedModule{
                 hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module = L SrcSpan
l modl :: HsModule GhcPs
modl@HsModule{
                     hsmodDecls :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls   = [LHsDecl GhcPs]
decls
                   , hsmodImports :: forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports = [LImportDecl GhcPs]
imports
                   }
               } = do
    ([LHsDecl GhcPs]
decls', [ModuleName]
modls) <- NamingT Hsc [LHsDecl GhcPs] -> Hsc ([LHsDecl GhcPs], [ModuleName])
forall a. NamingT Hsc a -> Hsc (a, [ModuleName])
runNamingHsc (NamingT Hsc [LHsDecl GhcPs]
 -> Hsc ([LHsDecl GhcPs], [ModuleName]))
-> NamingT Hsc [LHsDecl GhcPs]
-> Hsc ([LHsDecl GhcPs], [ModuleName])
forall a b. (a -> b) -> a -> b
$
                         GenericM (NamingT Hsc)
-> [LHsDecl GhcPs] -> NamingT Hsc [LHsDecl GhcPs]
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM
                           ((LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
-> a -> NamingT Hsc a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM ((LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
 -> a -> NamingT Hsc a)
-> (LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
-> a
-> NamingT Hsc a
forall a b. (a -> b) -> a -> b
$ Options -> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
transformExpr (Options -> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
-> Options -> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [String] -> Options
parseOpts [String]
opts)
                           [LHsDecl GhcPs]
decls
    HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return (HsParsedModule -> Hsc HsParsedModule)
-> HsParsedModule -> Hsc HsParsedModule
forall a b. (a -> b) -> a -> b
$ HsParsedModule
parsed {
        hpm_module :: Located (HsModule GhcPs)
hpm_module = SrcSpan -> HsModule GhcPs -> Located (HsModule GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsModule GhcPs -> Located (HsModule GhcPs))
-> HsModule GhcPs -> Located (HsModule GhcPs)
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs
modl {
            hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls   = [LHsDecl GhcPs]
decls'
          , hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs]
imports [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ (ModuleName -> LImportDecl GhcPs)
-> [ModuleName] -> [LImportDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> ModuleName -> LImportDecl GhcPs
importDecl Bool
True) [ModuleName]
modls
          }
      }

transformExpr :: Options -> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
transformExpr :: Options -> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
transformExpr options :: Options
options@Options{Bool
debug :: Options -> Bool
debug :: Bool
debug} e :: LHsExpr GhcPs
e@(LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Located a -> Located a
reLoc -> L SrcSpan
l HsExpr GhcPs
expr)
  | RecordCon XRecordCon GhcPs
_ext (L SrcSpan
_ IdP GhcPs
nm) (HsRecFields [LHsRecField GhcPs (LHsExpr GhcPs)]
flds Maybe (Located Int)
dotdot) <- HsExpr GhcPs
expr
  , Unqual nm' <- IdP GhcPs
nm
  , Maybe (Located Int)
Nothing    <- Maybe (Located Int)
dotdot
  , Just Mode
mode  <- String -> Maybe Mode
parseMode (OccName -> String
occNameString OccName
nm')
  , Just [(FastString, LHsExpr GhcPs)]
flds' <- (LHsRecField GhcPs (LHsExpr GhcPs)
 -> Maybe (FastString, LHsExpr GhcPs))
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> Maybe [(FastString, LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField GhcPs (LHsExpr GhcPs)
-> Maybe (FastString, LHsExpr GhcPs)
getField [LHsRecField GhcPs (LHsExpr GhcPs)]
flds
  = do LHsExpr GhcPs
e' <- Options
-> Mode
-> SrcSpan
-> [(FastString, LHsExpr GhcPs)]
-> NamingT Hsc (LHsExpr GhcPs)
anonRec Options
options Mode
mode SrcSpan
l [(FastString, LHsExpr GhcPs)]
flds'
       Bool -> NamingT Hsc () -> NamingT Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (NamingT Hsc () -> NamingT Hsc ())
-> NamingT Hsc () -> NamingT Hsc ()
forall a b. (a -> b) -> a -> b
$ Hsc () -> NamingT Hsc ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc () -> NamingT Hsc ()) -> Hsc () -> NamingT Hsc ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l (LHsExpr GhcPs -> SDoc
debugMsg LHsExpr GhcPs
e')
       LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
e'

  | Bool
otherwise
  = LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
e
  where
    getField ::
         LHsRecField GhcPs (LHsExpr GhcPs)
      -> Maybe (FastString, LHsExpr GhcPs)
    getField :: LHsRecField GhcPs (LHsExpr GhcPs)
-> Maybe (FastString, LHsExpr GhcPs)
getField (L SrcSpan
_ (HsRecField
                    { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = L SrcSpan
_ FieldOcc GhcPs
fieldOcc
                    , hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LHsExpr GhcPs
arg
                    , hsRecPun :: forall id arg. HsRecField' id arg -> Bool
hsRecPun = Bool
pun }))
      | FieldOcc XCFieldOcc GhcPs
_ (L SrcSpan
_ RdrName
nm) <- FieldOcc GhcPs
fieldOcc
      , Unqual OccName
nm' <- RdrName
nm
      , Bool -> Bool
not Bool
pun
      = (FastString, LHsExpr GhcPs) -> Maybe (FastString, LHsExpr GhcPs)
forall a. a -> Maybe a
Just (OccName -> FastString
occNameFS OccName
nm', LHsExpr GhcPs
arg)

      | Bool
otherwise
      = Maybe (FastString, LHsExpr GhcPs)
forall a. Maybe a
Nothing

debugMsg :: LHsExpr GhcPs -> SDoc
debugMsg :: LHsExpr GhcPs -> SDoc
debugMsg LHsExpr GhcPs
expr = Depth -> SDoc -> SDoc
pprSetDepth Depth
AllTheWay (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [
      String -> SDoc
text String
"large-records: splicing in the following expression:"
    , LHsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcPs
expr
    ]

{-------------------------------------------------------------------------------
  Main translation
-------------------------------------------------------------------------------}

anonRec ::
     Options
  -> Mode
  -> SrcSpan
  -> [(FastString, LHsExpr GhcPs)]
  -> NamingT Hsc (LHsExpr GhcPs)
anonRec :: Options
-> Mode
-> SrcSpan
-> [(FastString, LHsExpr GhcPs)]
-> NamingT Hsc (LHsExpr GhcPs)
anonRec Options{Bool
typelet :: Options -> Bool
typelet :: Bool
typelet, Bool
noapply :: Options -> Bool
noapply :: Bool
noapply} Mode
mode SrcSpan
l = \[(FastString, LHsExpr GhcPs)]
fields ->
    LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
applyDiff (LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
-> NamingT Hsc (LHsExpr GhcPs) -> NamingT Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(FastString, LHsExpr GhcPs)] -> NamingT Hsc (LHsExpr GhcPs)
go [(FastString, LHsExpr GhcPs)]
fields
  where
    LargeAnonNames{RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
largeAnon_letInsertAs :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_applyPending :: RdrName
largeAnon_insert :: RdrName
largeAnon_empty :: RdrName
..} = Mode -> LargeAnonNames
largeAnonNames Mode
mode

    go :: [(FastString, LHsExpr GhcPs)] -> NamingT Hsc (LHsExpr GhcPs)
    go :: [(FastString, LHsExpr GhcPs)] -> NamingT Hsc (LHsExpr GhcPs)
go [(FastString, LHsExpr GhcPs)]
fields
      | [(FastString, LHsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, LHsExpr GhcPs)]
fields = do
          RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
largeAnon_empty
          LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
-> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
largeAnon_empty
      | Bool -> Bool
not Bool
typelet = do
          Mode
-> SrcSpan
-> [(FastString, LHsExpr GhcPs)]
-> NamingT Hsc (LHsExpr GhcPs)
recordWithoutTypelet Mode
mode SrcSpan
l [(FastString, LHsExpr GhcPs)]
fields
      | Bool
otherwise = do
          RdrName
p       <- SrcSpan -> String -> NamingT Hsc RdrName
forall (m :: * -> *).
MonadIO m =>
SrcSpan -> String -> NamingT m RdrName
freshVar SrcSpan
l String
"p"
          [(FastString, LHsExpr GhcPs, RdrName)]
fields' <- ((FastString, LHsExpr GhcPs)
 -> NamingT Hsc (FastString, LHsExpr GhcPs, RdrName))
-> [(FastString, LHsExpr GhcPs)]
-> NamingT Hsc [(FastString, LHsExpr GhcPs, RdrName)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(FastString
n, LHsExpr GhcPs
e) -> (FastString
n,LHsExpr GhcPs
e,) (RdrName -> (FastString, LHsExpr GhcPs, RdrName))
-> NamingT Hsc RdrName
-> NamingT Hsc (FastString, LHsExpr GhcPs, RdrName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> String -> NamingT Hsc RdrName
forall (m :: * -> *).
MonadIO m =>
SrcSpan -> String -> NamingT m RdrName
freshVar SrcSpan
l String
"xs") [(FastString, LHsExpr GhcPs)]
fields
          Mode
-> SrcSpan
-> RdrName
-> [(FastString, LHsExpr GhcPs, RdrName)]
-> NamingT Hsc (LHsExpr GhcPs)
recordWithTypelet Mode
mode SrcSpan
l RdrName
p [(FastString, LHsExpr GhcPs, RdrName)]
fields'

    applyDiff :: LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
    applyDiff :: LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
applyDiff LHsExpr GhcPs
e
      | Bool
noapply   = LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
e
      | Bool
otherwise = do
          RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
largeAnon_applyPending
          LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
-> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
largeAnon_applyPending LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`mkHsApp` LHsExpr GhcPs
e

recordWithoutTypelet ::
     Mode
  -> SrcSpan
  -> [(FastString, LHsExpr GhcPs)]
  -> NamingT Hsc (LHsExpr GhcPs)
recordWithoutTypelet :: Mode
-> SrcSpan
-> [(FastString, LHsExpr GhcPs)]
-> NamingT Hsc (LHsExpr GhcPs)
recordWithoutTypelet Mode
mode SrcSpan
l = \[(FastString, LHsExpr GhcPs)]
fields -> do
    RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
largeAnon_empty
    RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
largeAnon_insert
    LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
-> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [(FastString, LHsExpr GhcPs)] -> LHsExpr GhcPs
go [(FastString, LHsExpr GhcPs)]
fields
  where
    LargeAnonNames{RdrName
largeAnon_letInsertAs :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_applyPending :: RdrName
largeAnon_insert :: RdrName
largeAnon_empty :: RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
..} = Mode -> LargeAnonNames
largeAnonNames Mode
mode

    go :: [(FastString, LHsExpr GhcPs)] -> LHsExpr GhcPs
    go :: [(FastString, LHsExpr GhcPs)] -> LHsExpr GhcPs
go []         = SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
largeAnon_empty
    go ((FastString
n,LHsExpr GhcPs
e):[(FastString, LHsExpr GhcPs)]
fs) = SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
largeAnon_insert LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
`mkHsApps` [SrcSpan -> FastString -> LHsExpr GhcPs
mkLabel SrcSpan
l FastString
n, LHsExpr GhcPs
e, [(FastString, LHsExpr GhcPs)] -> LHsExpr GhcPs
go [(FastString, LHsExpr GhcPs)]
fs]

-- | Experimental support for typelet
--
-- See documentation of 'letRecordT' and 'letInsertAs'.
recordWithTypelet ::
     Mode
  -> SrcSpan
  -> RdrName                                -- ^ Fresh var for the proxy
  -> [(FastString, LHsExpr GhcPs, RdrName)] -- ^ Fresh var for each insert
  -> NamingT Hsc (LHsExpr GhcPs)
recordWithTypelet :: Mode
-> SrcSpan
-> RdrName
-> [(FastString, LHsExpr GhcPs, RdrName)]
-> NamingT Hsc (LHsExpr GhcPs)
recordWithTypelet Mode
mode SrcSpan
l RdrName
p = \[(FastString, LHsExpr GhcPs, RdrName)]
fields -> do
    RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
largeAnon_empty
    RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
largeAnon_insert
    RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
largeAnon_letRecordT
    RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
largeAnon_letInsertAs
    RdrName -> NamingT Hsc ()
forall (m :: * -> *). Monad m => RdrName -> NamingT m ()
useName RdrName
typelet_castEqual

    LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs))
-> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
      LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
largeAnon_letRecordT) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
simpleLam RdrName
p (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
typelet_castEqual) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
          LHsExpr GhcPs
-> [(FastString, LHsExpr GhcPs, RdrName)] -> LHsExpr GhcPs
go (SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
largeAnon_empty) ([(FastString, LHsExpr GhcPs, RdrName)] -> LHsExpr GhcPs)
-> [(FastString, LHsExpr GhcPs, RdrName)] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ [(FastString, LHsExpr GhcPs, RdrName)]
-> [(FastString, LHsExpr GhcPs, RdrName)]
forall a. [a] -> [a]
reverse [(FastString, LHsExpr GhcPs, RdrName)]
fields
  where
    LargeAnonNames{RdrName
largeAnon_applyPending :: RdrName
largeAnon_letInsertAs :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_insert :: RdrName
largeAnon_empty :: RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
..} = Mode -> LargeAnonNames
largeAnonNames Mode
mode

    go ::
         LHsExpr GhcPs
      -> [(FastString, LHsExpr GhcPs, RdrName)]
      -> LHsExpr GhcPs
    go :: LHsExpr GhcPs
-> [(FastString, LHsExpr GhcPs, RdrName)] -> LHsExpr GhcPs
go LHsExpr GhcPs
prev []           = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp  (SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
typelet_castEqual) LHsExpr GhcPs
prev
    go LHsExpr GhcPs
prev ((FastString
n,LHsExpr GhcPs
e,RdrName
x):[(FastString, LHsExpr GhcPs, RdrName)]
fs) = LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps (SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
largeAnon_letInsertAs) [
          SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
p
        , SrcSpan -> FastString -> LHsExpr GhcPs
mkLabel SrcSpan
l FastString
n
        , LHsExpr GhcPs
e
        , LHsExpr GhcPs
prev
        , RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
simpleLam RdrName
x (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
-> [(FastString, LHsExpr GhcPs, RdrName)] -> LHsExpr GhcPs
go (SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
x) [(FastString, LHsExpr GhcPs, RdrName)]
fs
        ]
      where

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

mkVar :: SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar :: SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar SrcSpan
l RdrName
name = LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Located a -> Located a
reLocA (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> GenLocated SrcSpan (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
forall a. HasDefaultExt a => a
defExt (GenLocated SrcSpan RdrName -> GenLocated SrcSpan RdrName
forall a. Located a -> Located a
reLocA (GenLocated SrcSpan RdrName -> GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName -> GenLocated SrcSpan RdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
name)

-- | Construct simple lambda
--
-- Constructs lambda of the form
--
-- > \x -> e
simpleLam :: RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
simpleLam :: RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
simpleLam RdrName
x LHsExpr GhcPs
body = [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
(XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat IdP GhcPs
RdrName
x] LHsExpr GhcPs
body