-- 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 =
  ((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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 <- LibDir -> QuerySpec -> IO (Annotated Universe)
parse LibDir
libdir' QuerySpec
querySpec
    Query Universe v -> IO (Query Universe v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Query{v
Quantifiers
Annotated Universe
qQuantifiers :: Quantifiers
qResult :: v
qPattern :: Annotated Universe
qQuantifiers :: Quantifiers
qPattern :: Annotated Universe
qResult :: v
..}
  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
      (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Universe)
-> Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Annotated Universe
forall a b. (a -> b) -> Annotated a -> Annotated b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Universe
forall ast. Matchable ast => ast -> Universe
inject (Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Annotated Universe)
-> IO (Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> IO (Annotated Universe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> IO (Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
e (FixityEnv
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall ast (m :: * -> *).
(Data ast, MonadIO m) =>
FixityEnv -> ast -> TransformT m ast
fix FixityEnv
fixityEnv)
    parse LibDir
libdir (QType LibDir
s) = (GenLocated SrcSpanAnnA (HsType GhcPs) -> Universe)
-> Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
-> Annotated Universe
forall a b. (a -> b) -> Annotated a -> Annotated b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA (HsType GhcPs) -> Universe
forall ast. Matchable ast => ast -> Universe
inject (Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
 -> Annotated Universe)
-> IO (Annotated (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> IO (Annotated Universe)
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
      (GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Universe)
-> Annotated
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Annotated Universe
forall a b. (a -> b) -> Annotated a -> Annotated b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Universe
forall ast. Matchable ast => ast -> Universe
inject (Annotated
   (GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
 -> Annotated Universe)
-> IO
     (Annotated
        (GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> IO (Annotated Universe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotated
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> (GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> TransformT
         IO
         (GenLocated
            SrcSpanAnnA
            (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> IO
     (Annotated
        (GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
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 (FixityEnv
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> TransformT
     IO
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
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 =
  TransformT IO [(Context, Substitution, v)]
-> (GenLocated SrcSpanAnnA (HsExpr 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 a. a -> TransformT IO a
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)
    (a -> TransformT IO [(Context, Substitution, v)])
-> (GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> TransformT IO [(Context, Substitution, v)])
-> a
-> TransformT IO [(Context, Substitution, v)]
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`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)
    (a -> TransformT IO [(Context, Substitution, v)])
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
    -> TransformT IO [(Context, Substitution, v)])
-> a
-> TransformT IO [(Context, Substitution, v)]
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`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 <- 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 a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Context
ctxt, Substitution
sub, v
v) | (Substitution
sub, v
v) <- [(Substitution, v)]
pairs ]