{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
module Parsley.OverloadedQuotesPlugin.Plugin (plugin) where

import Data.Generics (GenericT, GenericQ, mkT, mkQ, everywhere, gmapT)
import GHC.Generics  (Generic)

import Parsley.PluginUtils (lookupModule, lookupNames)

#if __GLASGOW_HASKELL__ >= 900
import GHC.Driver.Plugins       (Plugin (..), defaultPlugin, purePlugin)
import GHC.Tc.Types             (TcM, TcGblEnv)


import qualified GHC               (HsGroup, GhcRn, Name, GenLocated(L), SrcSpan)
import qualified GHC.Plugins as GHC (CommandLineOption)
import qualified GHC.Tc.Utils.Monad as GHC  (getTopEnv)
#else
import Plugins       (Plugin (..), defaultPlugin, purePlugin)
import TcRnTypes     (TcGblEnv, TcM)


import qualified GHC               (HsGroup, GhcRn, Name, GenLocated(L), SrcSpan)
import qualified GhcPlugins as GHC (CommandLineOption)
import qualified TcRnMonad as GHC  (getTopEnv)
#endif

#if __GLASGOW_HASKELL__ < 810
import qualified HsExpr as Expr
#else
import qualified GHC.Hs.Expr as Expr
#endif

#if __GLASGOW_HASKELL__ >= 810
import GHC.Hs.Extension
noExt :: NoExtField
noExt :: NoExtField
noExt = NoExtField
noExtField
#else
import GHC (noExt)
#endif

type Expr = Expr.LHsExpr GHC.GhcRn

{-|
This plugin repurposes /Untyped/ Template Haskell quotes (and splices within them)
to be `Parsley.Quapplicative` values.
-}
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin { renamedResultAction :: [CommandLineOption]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
renamedResultAction = [CommandLineOption]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
overloadedQuotes, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = [CommandLineOption] -> IO PluginRecompile
purePlugin }

data QOps a = QOps {
    QOps a -> a
_code :: a,
    QOps a -> a
_val :: a,
    QOps a -> a
makeQ :: a,
    QOps a -> a
mkCode :: a,
    QOps a -> a
mkVal :: a
  } deriving (a -> QOps b -> QOps a
(a -> b) -> QOps a -> QOps b
(forall a b. (a -> b) -> QOps a -> QOps b)
-> (forall a b. a -> QOps b -> QOps a) -> Functor QOps
forall a b. a -> QOps b -> QOps a
forall a b. (a -> b) -> QOps a -> QOps b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> QOps b -> QOps a
$c<$ :: forall a b. a -> QOps b -> QOps a
fmap :: (a -> b) -> QOps a -> QOps b
$cfmap :: forall a b. (a -> b) -> QOps a -> QOps b
Functor, QOps a -> Bool
(a -> m) -> QOps a -> m
(a -> b -> b) -> b -> QOps a -> b
(forall m. Monoid m => QOps m -> m)
-> (forall m a. Monoid m => (a -> m) -> QOps a -> m)
-> (forall m a. Monoid m => (a -> m) -> QOps a -> m)
-> (forall a b. (a -> b -> b) -> b -> QOps a -> b)
-> (forall a b. (a -> b -> b) -> b -> QOps a -> b)
-> (forall b a. (b -> a -> b) -> b -> QOps a -> b)
-> (forall b a. (b -> a -> b) -> b -> QOps a -> b)
-> (forall a. (a -> a -> a) -> QOps a -> a)
-> (forall a. (a -> a -> a) -> QOps a -> a)
-> (forall a. QOps a -> [a])
-> (forall a. QOps a -> Bool)
-> (forall a. QOps a -> Int)
-> (forall a. Eq a => a -> QOps a -> Bool)
-> (forall a. Ord a => QOps a -> a)
-> (forall a. Ord a => QOps a -> a)
-> (forall a. Num a => QOps a -> a)
-> (forall a. Num a => QOps a -> a)
-> Foldable QOps
forall a. Eq a => a -> QOps a -> Bool
forall a. Num a => QOps a -> a
forall a. Ord a => QOps a -> a
forall m. Monoid m => QOps m -> m
forall a. QOps a -> Bool
forall a. QOps a -> Int
forall a. QOps a -> [a]
forall a. (a -> a -> a) -> QOps a -> a
forall m a. Monoid m => (a -> m) -> QOps a -> m
forall b a. (b -> a -> b) -> b -> QOps a -> b
forall a b. (a -> b -> b) -> b -> QOps a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: QOps a -> a
$cproduct :: forall a. Num a => QOps a -> a
sum :: QOps a -> a
$csum :: forall a. Num a => QOps a -> a
minimum :: QOps a -> a
$cminimum :: forall a. Ord a => QOps a -> a
maximum :: QOps a -> a
$cmaximum :: forall a. Ord a => QOps a -> a
elem :: a -> QOps a -> Bool
$celem :: forall a. Eq a => a -> QOps a -> Bool
length :: QOps a -> Int
$clength :: forall a. QOps a -> Int
null :: QOps a -> Bool
$cnull :: forall a. QOps a -> Bool
toList :: QOps a -> [a]
$ctoList :: forall a. QOps a -> [a]
foldl1 :: (a -> a -> a) -> QOps a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> QOps a -> a
foldr1 :: (a -> a -> a) -> QOps a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> QOps a -> a
foldl' :: (b -> a -> b) -> b -> QOps a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> QOps a -> b
foldl :: (b -> a -> b) -> b -> QOps a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> QOps a -> b
foldr' :: (a -> b -> b) -> b -> QOps a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> QOps a -> b
foldr :: (a -> b -> b) -> b -> QOps a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> QOps a -> b
foldMap' :: (a -> m) -> QOps a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> QOps a -> m
foldMap :: (a -> m) -> QOps a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> QOps a -> m
fold :: QOps m -> m
$cfold :: forall m. Monoid m => QOps m -> m
Foldable, Functor QOps
Foldable QOps
Functor QOps
-> Foldable QOps
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> QOps a -> f (QOps b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    QOps (f a) -> f (QOps a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> QOps a -> m (QOps b))
-> (forall (m :: * -> *) a. Monad m => QOps (m a) -> m (QOps a))
-> Traversable QOps
(a -> f b) -> QOps a -> f (QOps b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => QOps (m a) -> m (QOps a)
forall (f :: * -> *) a. Applicative f => QOps (f a) -> f (QOps a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> QOps a -> m (QOps b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> QOps a -> f (QOps b)
sequence :: QOps (m a) -> m (QOps a)
$csequence :: forall (m :: * -> *) a. Monad m => QOps (m a) -> m (QOps a)
mapM :: (a -> m b) -> QOps a -> m (QOps b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> QOps a -> m (QOps b)
sequenceA :: QOps (f a) -> f (QOps a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => QOps (f a) -> f (QOps a)
traverse :: (a -> f b) -> QOps a -> f (QOps b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> QOps a -> f (QOps b)
$cp2Traversable :: Foldable QOps
$cp1Traversable :: Functor QOps
Traversable, (forall x. QOps a -> Rep (QOps a) x)
-> (forall x. Rep (QOps a) x -> QOps a) -> Generic (QOps a)
forall x. Rep (QOps a) x -> QOps a
forall x. QOps a -> Rep (QOps a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (QOps a) x -> QOps a
forall a x. QOps a -> Rep (QOps a) x
$cto :: forall a x. Rep (QOps a) x -> QOps a
$cfrom :: forall a x. QOps a -> Rep (QOps a) x
Generic)

quapplicativeStrings :: QOps String
quapplicativeStrings :: QOps CommandLineOption
quapplicativeStrings = QOps :: forall a. a -> a -> a -> a -> a -> QOps a
QOps {
    _code :: CommandLineOption
_code = CommandLineOption
"_code",
    _val :: CommandLineOption
_val  = CommandLineOption
"_val",
    makeQ :: CommandLineOption
makeQ = CommandLineOption
"makeQ",
    mkCode :: CommandLineOption
mkCode = CommandLineOption
"mkCode",
    mkVal :: CommandLineOption
mkVal = CommandLineOption
"mkVal"
  }

overloadedQuotes :: [GHC.CommandLineOption] -> TcGblEnv -> GHC.HsGroup GHC.GhcRn -> TcM (TcGblEnv, GHC.HsGroup GHC.GhcRn)
overloadedQuotes :: [CommandLineOption]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
overloadedQuotes [CommandLineOption]
_ TcGblEnv
gEnv HsGroup GhcRn
rn = do
  HscEnv
hscEnv <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
GHC.getTopEnv
  Module
parsley <- HscEnv -> CommandLineOption -> TcM Module
lookupModule HscEnv
hscEnv CommandLineOption
"Parsley.Internal.Bridge"
  QOps Name
qops <- Module
-> QOps CommandLineOption
-> IOEnv (Env TcGblEnv TcLclEnv) (QOps Name)
forall (m :: * -> *) (t :: * -> *).
(Lookup m, Traversable t) =>
Module -> t CommandLineOption -> m (t Name)
lookupNames Module
parsley QOps CommandLineOption
quapplicativeStrings
  -- This is a little inefficient, since the top-down transformation means no quotes can be
  -- found under a top-level one: we use a top-down version of everywhereBut to stop traversal
  -- of this whenever it fires
  (TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gEnv, GenericQ Bool -> GenericT -> HsGroup GhcRn -> HsGroup GhcRn
GenericQ Bool -> GenericT -> GenericT
onlyTopmost (Bool -> (Expr -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Bool
False Expr -> Bool
isQuote) ((Expr -> Expr) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (QOps Name -> Expr -> Expr
transformUTHQuote QOps Name
qops)) HsGroup GhcRn
rn)

mkApp :: GHC.SrcSpan -> Expr -> Expr -> Expr
mkApp :: SrcSpan -> Expr -> Expr -> Expr
mkApp SrcSpan
s Expr
f = SrcSpan -> HsExpr GhcRn -> Expr
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
s (HsExpr GhcRn -> Expr) -> (Expr -> HsExpr GhcRn) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XApp GhcRn -> Expr -> Expr -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
Expr.HsApp NoExtField
XApp GhcRn
noExt Expr
f (Expr -> HsExpr GhcRn) -> (Expr -> Expr) -> Expr -> HsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Expr -> Expr
mkPar SrcSpan
s

mkVar :: GHC.SrcSpan -> GHC.Name -> Expr
mkVar :: SrcSpan -> Name -> Expr
mkVar SrcSpan
s = SrcSpan -> HsExpr GhcRn -> Expr
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
s (HsExpr GhcRn -> Expr) -> (Name -> HsExpr GhcRn) -> Name -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
Expr.HsVar NoExtField
XVar GhcRn
noExt (GenLocated SrcSpan Name -> HsExpr GhcRn)
-> (Name -> GenLocated SrcSpan Name) -> Name -> HsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
s

mkPar :: GHC.SrcSpan -> Expr -> Expr
mkPar :: SrcSpan -> Expr -> Expr
mkPar SrcSpan
s = SrcSpan -> HsExpr GhcRn -> Expr
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
s (HsExpr GhcRn -> Expr) -> (Expr -> HsExpr GhcRn) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPar GhcRn -> Expr -> HsExpr GhcRn
forall p. XPar p -> LHsExpr p -> HsExpr p
Expr.HsPar NoExtField
XPar GhcRn
noExt

pattern $mLUTHQuote :: forall r l p.
GenLocated l (HsExpr p)
-> (l -> XRnBracketOut p -> XExpBr GhcRn -> Expr -> r)
-> (Void# -> r)
-> r
LUTHQuote s ex1 ex2 x <- GHC.L s (Expr.HsRnBracketOut ex1 (Expr.ExpBr ex2 x) _)
pattern $bLUTHSplice :: l
-> XSpliceE p
-> XUntypedSplice p
-> SpliceDecoration
-> IdP p
-> LHsExpr p
-> GenLocated l (HsExpr p)
$mLUTHSplice :: forall r l p.
GenLocated l (HsExpr p)
-> (l
    -> XSpliceE p
    -> XUntypedSplice p
    -> SpliceDecoration
    -> IdP p
    -> LHsExpr p
    -> r)
-> (Void# -> r)
-> r
LUTHSplice s ex1 ex2 dec name x = GHC.L s (Expr.HsSpliceE ex1 (Expr.HsUntypedSplice ex2 dec name x))

isQuote :: Expr -> Bool
isQuote :: Expr -> Bool
isQuote (LUTHQuote SrcSpan
_ XRnBracketOut GhcRn
_ XExpBr GhcRn
_ Expr
_) = Bool
True
isQuote Expr
_                   = Bool
False

-- The goal here is to find [|e|] and turn it into makeQ e [||e||]
-- The catch is that for any $qe in the quote, it must be hoisted out, let bound and then re-incorporated
-- such that `[|x .. $qe .. y|]` ~> `let qe' = qe in makeQ (x .. _val qe' .. y) [||x .. $$(_code qe') .. y||]`
-- This means that the content of the splice _cannot_ use any of the free-variables defined within
-- the original quote. Perhaps in that case we could just inline the definition into both holes...
-- As `transform` works bottom up, we can always assume nested quotes are already handled: this might
-- get tricky, however.
transformUTHQuote :: QOps GHC.Name -> Expr -> Expr
transformUTHQuote :: QOps Name -> Expr -> Expr
transformUTHQuote QOps Name
ops (LUTHQuote SrcSpan
s XRnBracketOut GhcRn
ex XExpBr GhcRn
ex' Expr
x) = --pprTouch "new quote" $
  SrcSpan -> Expr -> Expr
mkPar SrcSpan
s (Expr
makeQS Expr -> Expr -> Expr
`mkAppS` GenericT -> Expr -> Expr
GenericT -> GenericT
everywhere ((Expr -> Expr) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (Name -> (Expr -> Expr) -> Expr -> Expr
transformUTHQuoteVar (QOps Name -> Name
forall a. QOps a -> a
_val QOps Name
ops) Expr -> Expr
makeVal)) Expr
x
                  Expr -> Expr -> Expr
`mkAppS` Expr -> Expr
mkQuote (GenericT -> Expr -> Expr
GenericT -> GenericT
everywhere ((Expr -> Expr) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (Name -> (Expr -> Expr) -> Expr -> Expr
transformUTHQuoteCode (QOps Name -> Name
forall a. QOps a -> a
_code QOps Name
ops) Expr -> Expr
makeCode)) Expr
x))
  where
    mkQuote :: Expr -> Expr
mkQuote Expr
y = SrcSpan -> HsExpr GhcRn -> Expr
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
s (XBracket GhcRn -> HsBracket GhcRn -> HsExpr GhcRn
forall p. XBracket p -> HsBracket p -> HsExpr p
Expr.HsBracket XBracket GhcRn
XRnBracketOut GhcRn
ex (XTExpBr GhcRn -> Expr -> HsBracket GhcRn
forall p. XTExpBr p -> LHsExpr p -> HsBracket p
Expr.TExpBr XExpBr GhcRn
XTExpBr GhcRn
ex' Expr
y))
    mkAppS :: Expr -> Expr -> Expr
mkAppS = SrcSpan -> Expr -> Expr -> Expr
mkApp SrcSpan
s
    makeQS :: Expr
makeQS = SrcSpan -> Name -> Expr
mkVar SrcSpan
s (QOps Name -> Name
forall a. QOps a -> a
makeQ QOps Name
ops)
    mkValS :: Expr
mkValS = SrcSpan -> Name -> Expr
mkVar SrcSpan
s (QOps Name -> Name
forall a. QOps a -> a
mkVal QOps Name
ops)
    mkCodeS :: Expr
mkCodeS = SrcSpan -> Name -> Expr
mkVar SrcSpan
s (QOps Name -> Name
forall a. QOps a -> a
mkCode QOps Name
ops)
    makeVal :: Expr -> Expr
makeVal Expr
y = SrcSpan -> Expr -> Expr
mkPar SrcSpan
s (Expr
mkValS Expr -> Expr -> Expr
`mkAppS` Expr
y)
    makeCode :: Expr -> Expr
makeCode Expr
y = SrcSpan -> Expr -> Expr
mkPar SrcSpan
s (Expr
mkCodeS Expr -> Expr -> Expr
`mkAppS` Expr
y)
transformUTHQuote QOps Name
_ Expr
x = Expr
x

transformUTHQuoteVar :: GHC.Name -> (Expr -> Expr) -> Expr -> Expr
transformUTHQuoteVar :: Name -> (Expr -> Expr) -> Expr -> Expr
transformUTHQuoteVar Name
_    Expr -> Expr
makeVal (LUTHQuote SrcSpan
_ XRnBracketOut GhcRn
_ XExpBr GhcRn
_ Expr
x)      = Expr -> Expr
makeVal Expr
x
transformUTHQuoteVar Name
_val Expr -> Expr
_       (LUTHSplice SrcSpan
s XSpliceE GhcRn
_ XUntypedSplice GhcRn
_ SpliceDecoration
_ IdP GhcRn
_ Expr
x) = SrcSpan -> Expr -> Expr -> Expr
mkApp SrcSpan
s (SrcSpan -> Name -> Expr
mkVar SrcSpan
s Name
_val) Expr
x
transformUTHQuoteVar Name
_    Expr -> Expr
_       Expr
x                        = Expr
x

transformUTHQuoteCode :: GHC.Name -> (Expr -> Expr) -> Expr -> Expr
transformUTHQuoteCode :: Name -> (Expr -> Expr) -> Expr -> Expr
transformUTHQuoteCode Name
_     Expr -> Expr
makeCode (LUTHQuote SrcSpan
s XRnBracketOut GhcRn
ex XExpBr GhcRn
ex' Expr
x)         = Expr -> Expr
makeCode (SrcSpan -> HsExpr GhcRn -> Expr
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
s (XBracket GhcRn -> HsBracket GhcRn -> HsExpr GhcRn
forall p. XBracket p -> HsBracket p -> HsExpr p
Expr.HsBracket XBracket GhcRn
XRnBracketOut GhcRn
ex (XTExpBr GhcRn -> Expr -> HsBracket GhcRn
forall p. XTExpBr p -> LHsExpr p -> HsBracket p
Expr.TExpBr XExpBr GhcRn
XTExpBr GhcRn
ex' Expr
x)))
transformUTHQuoteCode Name
_code Expr -> Expr
_        (LUTHSplice SrcSpan
s XSpliceE GhcRn
ex XUntypedSplice GhcRn
ex' SpliceDecoration
d IdP GhcRn
name Expr
x) = SrcSpan -> HsExpr GhcRn -> Expr
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
s (HsExpr GhcRn -> Expr) -> (Expr -> HsExpr GhcRn) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XSpliceE GhcRn -> HsSplice GhcRn -> HsExpr GhcRn
forall p. XSpliceE p -> HsSplice p -> HsExpr p
Expr.HsSpliceE XSpliceE GhcRn
ex (HsSplice GhcRn -> HsExpr GhcRn)
-> (Expr -> HsSplice GhcRn) -> Expr -> HsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTypedSplice GhcRn
-> SpliceDecoration -> IdP GhcRn -> Expr -> HsSplice GhcRn
forall id.
XTypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
Expr.HsTypedSplice XTypedSplice GhcRn
XUntypedSplice GhcRn
ex' SpliceDecoration
d IdP GhcRn
name (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$
  SrcSpan -> Expr -> Expr -> Expr
mkApp SrcSpan
s (SrcSpan -> Name -> Expr
mkVar SrcSpan
s Name
_code) Expr
x
transformUTHQuoteCode Name
_     Expr -> Expr
_        Expr
x                              = Expr
x

onlyTopmost :: GenericQ Bool -> GenericT -> GenericT
onlyTopmost :: GenericQ Bool -> GenericT -> GenericT
onlyTopmost GenericQ Bool
q GenericT
f = a -> a
GenericT
go
  where
    go :: GenericT
    go :: a -> a
go a
x
      | a -> Bool
GenericQ Bool
q a
x = a -> a
GenericT
f a
x
      | Bool
otherwise = GenericT -> a -> a
forall a. Data a => GenericT -> a -> a
gmapT GenericT
go a
x