-- 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 DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Retrie.Types
  ( Direction(..)
    -- * Queries and Matchers
  , Query(..)
  , Matcher(..)
  , mkMatcher
  , mkLocalMatcher
  , runMatcher
    -- * Rewrites and Rewriters
  , Rewrite
  , mkRewrite
  , Rewriter
  , mkRewriter
  , mkLocalRewriter
  , runRewriter
  , MatchResult(..)
  , Template(..)
  , MatchResultTransformer
  , defaultTransformer
    -- ** Functions on Rewrites
  , addRewriteImports
  , setRewriteTransformer
  , toURewrite
  , fromURewrite
  , ppRewrite
  , rewritesWithDependents
    -- * Internal
  , RewriterResult(..)
  , ParentPrec(..)
  , Context(..)
  ) where

import Control.Monad.IO.Class
import Control.Monad.State
import Data.Bifunctor
import qualified Data.IntMap.Strict as I
import Data.Data hiding (Fixity)
import Data.Maybe

import Retrie.AlphaEnv
import Retrie.ExactPrint
import Retrie.Fixity
import Retrie.GHC
import Retrie.PatternMap.Class
import Retrie.Quantifiers
import Retrie.Substitution
import Retrie.Universe

-- | 'Context' maintained by AST traversals.
data Context = Context
  { Context -> [RdrName]
ctxtBinders :: [RdrName]
    -- ^ Stack of bindings of which we are currently in the right-hand side.
    -- Used to avoid introducing self-recursion.
  , Context -> Rewriter
ctxtDependents :: Rewriter
    -- ^ The rewriter we apply to determine whether to add context-dependent
    -- rewrites to 'ctxtRewriter'. We keep this separate because most of the time
    -- it is empty, and we don't want to match every rewrite twice.
  , Context -> FixityEnv
ctxtFixityEnv :: FixityEnv
    -- ^ Current FixityEnv.
  , Context -> AlphaEnv
ctxtInScope :: AlphaEnv
    -- ^ In-scope local bindings. Used to detect shadowing.
  , Context -> ParentPrec
ctxtParentPrec :: ParentPrec
    -- ^ Precedence of parent
    -- (app = HasPrec 10, infix op = HasPrec $ op precedence)
  , Context -> Rewriter
ctxtRewriter :: Rewriter
    -- ^ The rewriter we should use to mutate the code.
  , Context -> Maybe Substitution
ctxtSubst :: Maybe Substitution
    -- ^ If present, update substitution with binder renamings.
    -- Used to implement capture-avoiding substitution.
  }

-- | Precedence of parent node in the AST.
data ParentPrec
  = HasPrec Fixity -- ^ Parent has precedence info.
  | IsLhs      -- ^ We are a pattern in a left-hand-side
  | IsHsAppsTy -- ^ Parent is HsAppsTy
  | NeverParen -- ^ Based on parent, we should never add parentheses.

------------------------------------------------------------------------

data Direction = LeftToRight | RightToLeft
  deriving (Direction -> Direction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq)

------------------------------------------------------------------------

-- | 'Query' is the primitive way to specify a matchable pattern (quantifiers
-- and expression). Whenever the pattern is matched, the associated result
-- will be returned.
data Query ast v = Query
  { forall ast v. Query ast v -> Quantifiers
qQuantifiers  :: Quantifiers
  , forall ast v. Query ast v -> Annotated ast
qPattern      :: Annotated ast
  , forall ast v. Query ast v -> v
qResult       :: v
  }

instance Functor (Query ast) where
  fmap :: forall a b. (a -> b) -> Query ast a -> Query ast b
fmap a -> b
f (Query Quantifiers
qs Annotated ast
ast a
v) = forall ast v. Quantifiers -> Annotated ast -> v -> Query ast v
Query Quantifiers
qs Annotated ast
ast (a -> b
f a
v)

