{-# LANGUAGE CPP                 #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.FreshT
import Data.Record.Anon.Internal.Plugin.Source.GhcShim
import Data.Record.Anon.Internal.Plugin.Source.Names
import Data.Record.Anon.Internal.Plugin.Source.Options

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

sourcePlugin :: [String] -> HsParsedModule -> Hsc HsParsedModule
sourcePlugin :: [String] -> HsParsedModule -> Hsc HsParsedModule
sourcePlugin [String]
rawOpts
             parsed :: HsParsedModule
parsed@HsParsedModule{
                 hpm_module :: HsParsedModule -> Located (HsModule (GhcPass 'Parsed))
hpm_module = L SrcSpan
l modl :: HsModule (GhcPass 'Parsed)
modl@HsModule{hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
hsmodDecls = [LHsDecl (GhcPass 'Parsed)]
decls}
               } = do

    [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
decls' <- FreshT Hsc [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
-> Hsc [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
forall a. FreshT Hsc a -> Hsc a
runFreshHsc (FreshT Hsc [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
 -> Hsc [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))])
-> FreshT Hsc [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
-> Hsc [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
forall a b. (a -> b) -> a -> b
$
                GenericM (FreshT Hsc) -> GenericM (FreshT Hsc)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM
                  ((LHsExpr (GhcPass 'Parsed)
 -> FreshT Hsc (LHsExpr (GhcPass 'Parsed)))
-> a -> FreshT Hsc a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM ((LHsExpr (GhcPass 'Parsed)
  -> FreshT Hsc (LHsExpr (GhcPass 'Parsed)))
 -> a -> FreshT Hsc a)
-> (LHsExpr (GhcPass 'Parsed)
    -> FreshT Hsc (LHsExpr (GhcPass 'Parsed)))
-> a
-> FreshT Hsc a
forall a b. (a -> b) -> a -> b
$ Options
-> LHsExpr (GhcPass 'Parsed)
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
transformExpr Options
opts)
                  [LHsDecl (GhcPass 'Parsed)]
[GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
decls
    HsParsedModule -> Hsc HsParsedModule
forall a. a -> Hsc a
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 = L l $ modl { hsmodDecls = decls' }
      }
  where
    opts :: Options
    opts :: Options
opts = [String] -> Options
parseOpts [String]
rawOpts

transformExpr :: Options -> LHsExpr GhcPs -> FreshT Hsc (LHsExpr GhcPs)
transformExpr :: Options
-> LHsExpr (GhcPass 'Parsed)
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
transformExpr options :: Options
options@Options{Bool
debug :: Bool
debug :: Options -> Bool
debug} e :: LHsExpr (GhcPass 'Parsed)
e@(LHsExpr (GhcPass 'Parsed) -> Located (HsExpr (GhcPass 'Parsed))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
-> Located (HsExpr (GhcPass 'Parsed))
forall a e. LocatedAn a e -> Located e
reLoc -> L SrcSpan
l HsExpr (GhcPass 'Parsed)
expr)
  | RecordCon XRecordCon (GhcPass 'Parsed)
_ext (L SrcSpanAnnN
_ RdrName
nm) (HsRecFields [LHsRecField (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
flds Maybe (XRec (GhcPass 'Parsed) RecFieldsDotDot)
dotdot) <- HsExpr (GhcPass 'Parsed)
expr
  , Unqual OccName
nm' <- RdrName
nm
  , Maybe (XRec (GhcPass 'Parsed) RecFieldsDotDot)
Nothing    <- Maybe (XRec (GhcPass 'Parsed) RecFieldsDotDot)
dotdot
  , Just Mode
mode  <- String -> Maybe Mode
parseMode (OccName -> String
occNameString OccName
nm')
  , Just [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
flds' <- (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))
 -> Maybe
      (FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))]
-> Maybe
     [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsRecField (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> Maybe (FastString, LHsExpr (GhcPass 'Parsed))
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))
-> Maybe
     (FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
getField [LHsRecField (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))]
flds
  = do LargeAnonNames
names <- Hsc LargeAnonNames -> FreshT Hsc LargeAnonNames
forall (m :: * -> *) a. Monad m => m a -> FreshT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc LargeAnonNames -> FreshT Hsc LargeAnonNames)
-> Hsc LargeAnonNames -> FreshT Hsc LargeAnonNames
forall a b. (a -> b) -> a -> b
$ Mode -> Hsc LargeAnonNames
getLargeAnonNames Mode
mode
       GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e'    <- Options
-> LargeAnonNames
-> SrcSpan
-> [(FastString, LHsExpr (GhcPass 'Parsed))]
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
anonRec Options
options LargeAnonNames
names SrcSpan
l [(FastString, LHsExpr (GhcPass 'Parsed))]
[(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
flds'
       Bool -> FreshT Hsc () -> FreshT Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (FreshT Hsc () -> FreshT Hsc ()) -> FreshT Hsc () -> FreshT Hsc ()
forall a b. (a -> b) -> a -> b
$ Hsc () -> FreshT Hsc ()
forall (m :: * -> *) a. Monad m => m a -> FreshT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc () -> FreshT Hsc ()) -> Hsc () -> FreshT Hsc ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l (LHsExpr (GhcPass 'Parsed) -> SDoc
debugMsg LHsExpr (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e')
       GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
-> FreshT Hsc (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
forall a. a -> FreshT Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e'

  | Bool
otherwise
  = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
-> FreshT Hsc (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
forall a. a -> FreshT Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e
  where
    getField ::
         LHsRecField GhcPs (LHsExpr GhcPs)
      -> Maybe (FastString, LHsExpr GhcPs)
#if __GLASGOW_HASKELL__ < 904
    getField (L _ (HsRecField
                    { hsRecFieldLbl = L _ fieldOcc
                    , hsRecFieldArg = arg
                    , hsRecPun = pun }))
#else
    getField :: LHsRecField (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> Maybe (FastString, LHsExpr (GhcPass 'Parsed))
getField (L SrcSpanAnnA
_ (HsFieldBind
                    { hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = L SrcAnn NoEpAnns
_ FieldOcc (GhcPass 'Parsed)
fieldOcc
                    , hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
arg
                    , hfbPun :: forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun = Bool
pun }))
#endif
      | FieldOcc XCFieldOcc (GhcPass 'Parsed)
_ (L SrcSpanAnnN
_ RdrName
nm) <- FieldOcc (GhcPass 'Parsed)
fieldOcc
      , Unqual OccName
nm' <- RdrName
nm
      , Bool -> Bool
not Bool
pun
      = (FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Maybe
     (FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
forall a. a -> Maybe a
Just (OccName -> FastString
occNameFS OccName
nm', GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
arg)

      | Bool
otherwise
      = Maybe (FastString, LHsExpr (GhcPass 'Parsed))
Maybe
  (FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
forall a. Maybe a
Nothing

debugMsg :: LHsExpr GhcPs -> SDoc
debugMsg :: LHsExpr (GhcPass 'Parsed) -> SDoc
debugMsg LHsExpr (GhcPass 'Parsed)
expr = Depth -> SDoc -> SDoc
pprSetDepth Depth
AllTheWay (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"large-records: splicing in the following expression:"
    , GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
expr
    ]

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

anonRec ::
     Options
  -> LargeAnonNames
  -> SrcSpan
  -> [(FastString, LHsExpr GhcPs)]
  -> FreshT Hsc (LHsExpr GhcPs)
anonRec :: Options
-> LargeAnonNames
-> SrcSpan
-> [(FastString, LHsExpr (GhcPass 'Parsed))]
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
anonRec Options{Bool
typelet :: Bool
typelet :: Options -> Bool
typelet, Bool
noapply :: Bool
noapply :: Options -> Bool
noapply} names :: LargeAnonNames
names@LargeAnonNames{RdrName
largeAnon_empty :: RdrName
largeAnon_insert :: RdrName
largeAnon_applyPending :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_letInsertAs :: RdrName
typelet_castEqual :: RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
typelet_castEqual :: LargeAnonNames -> RdrName
..} SrcSpan
l = \[(FastString, LHsExpr (GhcPass 'Parsed))]
fields ->
    LHsExpr (GhcPass 'Parsed) -> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
-> FreshT Hsc (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
applyDiff (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
 -> FreshT Hsc (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))
-> FreshT Hsc (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> FreshT Hsc (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(FastString, LHsExpr (GhcPass 'Parsed))]
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
go [(FastString, LHsExpr (GhcPass 'Parsed))]
fields
  where
    go :: [(FastString, LHsExpr GhcPs)] -> FreshT Hsc (LHsExpr GhcPs)
    go :: [(FastString, LHsExpr (GhcPass 'Parsed))]
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
go [(FastString, LHsExpr (GhcPass 'Parsed))]
fields
      | [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, LHsExpr (GhcPass 'Parsed))]
[(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
fields = do
          LHsExpr (GhcPass 'Parsed) -> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
forall a. a -> FreshT Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Parsed)
 -> FreshT Hsc (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_empty
      | Bool -> Bool
not Bool
typelet = do
          Hsc (LHsExpr (GhcPass 'Parsed))
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
forall (m :: * -> *) a. Monad m => m a -> FreshT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc (LHsExpr (GhcPass 'Parsed))
 -> FreshT Hsc (LHsExpr (GhcPass 'Parsed)))
-> Hsc (LHsExpr (GhcPass 'Parsed))
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ LargeAnonNames
-> SrcSpan
-> [(FastString, LHsExpr (GhcPass 'Parsed))]
-> Hsc (LHsExpr (GhcPass 'Parsed))
recordWithoutTypelet LargeAnonNames
names SrcSpan
l [(FastString, LHsExpr (GhcPass 'Parsed))]
fields
      | Bool
otherwise = do
          RdrName
p       <- SrcSpan -> String -> FreshT Hsc RdrName
forall (m :: * -> *).
MonadIO m =>
SrcSpan -> String -> FreshT m RdrName
freshVar SrcSpan
l String
"p"
          [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
  RdrName)]
fields' <- ((FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
 -> FreshT
      Hsc
      (FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
       RdrName))
-> [(FastString,
     GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
-> FreshT
     Hsc
     [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
       RdrName)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(FastString
n, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e) -> (FastString
n,GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e,) (RdrName
 -> (FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
     RdrName))
-> FreshT Hsc RdrName
-> FreshT
     Hsc
     (FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
      RdrName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> String -> FreshT Hsc RdrName
forall (m :: * -> *).
MonadIO m =>
SrcSpan -> String -> FreshT m RdrName
freshVar SrcSpan
l String
"xs") [(FastString, LHsExpr (GhcPass 'Parsed))]
[(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
fields
          Hsc (LHsExpr (GhcPass 'Parsed))
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
forall (m :: * -> *) a. Monad m => m a -> FreshT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Hsc (LHsExpr (GhcPass 'Parsed))
 -> FreshT Hsc (LHsExpr (GhcPass 'Parsed)))
-> Hsc (LHsExpr (GhcPass 'Parsed))
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ LargeAnonNames
-> SrcSpan
-> RdrName
-> [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
-> Hsc (LHsExpr (GhcPass 'Parsed))
recordWithTypelet LargeAnonNames
names SrcSpan
l RdrName
p [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
[(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
  RdrName)]
fields'

    applyDiff :: LHsExpr GhcPs -> FreshT Hsc (LHsExpr GhcPs)
    applyDiff :: LHsExpr (GhcPass 'Parsed) -> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
applyDiff LHsExpr (GhcPass 'Parsed)
e
      | Bool
noapply   = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
-> FreshT Hsc (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
forall a. a -> FreshT Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e
      | Bool
otherwise = LHsExpr (GhcPass 'Parsed) -> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
forall a. a -> FreshT Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Parsed)
 -> FreshT Hsc (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_applyPending LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`mkHsApp` LHsExpr (GhcPass 'Parsed)
e

recordWithoutTypelet ::
     LargeAnonNames
  -> SrcSpan
  -> [(FastString, LHsExpr GhcPs)]
  -> Hsc (LHsExpr GhcPs)
recordWithoutTypelet :: LargeAnonNames
-> SrcSpan
-> [(FastString, LHsExpr (GhcPass 'Parsed))]
-> Hsc (LHsExpr (GhcPass 'Parsed))
recordWithoutTypelet LargeAnonNames{RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
typelet_castEqual :: LargeAnonNames -> RdrName
largeAnon_empty :: RdrName
largeAnon_insert :: RdrName
largeAnon_applyPending :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_letInsertAs :: RdrName
typelet_castEqual :: RdrName
..} SrcSpan
l = \[(FastString, LHsExpr (GhcPass 'Parsed))]
fields -> do
    LHsExpr (GhcPass 'Parsed) -> Hsc (LHsExpr (GhcPass 'Parsed))
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Parsed) -> Hsc (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed) -> Hsc (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ [(FastString, LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
go [(FastString, LHsExpr (GhcPass 'Parsed))]
fields
  where
    go :: [(FastString, LHsExpr GhcPs)] -> LHsExpr GhcPs
    go :: [(FastString, LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
go []         = SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_empty
    go ((FastString
n,LHsExpr (GhcPass 'Parsed)
e):[(FastString, LHsExpr (GhcPass 'Parsed))]
fs) = SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_insert LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
`mkHsApps` [SrcSpan -> FastString -> LHsExpr (GhcPass 'Parsed)
mkLabel SrcSpan
l FastString
n, LHsExpr (GhcPass 'Parsed)
e, [(FastString, LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
go [(FastString, LHsExpr (GhcPass 'Parsed))]
fs]

-- | Experimental support for typelet
--
-- See documentation of 'letRecordT' and 'letInsertAs'.
recordWithTypelet ::
     LargeAnonNames
  -> SrcSpan
  -> RdrName                                -- ^ Fresh var for the proxy
  -> [(FastString, LHsExpr GhcPs, RdrName)] -- ^ Fresh var for each insert
  -> Hsc (LHsExpr GhcPs)
recordWithTypelet :: LargeAnonNames
-> SrcSpan
-> RdrName
-> [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
-> Hsc (LHsExpr (GhcPass 'Parsed))
recordWithTypelet LargeAnonNames{RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
typelet_castEqual :: LargeAnonNames -> RdrName
largeAnon_empty :: RdrName
largeAnon_insert :: RdrName
largeAnon_applyPending :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_letInsertAs :: RdrName
typelet_castEqual :: RdrName
..} SrcSpan
l RdrName
p = \[(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
fields -> do
    LHsExpr (GhcPass 'Parsed) -> Hsc (LHsExpr (GhcPass 'Parsed))
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Parsed) -> Hsc (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed) -> Hsc (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$
      LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_letRecordT) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        RdrName -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
simpleLam RdrName
p (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
typelet_castEqual) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          LHsExpr (GhcPass 'Parsed)
-> [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
-> LHsExpr (GhcPass 'Parsed)
go (SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_empty) ([(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
 -> LHsExpr (GhcPass 'Parsed))
-> [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
-> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
  RdrName)]
-> [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
     RdrName)]
forall a. [a] -> [a]
reverse [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
[(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
  RdrName)]
fields
  where
    go ::
         LHsExpr GhcPs
      -> [(FastString, LHsExpr GhcPs, RdrName)]
      -> LHsExpr GhcPs
    go :: LHsExpr (GhcPass 'Parsed)
-> [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
-> LHsExpr (GhcPass 'Parsed)
go LHsExpr (GhcPass 'Parsed)
prev []           = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp  (SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
typelet_castEqual) LHsExpr (GhcPass 'Parsed)
prev
    go LHsExpr (GhcPass 'Parsed)
prev ((FastString
n,LHsExpr (GhcPass 'Parsed)
e,RdrName
x):[(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
fs) = LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps (SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_letInsertAs) [
          SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
p
        , SrcSpan -> FastString -> LHsExpr (GhcPass 'Parsed)
mkLabel SrcSpan
l FastString
n
        , LHsExpr (GhcPass 'Parsed)
e
        , LHsExpr (GhcPass 'Parsed)
prev
        , RdrName -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
simpleLam RdrName
x (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
-> LHsExpr (GhcPass 'Parsed)
go (SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
x) [(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
fs
        ]
      where

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

mkVar :: SrcSpan -> RdrName -> LHsExpr GhcPs
mkVar :: SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
name = Located (HsExpr (GhcPass 'Parsed))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
forall e ann. Located e -> LocatedAn ann e
reLocA (Located (HsExpr (GhcPass 'Parsed))
 -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
-> Located (HsExpr (GhcPass 'Parsed))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> HsExpr (GhcPass 'Parsed) -> Located (HsExpr (GhcPass 'Parsed))
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr (GhcPass 'Parsed) -> Located (HsExpr (GhcPass 'Parsed)))
-> HsExpr (GhcPass 'Parsed) -> Located (HsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ XVar (GhcPass 'Parsed)
-> LIdP (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Parsed)
NoExtField
forall a. HasDefaultExt a => a
defExt (Located RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. Located e -> LocatedAn ann e
reLocA (Located RdrName -> GenLocated SrcSpanAnnN RdrName)
-> Located RdrName -> GenLocated SrcSpanAnnN RdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> Located 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 (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
simpleLam RdrName
x LHsExpr (GhcPass 'Parsed)
body = [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP (GhcPass 'Parsed)
RdrName
x] LHsExpr (GhcPass 'Parsed)
body