{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
module Retrie.Subst (subst) where
import Control.Monad.Writer.Strict
import Data.Generics
import Retrie.Context
import Retrie.ExactPrint
import Retrie.Expr
import Retrie.GHC
import Retrie.Substitution
import Retrie.SYB
import Retrie.Types
import Retrie.Util
subst
:: (MonadIO m, Data ast)
=> Substitution
-> Context
-> ast
-> TransformT m ast
subst :: forall (m :: * -> *) ast.
(MonadIO m, Data ast) =>
Substitution -> Context -> ast -> TransformT m ast
subst Substitution
sub Context
ctxt =
Strategy (TransformT m)
-> GenericQ Bool
-> GenericCU (TransformT m) Context
-> GenericMC (TransformT m) Context
-> GenericMC (TransformT m) Context
forall (m :: * -> *) c.
Monad m =>
Strategy m
-> GenericQ Bool -> GenericCU m c -> GenericMC m c -> GenericMC m c
everywhereMWithContextBut (a -> TransformT m a)
-> (a -> TransformT m a) -> a -> TransformT m a
Strategy (TransformT m)
forall (m :: * -> *) a.
Monad m =>
(a -> m a) -> (a -> m a) -> a -> m a
bottomUp (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False) Context -> Int -> a -> TransformT m Context
GenericCU (TransformT m) Context
forall (m :: * -> *). MonadIO m => GenericCU (TransformT m) Context
updateContext Context -> a -> TransformT m a
GenericMC (TransformT m) Context
forall {a} {m :: * -> *}.
(Typeable a, MonadIO m) =>
Context -> a -> TransformT m a
f Context
ctxt'
where
ctxt' :: Context
ctxt' = Context
ctxt { ctxtSubst = Just sub }
f :: Context -> a -> TransformT m a
f Context
c =
(GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> a -> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *).
MonadIO m =>
Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
substExpr Context
c)
(a -> TransformT m a)
-> (GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> a
-> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Context -> LPat GhcPs -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
MonadIO m =>
Context -> LPat GhcPs -> TransformT m (LPat GhcPs)
substPat Context
c
(a -> TransformT m a)
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> a
-> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)
forall (m :: * -> *).
MonadIO m =>
Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)
substType Context
c
(a -> TransformT m a)
-> (HsMatchContext GhcPs -> TransformT m (HsMatchContext GhcPs))
-> a
-> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Context
-> HsMatchContext GhcPs -> TransformT m (HsMatchContext GhcPs)
forall (m :: * -> *).
Monad m =>
Context
-> HsMatchContext GhcPs -> TransformT m (HsMatchContext GhcPs)
substHsMatchContext Context
c
(a -> TransformT m a)
-> (HsBind GhcPs -> TransformT m (HsBind GhcPs))
-> a
-> TransformT m a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Context -> HsBind GhcPs -> TransformT m (HsBind GhcPs)
forall (m :: * -> *).
Monad m =>
Context -> HsBind GhcPs -> TransformT m (HsBind GhcPs)
substBind Context
c
lookupHoleVar :: RdrName -> Context -> Maybe HoleVal
lookupHoleVar :: RdrName -> Context -> Maybe HoleVal
lookupHoleVar RdrName
rdr Context
ctxt = do
Substitution
sub <- Context -> Maybe Substitution
ctxtSubst Context
ctxt
FastString -> Substitution -> Maybe HoleVal
lookupSubst (RdrName -> FastString
rdrFS RdrName
rdr) Substitution
sub
substExpr
:: MonadIO m
=> Context
-> LHsExpr GhcPs
-> TransformT m (LHsExpr GhcPs)
substExpr :: forall (m :: * -> *).
MonadIO m =>
Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
substExpr Context
ctxt e :: LHsExpr GhcPs
e@(L SrcSpanAnnA
l1 (HsVar XVar GhcPs
x (L SrcSpanAnnN
l2 RdrName
v))) =
case RdrName -> Context -> Maybe HoleVal
lookupHoleVar RdrName
v Context
ctxt of
Just (HoleExpr AnnotatedHsExpr
eA) -> do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e0 <- Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
Annotated ast -> TransformT m ast
graftA (LHsExpr GhcPs -> LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
unparen (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotatedHsExpr
Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
eA)
let comments :: Bool
comments = GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
forall an a. LocatedAn an a -> Bool
hasComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
e0
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e1 <- if Bool
comments
then GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcPs)
e0
else GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: * -> *) t2 t1 a b.
(Monad m, Monoid t2, Typeable t1, Typeable t2) =>
LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e GenLocated SrcSpanAnnA (HsExpr GhcPs)
e0
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2 <- (TrailingAnn -> Bool)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
transferAnnsT TrailingAnn -> Bool
isComma LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e GenLocated SrcSpanAnnA (HsExpr GhcPs)
e1
Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
parenify Context
ctxt LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2
Just (HoleRdr RdrName
rdr) ->
LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l1 (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcPs
x (LIdP GhcPs -> HsExpr GhcPs) -> LIdP GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l2 RdrName
rdr
Maybe HoleVal
_ -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
substExpr Context
_ LHsExpr GhcPs
e = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
substPat
:: MonadIO m
=> Context
-> LPat GhcPs
-> TransformT m (LPat GhcPs)
substPat :: forall (m :: * -> *).
MonadIO m =>
Context -> LPat GhcPs -> TransformT m (LPat GhcPs)
substPat Context
ctxt (LPat GhcPs -> Maybe (LPat GhcPs)
forall (p :: Pass). LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat -> Just p :: LPat GhcPs
p@(L SrcSpanAnnA
l1 (VarPat XVarPat GhcPs
x _vl :: LIdP GhcPs
_vl@(L SrcSpanAnnN
l2 RdrName
v)))) = (GenLocated SrcSpanAnnA (Pat GhcPs) -> LPat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
-> TransformT m (LPat GhcPs)
forall a b. (a -> b) -> TransformT m a -> TransformT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LPat GhcPs -> LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs) -> LPat GhcPs
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat (TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
-> TransformT m (LPat GhcPs))
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
-> TransformT m (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$
case RdrName -> Context -> Maybe HoleVal
lookupHoleVar RdrName
v Context
ctxt of
Just (HolePat AnnotatedPat
pA) -> do
GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Annotated (GenLocated SrcSpanAnnA (Pat GhcPs))
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
Annotated ast -> TransformT m ast
graftA (LPat GhcPs -> LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
unparenP (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Annotated (GenLocated SrcSpanAnnA (Pat GhcPs))
-> Annotated (GenLocated SrcSpanAnnA (Pat GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotatedPat
Annotated (GenLocated SrcSpanAnnA (Pat GhcPs))
pA)
GenLocated SrcSpanAnnA (Pat GhcPs)
p0 <- (TrailingAnn -> Bool)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b (m :: * -> *).
(HasCallStack, Data a, Data b, Monad m) =>
(TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
transferEntryAnnsT TrailingAnn -> Bool
isComma LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p GenLocated SrcSpanAnnA (Pat GhcPs)
p'
Context -> LPat GhcPs -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
Context -> LPat GhcPs -> TransformT m (LPat GhcPs)
parenifyP Context
ctxt LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p0
Just (HoleRdr RdrName
rdr) ->
GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l1 (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
x (LIdP GhcPs -> Pat GhcPs) -> LIdP GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l2 RdrName
rdr
Maybe HoleVal
_ -> GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p
substPat Context
_ LPat GhcPs
p = GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p
substType
:: MonadIO m
=> Context
-> LHsType GhcPs
-> TransformT m (LHsType GhcPs)
substType :: forall (m :: * -> *).
MonadIO m =>
Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)
substType Context
ctxt LHsType GhcPs
ty
| Just (L SrcSpanAnnN
_ RdrName
v) <- HsType GhcPs -> Maybe (LIdP GhcPs)
forall p. HsType p -> Maybe (LIdP p)
tyvarRdrName (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty)
, Just (HoleType AnnotatedHsType
tyA) <- RdrName -> Context -> Maybe HoleVal
lookupHoleVar RdrName
v Context
ctxt = do
GenLocated SrcSpanAnnA (HsType GhcPs)
ty' <- Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
-> TransformT m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
Annotated ast -> TransformT m ast
graftA (LHsType GhcPs -> LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
unparenT (GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs))
-> Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
-> Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotatedHsType
Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
tyA)
GenLocated SrcSpanAnnA (HsType GhcPs)
ty0 <- (TrailingAnn -> Bool)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b (m :: * -> *).
(HasCallStack, Data a, Data b, Monad m) =>
(TrailingAnn -> Bool)
-> LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
transferEntryAnnsT TrailingAnn -> Bool
isComma LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty GenLocated SrcSpanAnnA (HsType GhcPs)
ty'
Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)
forall (m :: * -> *).
Monad m =>
Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)
parenifyT Context
ctxt LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty0
substType Context
_ LHsType GhcPs
ty = GenLocated SrcSpanAnnA (HsType GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
substHsMatchContext
:: Monad m
=> Context
#if __GLASGOW_HASKELL__ < 900
-> HsMatchContext RdrName
-> TransformT m (HsMatchContext RdrName)
#else
-> HsMatchContext GhcPs
-> TransformT m (HsMatchContext GhcPs)
#endif
substHsMatchContext :: forall (m :: * -> *).
Monad m =>
Context
-> HsMatchContext GhcPs -> TransformT m (HsMatchContext GhcPs)
substHsMatchContext Context
ctxt (FunRhs (L SrcSpanAnnN
l RdrName
v) LexicalFixity
f SrcStrictness
s)
| Just (HoleRdr RdrName
rdr) <- RdrName -> Context -> Maybe HoleVal
lookupHoleVar RdrName
v Context
ctxt =
HsMatchContext GhcPs -> TransformT m (HsMatchContext GhcPs)
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsMatchContext GhcPs -> TransformT m (HsMatchContext GhcPs))
-> HsMatchContext GhcPs -> TransformT m (HsMatchContext GhcPs)
forall a b. (a -> b) -> a -> b
$ LIdP (NoGhcTc GhcPs)
-> LexicalFixity -> SrcStrictness -> HsMatchContext GhcPs
forall p.
LIdP (NoGhcTc p)
-> LexicalFixity -> SrcStrictness -> HsMatchContext p
FunRhs (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
rdr) LexicalFixity
f SrcStrictness
s
substHsMatchContext Context
_ HsMatchContext GhcPs
other = HsMatchContext GhcPs -> TransformT m (HsMatchContext GhcPs)
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return HsMatchContext GhcPs
other
substBind
:: Monad m
=> Context
-> HsBind GhcPs
-> TransformT m (HsBind GhcPs)
substBind :: forall (m :: * -> *).
Monad m =>
Context -> HsBind GhcPs -> TransformT m (HsBind GhcPs)
substBind Context
ctxt fb :: HsBind GhcPs
fb@FunBind{}
| L SrcSpanAnnN
l RdrName
v <- HsBind GhcPs -> LIdP GhcPs
forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id HsBind GhcPs
fb
, Just (HoleRdr RdrName
rdr) <- RdrName -> Context -> Maybe HoleVal
lookupHoleVar RdrName
v Context
ctxt =
HsBind GhcPs -> TransformT m (HsBind GhcPs)
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return HsBind GhcPs
fb { fun_id = L l rdr }
substBind Context
_ HsBind GhcPs
other = HsBind GhcPs -> TransformT m (HsBind GhcPs)
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return HsBind GhcPs
other