instance Bifunctor Query where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Query a c -> Query b d
bimap a -> b
f c -> d
g (Query Quantifiers
qs Annotated a
ast c
v) = forall ast v. Quantifiers -> Annotated ast -> v -> Query ast v
Query Quantifiers
qs (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Annotated a
ast) (c -> d
g c
v)

instance (Data (Annotated ast), Show ast, Show v) => Show (Query ast v) where
  show :: Query ast v -> String
show (Query Quantifiers
q Annotated ast
p v
r) = String
"Query " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Quantifiers
q forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Data a => a -> String
showAst Annotated ast
p forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show v
r


------------------------------------------------------------------------

-- | 'Matcher' is a compiled 'Query'. Several queries can be compiled and then
-- merged into a single compiled 'Matcher' via 'Semigroup'/'Monoid'.
newtype Matcher a = Matcher (I.IntMap (UMap a))
  deriving (forall a b. a -> Matcher b -> Matcher a
forall a b. (a -> b) -> Matcher a -> Matcher b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Matcher b -> Matcher a
$c<$ :: forall a b. a -> Matcher b -> Matcher a
fmap :: forall a b. (a -> b) -> Matcher a -> Matcher b
$cfmap :: forall a b. (a -> b) -> Matcher a -> Matcher b
Functor)
-- The 'IntMap' tracks the binding level at which the 'Matcher' was built.
-- See Note [AlphaEnv Offset] for details.

instance Semigroup (Matcher a) where
  <> :: Matcher a -> Matcher a -> Matcher a
(<>) = forall a. Monoid a => a -> a -> a
mappend

instance Monoid (Matcher a) where
  mempty :: Matcher a
mempty = forall a. IntMap (UMap a) -> Matcher a
Matcher forall a. IntMap a
I.empty
  mappend :: Matcher a -> Matcher a -> Matcher a
mappend (Matcher IntMap (UMap a)
m1) (Matcher IntMap (UMap a)
m2) = forall a. IntMap (UMap a) -> Matcher a
Matcher (forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
I.unionWith forall (m :: * -> *) a. PatternMap m => m a -> m a -> m a
mUnion IntMap (UMap a)
m1 IntMap (UMap a)
m2)

-- | Compile a 'Query' into a 'Matcher'.
mkMatcher :: Matchable ast => Query ast v -> Matcher v
mkMatcher :: forall ast v. Matchable ast => Query ast v -> Matcher v
mkMatcher = forall ast v. Matchable ast => AlphaEnv -> Query ast v -> Matcher v
mkLocalMatcher AlphaEnv
emptyAlphaEnv

-- | Compile a 'Query' into a 'Matcher' within a given local scope. Useful for
-- introducing local matchers which only match within a given local scope.
mkLocalMatcher :: Matchable ast => AlphaEnv -> Query ast v -> Matcher v
mkLocalMatcher :: forall ast v. Matchable ast => AlphaEnv -> Query ast v -> Matcher v
mkLocalMatcher AlphaEnv
env Query{v
Quantifiers
Annotated ast
qResult :: v
qPattern :: Annotated ast
qQuantifiers :: Quantifiers
qResult :: forall ast v. Query ast v -> v
qPattern :: forall ast v. Query ast v -> Annotated ast
qQuantifiers :: forall ast v. Query ast v -> Quantifiers
..} = forall a. IntMap (UMap a) -> Matcher a
Matcher forall a b. (a -> b) -> a -> b
$
  forall a. Int -> a -> IntMap a
I.singleton (AlphaEnv -> Int
alphaEnvOffset AlphaEnv
env) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> a -> m a -> m a
insertMatch
      AlphaEnv
emptyAlphaEnv
      Quantifiers
qQuantifiers
      (forall ast. Matchable ast => ast -> Universe
inject forall a b. (a -> b) -> a -> b
$ forall ast. Annotated ast -> ast
astA Annotated ast
qPattern)
      v
qResult
      forall (m :: * -> *) a. PatternMap m => m a
