{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Retrie.Query
( QuerySpec(..)
, parseQuerySpecs
, genericQ
) where
import Retrie.ExactPrint
import Retrie.Fixity
import Retrie.GHC
import Retrie.Quantifiers
import Retrie.Substitution
import Retrie.SYB
import Retrie.Types
import Retrie.Universe
data QuerySpec
= QExpr String
| QType String
| QStmt String
parseQuerySpecs
:: FixityEnv
-> [(Quantifiers, QuerySpec, v)]
-> IO [Query Universe v]
parseQuerySpecs :: FixityEnv -> [(Quantifiers, QuerySpec, v)] -> IO [Query Universe v]
parseQuerySpecs FixityEnv
fixityEnv =
((Quantifiers, QuerySpec, v) -> IO (Query Universe v))
-> [(Quantifiers, QuerySpec, v)] -> IO [Query Universe v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Quantifiers, QuerySpec, v) -> IO (Query Universe v))
-> [(Quantifiers, QuerySpec, v)] -> IO [Query Universe v])
-> ((Quantifiers, QuerySpec, v) -> IO (Query Universe v))
-> [(Quantifiers, QuerySpec, v)]
-> IO [Query Universe v]
forall a b. (a -> b) -> a -> b
$ \(Quantifiers
qQuantifiers, QuerySpec
querySpec, v
qResult) -> do
Annotated Universe
qPattern <- QuerySpec -> IO (Annotated Universe)
parse QuerySpec
querySpec
Query Universe v -> IO (Query Universe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Query :: forall ast v. Quantifiers -> Annotated ast -> v -> Query ast v
Query{v
Quantifiers
Annotated Universe
qResult :: v
qPattern :: Annotated Universe
qQuantifiers :: Quantifiers
qPattern :: Annotated Universe
qResult :: v
qQuantifiers :: Quantifiers
..}
where
parse :: QuerySpec -> IO (Annotated Universe)
parse (QExpr String
s) = do
AnnotatedHsExpr
e <- String -> IO AnnotatedHsExpr
parseExpr String
s
(LHsExpr GhcPs -> Universe)
-> AnnotatedHsExpr -> Annotated Universe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcPs -> Universe
forall ast. Matchable ast => ast -> Universe
inject (AnnotatedHsExpr -> Annotated Universe)
-> IO AnnotatedHsExpr -> IO (Annotated Universe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotatedHsExpr
-> (LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs))
-> IO AnnotatedHsExpr
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedHsExpr
e (FixityEnv -> LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall ast (m :: * -> *).
(Data ast, Monad m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
fixityEnv)
parse (QType String
s) = (LHsType GhcPs -> Universe)
-> Annotated (LHsType GhcPs) -> Annotated Universe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> Universe
forall ast. Matchable ast => ast -> Universe
inject (Annotated (LHsType GhcPs) -> Annotated Universe)
-> IO (Annotated (LHsType GhcPs)) -> IO (Annotated Universe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Annotated (LHsType GhcPs))
parseType String
s
parse (QStmt String
s) = do
AnnotatedStmt
stmt <- String -> IO AnnotatedStmt
parseStmt String
s
(LStmt GhcPs (LHsExpr GhcPs) -> Universe)
-> AnnotatedStmt -> Annotated Universe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LStmt GhcPs (LHsExpr GhcPs) -> Universe
forall ast. Matchable ast => ast -> Universe
inject (AnnotatedStmt -> Annotated Universe)
-> IO AnnotatedStmt -> IO (Annotated Universe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotatedStmt
-> (LStmt GhcPs (LHsExpr GhcPs)
-> TransformT IO (LStmt GhcPs (LHsExpr GhcPs)))
-> IO AnnotatedStmt
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedStmt
stmt (FixityEnv
-> LStmt GhcPs (LHsExpr GhcPs)
-> TransformT IO (LStmt GhcPs (LHsExpr GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
fixityEnv)
genericQ
:: Typeable a
=> Matcher v
-> Context
-> a
-> TransformT IO [(Context, Substitution, v)]
genericQ :: Matcher v
-> Context -> a -> TransformT IO [(Context, Substitution, v)]
genericQ Matcher v
m Context
ctxt =
TransformT IO [(Context, Substitution, v)]
-> (LHsExpr GhcPs -> TransformT IO [(Context, Substitution, v)])
-> a
-> TransformT IO [(Context, Substitution, v)]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ ([(Context, Substitution, v)]
-> TransformT IO [(Context, Substitution, v)]
forall (m :: * -> *) a. Monad m => a -> m a
return []) (Matcher v
-> Context
-> LHsExpr GhcPs
-> TransformT IO [(Context, Substitution, v)]
forall ast v.
Matchable ast =>
Matcher v
-> Context -> ast -> TransformT IO [(Context, Substitution, v)]
genericQImpl @(LHsExpr GhcPs) Matcher v
m Context
ctxt)
(a -> TransformT IO [(Context, Substitution, v)])
-> (LStmt GhcPs (LHsExpr GhcPs)
-> TransformT IO [(Context, Substitution, v)])
-> a
-> TransformT IO [(Context, Substitution, v)]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Matcher v
-> Context
-> LStmt GhcPs (LHsExpr GhcPs)
-> TransformT IO [(Context, Substitution, v)]
forall ast v.
Matchable ast =>
Matcher v
-> Context -> ast -> TransformT IO [(Context, Substitution, v)]
genericQImpl @(LStmt GhcPs (LHsExpr GhcPs)) Matcher v
m Context
ctxt)
(a -> TransformT IO [(Context, Substitution, v)])
-> (LHsType GhcPs -> TransformT IO [(Context, Substitution, v)])
-> a
-> TransformT IO [(Context, Substitution, v)]
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Matcher v
-> Context
-> LHsType GhcPs
-> TransformT IO [(Context, Substitution, v)]
forall ast v.
Matchable ast =>
Matcher v
-> Context -> ast -> TransformT IO [(Context, Substitution, v)]
genericQImpl @(LHsType GhcPs) Matcher v
m Context
ctxt)
genericQImpl
:: forall ast v. Matchable ast
=> Matcher v
-> Context
-> ast
-> TransformT IO [(Context, Substitution, v)]
genericQImpl :: Matcher v
-> Context -> ast -> TransformT IO [(Context, Substitution, v)]
genericQImpl Matcher v
m Context
ctxt ast
ast = do
[(Substitution, v)]
pairs <- Context -> Matcher v -> ast -> TransformT IO [(Substitution, v)]
forall ast (m :: * -> *) v.
(Matchable ast, MonadIO m) =>
Context -> Matcher v -> ast -> TransformT m [(Substitution, v)]
runMatcher Context
ctxt Matcher v
m ast
ast
[(Context, Substitution, v)]
-> TransformT IO [(Context, Substitution, v)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Context
ctxt, Substitution
sub, v
v) | (Substitution
sub, v
v) <- [(Substitution, v)]
pairs ]