{-# 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
hpm_module = L SrcSpan
l modl :: HsModule
modl@HsModule{hsmodDecls :: HsModule -> [LHsDecl (GhcPass 'Parsed)]
hsmodDecls = [LHsDecl (GhcPass 'Parsed)]
decls}
               } = do

    [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
decls' <- forall a. FreshT Hsc a -> Hsc a
runFreshHsc forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM
                  (forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM forall a b. (a -> b) -> a -> b
$ Options
-> LHsExpr (GhcPass 'Parsed)
-> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
transformExpr Options
opts)
                  [LHsDecl (GhcPass 'Parsed)]
decls
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HsParsedModule
parsed {
        hpm_module :: Located HsModule
hpm_module = forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall a b. (a -> b) -> a -> b
$ HsModule
modl { hsmodDecls :: [LHsDecl (GhcPass 'Parsed)]
hsmodDecls = [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
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 :: Options -> Bool
debug :: Bool
debug} e :: LHsExpr (GhcPass 'Parsed)
e@(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 (Located Int)
dotdot) <- HsExpr (GhcPass 'Parsed)
expr
  , Unqual OccName
nm' <- RdrName
nm
  , Maybe (Located Int)
Nothing    <- Maybe (Located Int)
dotdot
  , Just Mode
mode  <- String -> Maybe Mode
parseMode (OccName -> String
occNameString OccName
nm')
  , Just [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
flds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> Maybe (FastString, LHsExpr (GhcPass 'Parsed))
getField [LHsRecField (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
flds
  = do LargeAnonNames
names <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))]
flds'
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> Hsc ()
issueWarning SrcSpan
l (LHsExpr (GhcPass 'Parsed) -> SDoc
debugMsg GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e')
       forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e'

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

      | Bool
otherwise
      = 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 forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [
      String -> SDoc
text String
"large-records: splicing in the following expression:"
    , forall a. Outputable a => a -> SDoc
ppr LHsExpr (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 :: Options -> Bool
typelet :: Bool
typelet, Bool
noapply :: Options -> Bool
noapply :: Bool
noapply} names :: LargeAnonNames
names@LargeAnonNames{RdrName
typelet_castEqual :: LargeAnonNames -> RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
typelet_castEqual :: RdrName
largeAnon_letInsertAs :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_applyPending :: RdrName
largeAnon_insert :: RdrName
largeAnon_empty :: RdrName
..} SrcSpan
l = \[(FastString, LHsExpr (GhcPass 'Parsed))]
fields ->
    LHsExpr (GhcPass 'Parsed) -> FreshT Hsc (LHsExpr (GhcPass 'Parsed))
applyDiff 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
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, LHsExpr (GhcPass 'Parsed))]
fields = do
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_empty
      | Bool -> Bool
not Bool
typelet = do
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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       <- forall (m :: * -> *).
MonadIO m =>
SrcSpan -> String -> FreshT m RdrName
freshVar SrcSpan
l String
"p"
          [(FastString, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
  RdrName)]
fields' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(FastString
n, GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e) -> (FastString
n,GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
e,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
SrcSpan -> String -> FreshT m RdrName
freshVar SrcSpan
l String
"xs") [(FastString, LHsExpr (GhcPass 'Parsed))]
fields
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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, 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   = forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr (GhcPass 'Parsed)
e
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_applyPending 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
typelet_castEqual :: RdrName
largeAnon_letInsertAs :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_applyPending :: RdrName
largeAnon_insert :: RdrName
largeAnon_empty :: RdrName
typelet_castEqual :: LargeAnonNames -> RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
..} SrcSpan
l = \[(FastString, LHsExpr (GhcPass 'Parsed))]
fields -> do
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 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
typelet_castEqual :: RdrName
largeAnon_letInsertAs :: RdrName
largeAnon_letRecordT :: RdrName
largeAnon_applyPending :: RdrName
largeAnon_insert :: RdrName
largeAnon_empty :: RdrName
typelet_castEqual :: LargeAnonNames -> RdrName
largeAnon_letInsertAs :: LargeAnonNames -> RdrName
largeAnon_letRecordT :: LargeAnonNames -> RdrName
largeAnon_applyPending :: LargeAnonNames -> RdrName
largeAnon_insert :: LargeAnonNames -> RdrName
largeAnon_empty :: LargeAnonNames -> RdrName
..} SrcSpan
l RdrName
p = \[(FastString, LHsExpr (GhcPass 'Parsed), RdrName)]
fields -> do
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
largeAnon_letRecordT) forall a b. (a -> b) -> a -> b
$
        RdrName -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
simpleLam RdrName
p forall a b. (a -> b) -> a -> b
$ forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpan -> RdrName -> LHsExpr (GhcPass 'Parsed)
mkVar SrcSpan
l RdrName
typelet_castEqual) 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) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [(FastString, LHsExpr (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 []           = 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) = 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 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 = forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar forall a. HasDefaultExt a => a
defExt (forall e ann. Located e -> LocatedAn ann e
reLocA forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
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 = forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
x] LHsExpr (GhcPass 'Parsed)
body