mEmpty

------------------------------------------------------------------------

-- | Run a 'Matcher' on an expression in the given 'AlphaEnv' and return the
-- results from any matches. Results are accompanied by a 'Substitution', which
-- maps 'Quantifiers' from the original 'Query' to the expressions they unified
-- with.
runMatcher
  :: (Matchable ast, MonadIO m)
  => Context
  -> Matcher v
  -> ast
  -> TransformT m [(Substitution, v)]
runMatcher :: forall ast (m :: * -> *) v.
(Matchable ast, MonadIO m) =>
Context -> Matcher v -> ast -> TransformT m [(Substitution, v)]
runMatcher Context{[RdrName]
Maybe Substitution
FixityEnv
AlphaEnv
Rewriter
ParentPrec
ctxtSubst :: Maybe Substitution
ctxtRewriter :: Rewriter
ctxtParentPrec :: ParentPrec
ctxtInScope :: AlphaEnv
ctxtFixityEnv :: FixityEnv
ctxtDependents :: Rewriter
ctxtBinders :: [RdrName]
ctxtSubst :: Context -> Maybe Substitution
ctxtRewriter :: Context -> Rewriter
ctxtParentPrec :: Context -> ParentPrec
ctxtInScope :: Context -> AlphaEnv
ctxtFixityEnv :: Context -> FixityEnv
ctxtDependents :: Context -> Rewriter
ctxtBinders :: Context -> [RdrName]
..} (Matcher IntMap (UMap v)
m) ast
ast = do
  Int
seed <- forall s (m :: * -> *). MonadState s m => m s
get
  let
    matchEnv :: MatchEnv
matchEnv = AlphaEnv -> (forall a. a -> Annotated a) -> MatchEnv
ME AlphaEnv
ctxtInScope (\a
x -> forall ast. ast -> Int -> Annotated ast
unsafeMkA a
x Int
seed)
    uast :: Universe
uast = forall ast. Matchable ast => ast -> Universe
inject ast
ast

  forall (m :: * -> *) a. Monad m => a -> m a
return
    [ (Substitution, v)
match
    | (Int
lvl, UMap v
umap) <- forall a. IntMap a -> [(Int, a)]
I.toAscList IntMap (UMap v)
m
    , (Substitution, v)
match <- forall (m :: * -> *) a.
PatternMap m =>
MatchEnv -> Key m -> m a -> [(Substitution, a)]
findMatch (Int -> MatchEnv -> MatchEnv
pruneMatchEnv Int
lvl MatchEnv
matchEnv) Universe
uast UMap v
umap
    ]

------------------------------------------------------------------------

-- | A 'Rewrite' is a 'Query' specialized to 'Template' results, which have
-- all the information necessary to replace one expression with another.
type Rewrite ast = Query ast (Template ast, MatchResultTransformer)

-- | Make a 'Rewrite' from given quantifiers and left- and right-hand sides.
mkRewrite :: Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite :: forall ast.
Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite Quantifiers
qQuantifiers Annotated ast
qPattern Annotated ast
tTemplate = Query{(Template ast, MatchResultTransformer)
Quantifiers
Annotated ast
qResult :: (Template ast, MatchResultTransformer)
qPattern :: Annotated ast
qQuantifiers :: Quantifiers
qResult :: (Template ast, MatchResultTransformer)
qPattern :: Annotated ast
qQuantifiers :: Quantifiers
..}
  where
    tImports :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
tImports = forall a. Monoid a => a
mempty
    tDependents :: Maybe a
tDependents = forall a. Maybe a
Nothing
    qResult :: (Template ast, MatchResultTransformer)
qResult = (Template{Annotated ast
Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. Maybe a
tDependents :: Maybe [Rewrite Universe]
tImports :: AnnotatedImports
tTemplate :: Annotated ast
tDependents :: forall a. Maybe a
tImports :: Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
tTemplate :: Annotated ast
..}, MatchResultTransformer
defaultTransformer)

