-- 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
  :: LibDir
  -> FixityEnv
  -> [(Quantifiers, QuerySpec, v)]
  -> IO [Query Universe v]
parseQuerySpecs :: forall v.
LibDir
-> FixityEnv
-> [(Quantifiers, QuerySpec, v)]
-> IO [Query Universe v]
parseQuerySpecs LibDir
libdir' FixityEnv
fixityEnv =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a b. (a -> b) -> a -> b
$ \(Quantifiers
qQuantifiers, QuerySpec
querySpec, v
qResult) -> do
    Annotated Universe
qPattern <- LibDir -> QuerySpec -> IO (Annotated Universe)
parse LibDir
libdir' QuerySpec
querySpec
    forall (m :: * -> *) a. Monad m => a -> m a
return Query{v
Quantifiers
Annotated Universe
qResult :: v
qPattern :: Annotated Universe
qQuantifiers :: Quantifiers
qPattern :: Annotated Universe
qResult :: v
qQuantifiers :: Quantifiers
..}
  where
    parse :: LibDir -> QuerySpec -> IO (Annotated Universe)
parse LibDir
libdir (QExpr LibDir
s) = do
      Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
e <- LibDir -> LibDir -> IO AnnotatedHsExpr
parseExpr LibDir
libdir LibDir
s
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ast. Matchable ast => ast -> Universe
inject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
e (forall ast (m :: * -> *).
(Data ast, MonadIO m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
fixityEnv)
    parse LibDir
libdir (QType LibDir
s) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ast. Matchable ast => ast -> Universe
inject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LibDir -> LibDir -> IO AnnotatedHsType
parseType LibDir
libdir LibDir
s
    parse LibDir
libdir (QStmt LibDir
s) = do
      Annotated
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
stmt <- LibDir -> LibDir -> IO AnnotatedStmt
parseStmt LibDir
libdir LibDir
s
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ast. Matchable ast => ast -> Universe
inject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
stmt (forall ast (m :: * -> *).
(Data ast, MonadIO m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
fixityEnv)

genericQ
  :: Typeable a
  => Matcher v
  -> Context
  -> a
  -> TransformT IO [(Context, Substitution, v)]
genericQ :: forall a v.
Typeable a =>
Matcher v
-> Context -> a -> TransformT IO [(Context, Substitution, v)]
genericQ Matcher v
m Context
ctxt =
  forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ (forall (m :: * -> *) a. Monad m => a -> m a
return []) (forall ast v.
Matchable ast =>
Matcher v
-> Context -> ast -> TransformT IO [(Context, Substitution, v)]
genericQImpl @(LHsExpr GhcPs) Matcher v
m Context
ctxt)
    forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (forall ast v.
Matchable ast =>
Matcher v
-> Context -> ast -> TransformT IO [(Context, Substitution, v)]
genericQImpl @(LStmt GhcPs (LHsExpr GhcPs)) Matcher v
m Context
ctxt)
    forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (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 :: forall ast v.
Matchable ast =>
Matcher v
-> Context -> ast -> TransformT IO [(Context, Substitution, v)]
genericQImpl Matcher v
m Context
ctxt ast
ast = do
  [(Substitution, v)]
pairs <- forall ast (m :: * -> *) v.
(Matchable ast, MonadIO m) =>
Context -> Matcher v -> ast -> TransformT m [(Substitution, v)]
runMatcher Context
ctxt Matcher v
m ast
ast
  forall (m :: * -> *) a. Monad m => a -> m a
return [ (Context
ctxt, Substitution
sub, v
v) | (Substitution
sub, v
v) <- [(Substitution, v)]
pairs ]