{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Retrie.Elaborate
( defaultElaborations
, elaborateRewritesInternal
) where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import "list-t" ListT
import Data.Maybe
import Retrie.Context
import Retrie.ExactPrint
import Retrie.Expr
import Retrie.Fixity
import Retrie.GHC
import Retrie.Quantifiers
import Retrie.Rewrites
import Retrie.Subst
import Retrie.Substitution
import Retrie.SYB
import Retrie.Types
import Retrie.Universe
defaultElaborations :: [RewriteSpec]
defaultElaborations :: [RewriteSpec]
defaultElaborations =
[ String -> RewriteSpec
Adhoc String
"forall f x. f $ x = f (x)"
]
elaborateRewritesInternal
:: FixityEnv
-> [Rewrite Universe]
-> [Rewrite Universe]
-> IO [Rewrite Universe]
elaborateRewritesInternal :: FixityEnv
-> [Rewrite Universe]
-> [Rewrite Universe]
-> IO [Rewrite Universe]
elaborateRewritesInternal FixityEnv
_ [] [Rewrite Universe]
rewrites = [Rewrite Universe] -> IO [Rewrite Universe]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Rewrite Universe]
rewrites
elaborateRewritesInternal FixityEnv
fixityEnv [Rewrite Universe]
elaborations [Rewrite Universe]
rewrites =
[[Rewrite Universe]] -> [Rewrite Universe]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Rewrite Universe]] -> [Rewrite Universe])
-> IO [[Rewrite Universe]] -> IO [Rewrite Universe]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rewrite Universe -> IO [Rewrite Universe])
-> [Rewrite Universe] -> IO [[Rewrite Universe]]
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 (FixityEnv -> Rewriter -> Rewrite Universe -> IO [Rewrite Universe]
elaborateOne FixityEnv
fixityEnv Rewriter
elaborator) [Rewrite Universe]
rewrites
where
elaborator :: Rewriter
elaborator = (Rewrite Universe -> Rewriter) -> [Rewrite Universe] -> Rewriter
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Rewrite Universe -> Rewriter
forall ast. Matchable ast => Rewrite ast -> Rewriter
mkRewriter [Rewrite Universe]
elaborations
elaborateOne :: FixityEnv -> Rewriter -> Rewrite Universe -> IO [Rewrite Universe]
elaborateOne :: FixityEnv -> Rewriter -> Rewrite Universe -> IO [Rewrite Universe]
elaborateOne FixityEnv
fixityEnv Rewriter
elaborator Rewrite Universe
rr = do
Annotated [Universe]
patterns <-
Annotated Universe
-> (Universe -> TransformT IO [Universe])
-> IO (Annotated [Universe])
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA (Rewrite Universe -> Annotated Universe
forall ast v. Query ast v -> Annotated ast
qPattern Rewrite Universe
rr) ((Universe -> TransformT IO [Universe])
-> IO (Annotated [Universe]))
-> (Universe -> TransformT IO [Universe])
-> IO (Annotated [Universe])
forall a b. (a -> b) -> a -> b
$ ListT (TransformT IO) Universe -> TransformT IO [Universe]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
toList (ListT (TransformT IO) Universe -> TransformT IO [Universe])
-> (Universe -> ListT (TransformT IO) Universe)
-> Universe
-> TransformT IO [Universe]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Strategy (ListT (TransformT IO))
-> GenericQ Bool
-> GenericCU (ListT (TransformT IO)) Context
-> GenericMC (ListT (TransformT IO)) Context
-> GenericMC (ListT (TransformT IO)) Context
forall (m :: * -> *) c.
Monad m =>
Strategy m
-> GenericQ Bool -> GenericCU m c -> GenericMC m c -> GenericMC m c
everywhereMWithContextBut (a -> ListT (TransformT IO) a)
-> (a -> ListT (TransformT IO) a) -> a -> ListT (TransformT IO) a
Strategy (ListT (TransformT IO))
forall (m :: * -> *) a.
Monad m =>
(a -> m a) -> (a -> m a) -> a -> m a
topDown
(Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False) (\Context
c Int
i a
x -> TransformT IO Context -> ListT (TransformT IO) Context
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TransformT IO Context -> ListT (TransformT IO) Context)
-> TransformT IO Context -> ListT (TransformT IO) Context
forall a b. (a -> b) -> a -> b
$ Context -> Int -> a -> TransformT IO Context
GenericCU (TransformT IO) Context
forall (m :: * -> *). MonadIO m => GenericCU (TransformT m) Context
updateContext Context
c Int
i a
x) Context -> a -> ListT (TransformT IO) a
GenericMC (ListT (TransformT IO)) Context
forall a (m :: * -> *).
(Data a, MonadIO m) =>
Context -> a -> ListT (TransformT m) a
elaborate Context
ctxt
[Rewrite Universe] -> IO [Rewrite Universe]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Rewrite Universe
rr { qPattern = pattern } | Annotated Universe
pattern <- Annotated [Universe] -> [Annotated Universe]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Annotated (f a) -> f (Annotated a)
sequenceA Annotated [Universe]
patterns ]
where
ctxt :: Context
ctxt = FixityEnv -> Rewriter -> Rewriter -> Context
emptyContext FixityEnv
fixityEnv Rewriter
elaborator Rewriter
forall a. Monoid a => a
mempty
elaborate
:: (Data a, MonadIO m) => Context -> a -> ListT (TransformT m) a
elaborate :: forall a (m :: * -> *).
(Data a, MonadIO m) =>
Context -> a -> ListT (TransformT m) a
elaborate Context
c =
(GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ListT (TransformT m) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> a -> ListT (TransformT m) a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (forall ast (m :: * -> *).
(Data ast, ExactPrint ast, Matchable (LocatedA ast), MonadIO m) =>
Context -> LocatedA ast -> ListT (TransformT m) (LocatedA ast)
elaborateImpl @(HsExpr GhcPs) Context
c)
(a -> ListT (TransformT m) a)
-> (LocatedA (Stmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ListT
(TransformT m)
(LocatedA (Stmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> a
-> ListT (TransformT m) a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` (forall ast (m :: * -> *).
(Data ast, ExactPrint ast, Matchable (LocatedA ast), MonadIO m) =>
Context -> LocatedA ast -> ListT (TransformT m) (LocatedA ast)
elaborateImpl @(Stmt GhcPs (LHsExpr GhcPs)) Context
c)
(a -> ListT (TransformT m) a)
-> (LocatedA (HsType GhcPs)
-> ListT (TransformT m) (LocatedA (HsType GhcPs)))
-> a
-> ListT (TransformT m) a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` (forall ast (m :: * -> *).
(Data ast, ExactPrint ast, Matchable (LocatedA ast), MonadIO m) =>
Context -> LocatedA ast -> ListT (TransformT m) (LocatedA ast)
elaborateImpl @(HsType GhcPs) Context
c)
(a -> ListT (TransformT m) a)
-> (GenLocated SrcSpanAnnA (Pat GhcPs)
-> ListT (TransformT m) (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> a
-> ListT (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 -> ListT (TransformT m) (LPat GhcPs)
forall (m :: * -> *).
MonadIO m =>
Context -> LPat GhcPs -> ListT (TransformT m) (LPat GhcPs)
elaboratePat Context
c)
elaboratePat :: MonadIO m => Context -> LPat GhcPs -> ListT (TransformT m) (LPat GhcPs)
elaboratePat :: forall (m :: * -> *).
MonadIO m =>
Context -> LPat GhcPs -> ListT (TransformT m) (LPat GhcPs)
elaboratePat Context
c LPat GhcPs
p
| Just LPat GhcPs
lp <- LPat GhcPs -> Maybe (LPat GhcPs)
forall (p :: Pass). LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat LPat GhcPs
p = LPat GhcPs -> LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs))
-> ListT (TransformT m) (GenLocated SrcSpanAnnA (Pat GhcPs))
-> ListT (TransformT m) (GenLocated SrcSpanAnnA (Pat GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> ListT (TransformT m) (GenLocated SrcSpanAnnA (Pat GhcPs))
forall ast (m :: * -> *).
(Data ast, ExactPrint ast, Matchable (LocatedA ast), MonadIO m) =>
Context -> LocatedA ast -> ListT (TransformT m) (LocatedA ast)
elaborateImpl Context
c LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
lp
| Bool
otherwise = GenLocated SrcSpanAnnA (Pat GhcPs)
-> ListT (TransformT m) (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> ListT (TransformT m) a
forall (m :: * -> *) a. Monad m => a -> m a
return LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p
elaborateImpl
:: forall ast m. (Data ast, ExactPrint ast, Matchable (LocatedA ast), MonadIO m)
=> Context -> LocatedA ast -> ListT (TransformT m) (LocatedA ast)
elaborateImpl :: forall ast (m :: * -> *).
(Data ast, ExactPrint ast, Matchable (LocatedA ast), MonadIO m) =>
Context -> LocatedA ast -> ListT (TransformT m) (LocatedA ast)
elaborateImpl Context
ctxt LocatedA ast
e = do
[LocatedA ast]
elaborations <- TransformT m [LocatedA ast] -> ListT (TransformT m) [LocatedA ast]
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TransformT m [LocatedA ast]
-> ListT (TransformT m) [LocatedA ast])
-> TransformT m [LocatedA ast]
-> ListT (TransformT m) [LocatedA ast]
forall a b. (a -> b) -> a -> b
$ do
[(Substitution, RewriterResult Universe)]
matches <- Context
-> Rewriter
-> LocatedA ast
-> TransformT m [(Substitution, RewriterResult Universe)]
forall ast (m :: * -> *) v.
(Matchable ast, MonadIO m) =>
Context -> Matcher v -> ast -> TransformT m [(Substitution, v)]
runMatcher Context
ctxt (Context -> Rewriter
ctxtRewriter Context
ctxt) (LocatedA ast -> LocatedA ast
forall k. Data k => k -> k
getUnparened LocatedA ast
e)
[MatchResult (LocatedA ast)]
validMatches <- Context
-> [(Substitution, RewriterResult Universe)]
-> TransformT m [MatchResult (LocatedA ast)]
forall ast (m :: * -> *).
(Matchable ast, MonadIO m) =>
Context
-> [(Substitution, RewriterResult Universe)]
-> TransformT m [MatchResult ast]
allMatches Context
ctxt [(Substitution, RewriterResult Universe)]
matches
[(Substitution, Template (LocatedA ast))]
-> ((Substitution, Template (LocatedA ast))
-> TransformT m (LocatedA ast))
-> TransformT m [LocatedA ast]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ (Substitution
sub, Template (LocatedA ast)
tmpl) | MatchResult Substitution
sub Template (LocatedA ast)
tmpl <- [MatchResult (LocatedA ast)]
validMatches ] (((Substitution, Template (LocatedA ast))
-> TransformT m (LocatedA ast))
-> TransformT m [LocatedA ast])
-> ((Substitution, Template (LocatedA ast))
-> TransformT m (LocatedA ast))
-> TransformT m [LocatedA ast]
forall a b. (a -> b) -> a -> b
$ \(Substitution
sub, Template{Maybe [Rewrite Universe]
AnnotatedImports
Annotated (LocatedA ast)
tTemplate :: Annotated (LocatedA ast)
tImports :: AnnotatedImports
tDependents :: Maybe [Rewrite Universe]
tTemplate :: forall ast. Template ast -> Annotated ast
tImports :: forall ast. Template ast -> AnnotatedImports
tDependents :: forall ast. Template ast -> Maybe [Rewrite Universe]
..}) -> do
LocatedA ast
t' <- Annotated (LocatedA ast) -> TransformT m (LocatedA ast)
forall ast (m :: * -> *).
(Data ast, Monad m) =>
Annotated ast -> TransformT m ast
graftA Annotated (LocatedA ast)
tTemplate
LocatedA ast
r <- Substitution
-> Context -> LocatedA ast -> TransformT m (LocatedA ast)
forall (m :: * -> *) ast.
(MonadIO m, Data ast) =>
Substitution -> Context -> ast -> TransformT m ast
subst Substitution
sub Context
ctxt LocatedA ast
t'
LocatedA ast
r0 <- LocatedA ast -> LocatedA ast -> TransformT m (LocatedA ast)
forall an a b (m :: * -> *).
(HasCallStack, Monoid an, Data a, Data b, MonadIO m,
Typeable an) =>
LocatedAn an a -> LocatedAn an b -> TransformT m (LocatedAn an b)
addAllAnnsT LocatedA ast
e LocatedA ast
r
((GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> LocatedA ast -> TransformT m (LocatedA ast)
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 :: * -> *).
Monad m =>
Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
parenify Context
ctxt) (LocatedA ast -> TransformT m (LocatedA ast))
-> (LocatedA (HsType GhcPs)
-> TransformT m (LocatedA (HsType GhcPs)))
-> LocatedA ast
-> TransformT m (LocatedA ast)
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 :: * -> *).
Monad m =>
Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)
parenifyT Context
ctxt (LocatedA ast -> TransformT m (LocatedA ast))
-> (GenLocated SrcSpanAnnA (Pat GhcPs)
-> TransformT m (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> LocatedA ast
-> TransformT m (LocatedA ast)
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 :: * -> *).
Monad m =>
Context -> LPat GhcPs -> TransformT m (LPat GhcPs)
parenifyP Context
ctxt) LocatedA ast
r0
[LocatedA ast] -> ListT (TransformT m) (LocatedA ast)
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f a -> ListT m a
fromFoldable (LocatedA ast
e LocatedA ast -> [LocatedA ast] -> [LocatedA ast]
forall a. a -> [a] -> [a]
: [LocatedA ast]
elaborations)
allMatches
:: (Matchable ast, MonadIO m)
=> Context
-> [(Substitution, RewriterResult Universe)]
-> TransformT m [MatchResult ast]
allMatches :: forall ast (m :: * -> *).
(Matchable ast, MonadIO m) =>
Context
-> [(Substitution, RewriterResult Universe)]
-> TransformT m [MatchResult ast]
allMatches Context
_ [] = [MatchResult ast] -> TransformT m [MatchResult ast]
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
allMatches Context
ctxt [(Substitution, RewriterResult Universe)]
matchResults = do
[(Quantifiers, MatchResult Universe)]
results <-
[(Substitution, RewriterResult Universe)]
-> ((Substitution, RewriterResult Universe)
-> TransformT m (Quantifiers, MatchResult Universe))
-> TransformT m [(Quantifiers, MatchResult Universe)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Substitution, RewriterResult Universe)]
matchResults (((Substitution, RewriterResult Universe)
-> TransformT m (Quantifiers, MatchResult Universe))
-> TransformT m [(Quantifiers, MatchResult Universe)])
-> ((Substitution, RewriterResult Universe)
-> TransformT m (Quantifiers, MatchResult Universe))
-> TransformT m [(Quantifiers, MatchResult Universe)]
forall a b. (a -> b) -> a -> b
$ \(Substitution
sub, RewriterResult{SrcSpan
Quantifiers
Template Universe
MatchResultTransformer
rrOrigin :: SrcSpan
rrQuantifiers :: Quantifiers
rrTransformer :: MatchResultTransformer
rrTemplate :: Template Universe
rrOrigin :: forall ast. RewriterResult ast -> SrcSpan
rrQuantifiers :: forall ast. RewriterResult ast -> Quantifiers
rrTransformer :: forall ast. RewriterResult ast -> MatchResultTransformer
rrTemplate :: forall ast. RewriterResult ast -> Template ast
..}) -> do
MatchResult Universe
result <- RWST () [String] Int m (MatchResult Universe)
-> TransformT m (MatchResult Universe)
forall (m :: * -> *) a. RWST () [String] Int m a -> TransformT m a
TransformT (RWST () [String] Int m (MatchResult Universe)
-> TransformT m (MatchResult Universe))
-> RWST () [String] Int m (MatchResult Universe)
-> TransformT m (MatchResult Universe)
forall a b. (a -> b) -> a -> b
$ m (MatchResult Universe)
-> RWST () [String] Int m (MatchResult Universe)
forall (m :: * -> *) a. Monad m => m a -> RWST () [String] Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (MatchResult Universe)
-> RWST () [String] Int m (MatchResult Universe))
-> m (MatchResult Universe)
-> RWST () [String] Int m (MatchResult Universe)
forall a b. (a -> b) -> a -> b
$ IO (MatchResult Universe) -> m (MatchResult Universe)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MatchResult Universe) -> m (MatchResult Universe))
-> IO (MatchResult Universe) -> m (MatchResult Universe)
forall a b. (a -> b) -> a -> b
$ MatchResultTransformer
rrTransformer Context
ctxt (MatchResult Universe -> IO (MatchResult Universe))
-> MatchResult Universe -> IO (MatchResult Universe)
forall a b. (a -> b) -> a -> b
$ Substitution -> Template Universe -> MatchResult Universe
forall ast. Substitution -> Template ast -> MatchResult ast
MatchResult Substitution
sub Template Universe
rrTemplate
(Quantifiers, MatchResult Universe)
-> TransformT m (Quantifiers, MatchResult Universe)
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Quantifiers
rrQuantifiers, MatchResult Universe
result)
[MatchResult ast] -> TransformT m [MatchResult ast]
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Universe -> ast
forall ast. Matchable ast => Universe -> ast
project (Universe -> ast) -> MatchResult Universe -> MatchResult ast
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MatchResult Universe
result
| (Quantifiers
quantifiers, result :: MatchResult Universe
result@(MatchResult Substitution
sub' Template Universe
_)) <- [(Quantifiers, MatchResult Universe)]
results
, Maybe [HoleVal] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [HoleVal] -> Bool) -> Maybe [HoleVal] -> Bool
forall a b. (a -> b) -> a -> b
$ [Maybe HoleVal] -> Maybe [HoleVal]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ FastString -> Substitution -> Maybe HoleVal
lookupSubst FastString
q Substitution
sub' | FastString
q <- Quantifiers -> [FastString]
qList Quantifiers
quantifiers ]
]