-- | Add imports to a 'Rewrite'. Whenever the 'Rewrite' successfully rewrites
-- an expression, the imports are inserted into the enclosing module.
addRewriteImports :: AnnotatedImports -> Rewrite ast -> Rewrite ast
addRewriteImports :: forall ast. AnnotatedImports -> Rewrite ast -> Rewrite ast
addRewriteImports AnnotatedImports
imports Rewrite ast
q = Rewrite ast
q { qResult :: (Template ast, MatchResultTransformer)
qResult = (Template ast
newTemplate, MatchResultTransformer
transformer) }
  where
    (Template ast
template, MatchResultTransformer
transformer) = forall ast v. Query ast v -> v
qResult Rewrite ast
q
    newTemplate :: Template ast
newTemplate = Template ast
template { tImports :: AnnotatedImports
tImports = AnnotatedImports
imports forall a. Semigroup a => a -> a -> a
<> forall ast. Template ast -> AnnotatedImports
tImports Template ast
template }

-- | Set the 'MatchResultTransformer' for a 'Rewrite'.
setRewriteTransformer :: MatchResultTransformer -> Rewrite ast -> Rewrite ast
setRewriteTransformer :: forall ast. MatchResultTransformer -> Rewrite ast -> Rewrite ast
setRewriteTransformer MatchResultTransformer
transformer Rewrite ast
q =
  Rewrite ast
q { qResult :: (Template ast, MatchResultTransformer)
qResult = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const MatchResultTransformer
transformer) (forall ast v. Query ast v -> v
qResult Rewrite ast
q) }

-- | A 'Rewriter' is a complied 'Rewrite', much like a 'Matcher' is a compiled
-- 'Query'.
type Rewriter = Matcher (RewriterResult Universe)

-- | Compile a 'Rewrite' into a 'Rewriter'.
mkRewriter :: Matchable ast => Rewrite ast -> Rewriter
mkRewriter :: forall ast. Matchable ast => Rewrite ast -> Rewriter
mkRewriter = forall ast. Matchable ast => AlphaEnv -> Rewrite ast -> Rewriter
mkLocalRewriter AlphaEnv
emptyAlphaEnv

-- | Compile a 'Rewrite' into a 'Rewriter' with a given local scope. Useful for
-- introducing local matchers which only match within a given local scope.
mkLocalRewriter :: Matchable ast => AlphaEnv -> Rewrite ast -> Rewriter
mkLocalRewriter :: forall ast. Matchable ast => AlphaEnv -> Rewrite ast -> Rewriter
mkLocalRewriter AlphaEnv
env q :: Rewrite ast
q@Query{(Template ast, MatchResultTransformer)
Quantifiers
Annotated ast
qResult :: (Template ast, MatchResultTransformer)
qPattern :: Annotated ast
qQuantifiers :: Quantifiers
qResult :: forall ast v. Query ast v -> v
qPattern :: forall ast v. Query ast v -> Annotated ast
qQuantifiers :: forall ast v. Query ast v -> Quantifiers
..} =
  forall ast v. Matchable ast => AlphaEnv -> Query ast v -> Matcher v
mkLocalMatcher AlphaEnv
env Rewrite ast
q { qResult :: RewriterResult Universe
qResult = RewriterResult{SrcSpan
Quantifiers
Template Universe
MatchResultTransformer
rrTemplate :: Template Universe
rrTransformer :: MatchResultTransformer
rrQuantifiers :: Quantifiers
rrOrigin :: SrcSpan
rrTransformer :: MatchResultTransformer
rrTemplate :: Template Universe
rrQuantifiers :: Quantifiers
rrOrigin :: SrcSpan
..} }
  where
    rrOrigin :: SrcSpan
rrOrigin = forall ast. Matchable ast => ast -> SrcSpan
getOrigin forall a b. (a -> b) -> a -> b
$ forall ast. Annotated ast -> ast
astA Annotated ast
qPattern
    rrQuantifiers :: Quantifiers
