-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# 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

-- | Specifies which parser to use in 'Retrie.parseQueries'.
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 ]