rrQuantifiers = Quantifiers
qQuantifiers
    (Template Universe
rrTemplate, MatchResultTransformer
rrTransformer) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ast. Matchable ast => ast -> Universe
inject) (Template ast, MatchResultTransformer)
qResult

-- | Wrapper that allows us to attach extra derived information to the
-- 'Template' supplied by the 'Rewrite'. Saves the user from specifying it.
data RewriterResult ast = RewriterResult
  { forall ast. RewriterResult ast -> SrcSpan
rrOrigin :: SrcSpan
  , forall ast. RewriterResult ast -> Quantifiers
rrQuantifiers :: Quantifiers
  , forall ast. RewriterResult ast -> MatchResultTransformer
rrTransformer :: MatchResultTransformer
  , forall ast. RewriterResult ast -> Template ast
rrTemplate :: Template ast
  }
  deriving (forall a b. a -> RewriterResult b -> RewriterResult a
forall a b. (a -> b) -> RewriterResult a -> RewriterResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RewriterResult b -> RewriterResult a
$c<$ :: forall a b. a -> RewriterResult b -> RewriterResult a
fmap :: forall a b. (a -> b) -> RewriterResult a -> RewriterResult b
$cfmap :: forall a b. (a -> b) -> RewriterResult a -> RewriterResult b
Functor)

-- | A 'MatchResultTransformer' allows the user to specify custom logic to
-- modify the result of matching the left-hand side of a rewrite
-- (the 'MatchResult'). The 'MatchResult' generated by this function is used
-- to effect the resulting AST rewrite.
--
-- For example, this transformer looks at the matched expression to build
-- the resulting expression:
--
-- > fancyMigration :: MatchResultTransformer
-- > fancyMigration ctxt matchResult
-- >   | MatchResult sub t <- matchResult
-- >   , HoleExpr e <- lookupSubst sub "x" = do
-- >     e' <- ... some fancy IO computation using 'e' ...
-- >     return $ MatchResult (extendSubst sub "x" (HoleExpr e')) t
-- >   | otherwise = NoMatch
-- >
-- > main :: IO ()
-- > main = runScript $ \opts -> do
-- >   rrs <- parseRewrites opts [Adhoc "forall x. ... = ..."]
-- >   return $ apply
-- >     [ setRewriteTransformer fancyMigration rr | rr <- rrs ]
--
-- Since the 'MatchResultTransformer' can also modify the 'Template', you
-- can construct an entirely novel right-hand side, add additional imports,
-- or inject new dependent rewrites.
type MatchResultTransformer =
  Context -> MatchResult Universe -> IO (MatchResult Universe)

-- | The default transformer. Returns the 'MatchResult' unchanged.
defaultTransformer :: MatchResultTransformer
defaultTransformer :: MatchResultTransformer
defaultTransformer = forall a b. a -> b -> a
const forall (m :: * -> *) a. Monad m => a -> m a
return

-- | The right-hand side of a 'Rewrite'.
data Template ast = Template
  { forall ast. Template ast -> Annotated ast
tTemplate :: Annotated ast -- ^ The expression for the right-hand side.
  , forall ast. Template ast -> AnnotatedImports
tImports :: AnnotatedImports
    -- ^ Imports to add whenever a rewrite is successful.
  , forall ast. Template ast -> Maybe [Rewrite Universe]
tDependents :: Maybe [Rewrite Universe]
    -- ^ Dependent rewrites to introduce whenever a rewrite is successful.
    -- See Note [tDependents]
  }

instance Functor Template where
  fmap :: forall a b. (a -> b) -> Template a -> Template b
fmap a -> b
f Template{Maybe [Rewrite Universe]
Annotated a
AnnotatedImports
tDependents :: Maybe [Rewrite Universe]
tImports :: AnnotatedImports
tTemplate :: Annotated a
tDependents :: forall ast. Template ast -> Maybe [Rewrite Universe]
tImports :: forall ast. Template ast -> AnnotatedImports
tTemplate :: forall ast. Template ast -> Annotated ast
..} = Template { tTemplate :: Annotated b
tTemplate = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Annotated a
tTemplate, Maybe [Rewrite Universe]
AnnotatedImports
tDependents :: Maybe [Rewrite Universe]
tImports :: AnnotatedImports
tDependents :: Maybe [Rewrite Universe]
tImports :: AnnotatedImports
..}

-- Note [tDependents]
-- Why Maybe [] instead of just []? We want to support two things:
--
-- 1. Ability to avoid putting most rewrites into ctxtDependents if possible,
-- so context updating doesn't require double-matching every rewrite. Dependent
-- rewrites are not the norm.
--
-- 2. Ability of tTransform to introduce new dependent rewrites. To support
-- this in conjunction with #1, we need some way to say "this should be in
-- ctxtDependents, even if the list is empty".
--
-- So:
--
-- * Nothing = don't include in ctxtDependents
-- * Just [] = include in ctxtDependents, but presumably tTransform will
--             introduce the actual dependent rewrites
-- * Just xs = include in ctxtDependents

-- | The result of matching the left-hand side of a 'Rewrite'.
data MatchResult ast
  = MatchResult Substitution (Template ast)
  | NoMatch

instance Functor MatchResult where
  fmap :: forall a b. (a -> b) -> MatchResult a -> MatchResult b
fmap a -> b
f (MatchResult Substitution
s Template a
t) = forall ast. Substitution -> Template ast -> MatchResult ast
MatchResult Substitution
s (a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template a
t)
  fmap a -> b
_ MatchResult a
NoMatch = forall ast. MatchResult ast
NoMatch

------------------------------------------------------------------------

-- | Run a 'Rewriter' on an expression in the given 'AlphaEnv' and return the
-- 'MatchResult's from any matches. Takes an extra function for rewriting the
-- 'RewriterResult', which is run *before* the 'MatchResultTransformer' is run.
runRewriter
  :: forall ast m. (Matchable ast, MonadIO m)
  => (RewriterResult Universe -> RewriterResult Universe)
  -> Context
  -> Rewriter
  -> ast
  -> TransformT m (MatchResult ast)
runRewriter :: forall ast (m :: * -> *).
(Matchable ast, MonadIO m) =>
(RewriterResult Universe -> RewriterResult Universe)
-> Context -> Rewriter -> ast -> TransformT m (MatchResult ast)
runRewriter RewriterResult Universe -> RewriterResult Universe
f Context
ctxt Rewriter
rewriter =
  forall ast (m :: * -> *) v.
(Matchable ast, MonadIO m) =>
Context -> Matcher v -> ast -> TransformT m [(Substitution, v)]
runMatcher Context
ctxt Rewriter
rewriter forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall ast (m :: * -> *).
(Matchable ast, MonadIO m) =>
Context
-> [(Substitution, RewriterResult Universe)]
-> TransformT m (MatchResult ast)
firstMatch Context
ctxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second RewriterResult Universe -> RewriterResult Universe
f)

-- | Find the first 'valid' match.
-- Runs the user's 'MatchResultTransformer' and sanity checks the result.
firstMatch
  :: (Matchable ast, MonadIO m)
  => Context
  -> [(Substitution, RewriterResult Universe)]
  -> TransformT m (MatchResult ast)
firstMatch :: forall ast (m :: * -> *).
(Matchable ast, MonadIO m) =>
Context
-> [(Substitution, RewriterResult Universe)]
-> TransformT m (MatchResult ast)
firstMatch Context
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall ast. MatchResult ast
NoMatch
firstMatch Context
ctxt ((Substitution
sub, RewriterResult{SrcSpan
Quantifiers
Template Universe
MatchResultTransformer
rrTemplate :: Template Universe
rrTransformer :: MatchResultTransformer
rrQuantifiers :: Quantifiers
rrOrigin :: SrcSpan
rrTemplate :: forall ast. RewriterResult ast -> Template ast
rrTransformer :: forall ast. RewriterResult ast -> MatchResultTransformer
rrQuantifiers :: forall ast. RewriterResult ast -> Quantifiers
rrOrigin :: forall ast. RewriterResult ast -> SrcSpan
..}):[(Substitution, RewriterResult Universe)]
matchResults) = do
  -- 'firstMatch' is lazy in 'rrTransformer', only running it enough
  -- times to get the first valid MatchResult.
  MatchResult Universe
matchResult <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MatchResultTransformer
rrTransformer Context
ctxt (forall ast. Substitution -> Template ast -> MatchResult ast
MatchResult Substitution
sub Template Universe
rrTemplate)
  case MatchResult Universe
matchResult of
    MatchResult Substitution
sub' Template Universe
_
      -- Check that all quantifiers from the original rewrite have mappings
      -- in the resulting substitution. This is mostly to prevent a bad
      -- user-defined MatchResultTransformer from causing havok.
      | forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ FastString -> Substitution -> Maybe HoleVal
lookupSubst FastString
q Substitution
sub' | FastString
q <- Quantifiers -> [FastString]
qList Quantifiers
rrQuantifiers ] ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ast. Matchable ast => Universe -> ast
project forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MatchResult Universe
matchResult
    MatchResult Universe
_ -> forall ast (m :: * -> *).
(Matchable ast, MonadIO m) =>
Context
-> [(Substitution, RewriterResult Universe)]
-> TransformT m (MatchResult ast)
firstMatch Context
ctxt [(Substitution, RewriterResult Universe)]
matchResults

------------------------------------------------------------------------

-- | Pretty-print a 'Rewrite' for debugging.
ppRewrite :: Rewrite Universe -> String
ppRewrite :: Rewrite Universe -> String
ppRewrite Query{(Template Universe, MatchResultTransformer)
Quantifiers
Annotated Universe
qResult :: (Template Universe, MatchResultTransformer)
qPattern :: Annotated Universe
qQuantifiers :: Quantifiers
qResult :: forall ast v. Query ast v -> v
qPattern :: forall ast v. Query ast v -> Annotated ast
qQuantifiers :: forall ast v. Query ast v -> Quantifiers
..} =
  forall a. Show a => a -> String
show (Quantifiers -> [FastString]
qList Quantifiers
qQuantifiers) forall a. [a] -> [a] -> [a]
++
    String
"\n" forall a. [a] -> [a] -> [a]
++ Annotated Universe -> String
printU Annotated Universe
qPattern forall a. [a] -> [a] -> [a]
++
    String
"\n==>\n" forall a. [a] -> [a] -> [a]
++ Annotated Universe -> String
printU (forall ast. Template ast -> Annotated ast
tTemplate forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (Template Universe, MatchResultTransformer)
qResult)

-- | Inject a type-specific rewrite into the universal type.
toURewrite :: Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite :: forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall ast. Matchable ast => ast -> Universe
inject (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ast. Matchable ast => ast -> Universe
inject))

-- | Project a type-specific rewrite from the universal type.
fromURewrite :: Matchable ast => Rewrite Universe -> Rewrite ast
fromURewrite :: forall ast. Matchable ast => Rewrite Universe -> Rewrite ast
fromURewrite = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall ast. Matchable ast => Universe -> ast
project (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ast. Matchable ast => Universe -> ast
project))

-- | Filter a list of rewrites for those that introduce dependent rewrites.
rewritesWithDependents :: [Rewrite ast] -> [Rewrite ast]
rewritesWithDependents :: forall ast. [Rewrite ast] -> [Rewrite ast]
rewritesWithDependents = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ast. Template ast -> Maybe [Rewrite Universe]
tDependents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ast v. Query ast v -> v
qResult)