-- 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 CPP #-}
{-# LANGUAGE TupleSections #-}
module Retrie.Rewrites.Function
  ( dfnsToRewrites
  , getImports
  , matchToRewrites
  ) where

import Control.Monad
import Control.Monad.State.Lazy
import Data.List
import Data.Maybe
import Data.Traversable

import Retrie.ExactPrint
import Retrie.Expr
import Retrie.GHC
import Retrie.Quantifiers
import Retrie.Types

dfnsToRewrites
  :: [(FastString, Direction)]
  -> AnnotatedModule
#if __GLASGOW_HASKELL__ < 900
  -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
#else
  -> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)])
#endif
dfnsToRewrites :: [(FastString, Direction)]
-> AnnotatedModule -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
dfnsToRewrites [(FastString, Direction)]
specs AnnotatedModule
am = (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)])
 -> UniqFM [Rewrite (LHsExpr GhcPs)])
-> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated (UniqFM [Rewrite (LHsExpr GhcPs)])
-> UniqFM [Rewrite (LHsExpr GhcPs)]
forall ast. Annotated ast -> ast
astA (IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
 -> IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
forall a b. (a -> b) -> a -> b
$ AnnotatedModule
-> (Located HsModule
    -> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
am ((Located HsModule
  -> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
 -> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)])))
-> (Located HsModule
    -> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
forall a b. (a -> b) -> a -> b
$ \ (L SrcSpan
_ HsModule
m) -> do
  let
    fsMap :: UniqFM [Direction]
fsMap = [(FastString, Direction)] -> UniqFM [Direction]
forall a b. Uniquable a => [(a, b)] -> UniqFM [b]
uniqBag [(FastString, Direction)]
specs

  [(FastString, [Rewrite (LHsExpr GhcPs)])]
rrs <- [TransformT IO (FastString, [Rewrite (LHsExpr GhcPs)])]
-> TransformT IO [(FastString, [Rewrite (LHsExpr GhcPs)])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ do
        LHsExpr GhcPs
fe <- Located RdrName -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
Located RdrName -> TransformT m (LHsExpr GhcPs)
mkLocatedHsVar Located RdrName
fRdrName
        AnnotatedImports
imps <- Direction
-> Maybe (Located ModuleName) -> TransformT IO AnnotatedImports
getImports Direction
dir (HsModule -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
hsmodName HsModule
m)
        (FastString
fName,) ([Rewrite (LHsExpr GhcPs)]
 -> (FastString, [Rewrite (LHsExpr GhcPs)]))
-> ([[Rewrite (LHsExpr GhcPs)]] -> [Rewrite (LHsExpr GhcPs)])
-> [[Rewrite (LHsExpr GhcPs)]]
-> (FastString, [Rewrite (LHsExpr GhcPs)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Rewrite (LHsExpr GhcPs)]] -> [Rewrite (LHsExpr GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Rewrite (LHsExpr GhcPs)]]
 -> (FastString, [Rewrite (LHsExpr GhcPs)]))
-> TransformT IO [[Rewrite (LHsExpr GhcPs)]]
-> TransformT IO (FastString, [Rewrite (LHsExpr GhcPs)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          [LMatch GhcPs (LHsExpr GhcPs)]
-> (LMatch GhcPs (LHsExpr GhcPs)
    -> TransformT IO [Rewrite (LHsExpr GhcPs)])
-> TransformT IO [[Rewrite (LHsExpr GhcPs)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Located [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located [LMatch GhcPs (LHsExpr GhcPs)]
 -> SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)]))
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (LHsExpr GhcPs)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts (MatchGroup GhcPs (LHsExpr GhcPs)
 -> Located [LMatch GhcPs (LHsExpr GhcPs)])
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ HsBindLR GhcPs GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs)
forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches HsBindLR GhcPs GhcPs
f) (LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> LMatch GhcPs (LHsExpr GhcPs)
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
matchToRewrites LHsExpr GhcPs
fe AnnotatedImports
imps Direction
dir)
    | L SrcSpan
_ (ValD XValD GhcPs
_ f :: HsBindLR GhcPs GhcPs
f@FunBind{}) <- HsModule -> [GenLocated SrcSpan (HsDecl GhcPs)]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule
m
    , let fRdrName :: Located (IdP GhcPs)
fRdrName = HsBindLR GhcPs GhcPs -> Located (IdP GhcPs)
forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id HsBindLR GhcPs GhcPs
f
    , let fName :: FastString
fName = OccName -> FastString
occNameFS (RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
fRdrName))
    , Direction
dir <- [Direction] -> Maybe [Direction] -> [Direction]
forall a. a -> Maybe a -> a
fromMaybe [] (UniqFM [Direction] -> FastString -> Maybe [Direction]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Direction]
fsMap FastString
fName)
    ]

  UniqFM [Rewrite (LHsExpr GhcPs)]
-> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)])
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqFM [Rewrite (LHsExpr GhcPs)]
 -> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> UniqFM [Rewrite (LHsExpr GhcPs)]
-> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)])
forall a b. (a -> b) -> a -> b
$ ([Rewrite (LHsExpr GhcPs)]
 -> [Rewrite (LHsExpr GhcPs)] -> [Rewrite (LHsExpr GhcPs)])
-> [(FastString, [Rewrite (LHsExpr GhcPs)])]
-> UniqFM [Rewrite (LHsExpr GhcPs)]
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> [(key, elt)] -> UniqFM elt
listToUFM_C [Rewrite (LHsExpr GhcPs)]
-> [Rewrite (LHsExpr GhcPs)] -> [Rewrite (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
(++) [(FastString, [Rewrite (LHsExpr GhcPs)])]
rrs

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

getImports
  :: Direction -> Maybe (Located ModuleName) -> TransformT IO AnnotatedImports
getImports :: Direction
-> Maybe (Located ModuleName) -> TransformT IO AnnotatedImports
getImports Direction
RightToLeft (Just (L SrcSpan
_ ModuleName
mn)) = -- See Note [fold only]
  IO AnnotatedImports -> TransformT IO AnnotatedImports
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO AnnotatedImports -> TransformT IO AnnotatedImports)
-> IO AnnotatedImports -> TransformT IO AnnotatedImports
forall a b. (a -> b) -> a -> b
$ IO AnnotatedImports -> IO AnnotatedImports
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AnnotatedImports -> IO AnnotatedImports)
-> IO AnnotatedImports -> IO AnnotatedImports
forall a b. (a -> b) -> a -> b
$ [String] -> IO AnnotatedImports
parseImports [String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
mn]
getImports Direction
_ Maybe (Located ModuleName)
_ = AnnotatedImports -> TransformT IO AnnotatedImports
forall (m :: * -> *) a. Monad m => a -> m a
return AnnotatedImports
forall a. Monoid a => a
mempty

matchToRewrites
  :: LHsExpr GhcPs
  -> AnnotatedImports
  -> Direction
  -> LMatch GhcPs (LHsExpr GhcPs)
  -> TransformT IO [Rewrite (LHsExpr GhcPs)]
matchToRewrites :: LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> LMatch GhcPs (LHsExpr GhcPs)
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
matchToRewrites LHsExpr GhcPs
e AnnotatedImports
imps Direction
dir (L SrcSpan
_ Match GhcPs (LHsExpr GhcPs)
alt) = do
  let
    pats :: [LPat GhcPs]
pats = Match GhcPs (LHsExpr GhcPs) -> [LPat GhcPs]
forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (LHsExpr GhcPs)
alt
    grhss :: GRHSs GhcPs (LHsExpr GhcPs)
grhss = Match GhcPs (LHsExpr GhcPs) -> GRHSs GhcPs (LHsExpr GhcPs)
forall p body. Match p body -> GRHSs p body
m_grhss Match GhcPs (LHsExpr GhcPs)
alt
  [[Rewrite (LHsExpr GhcPs)]]
qss <- [([Located (Pat GhcPs)], [Located (Pat GhcPs)])]
-> (([Located (Pat GhcPs)], [Located (Pat GhcPs)])
    -> TransformT IO [Rewrite (LHsExpr GhcPs)])
-> TransformT IO [[Rewrite (LHsExpr GhcPs)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([[Located (Pat GhcPs)]]
-> [[Located (Pat GhcPs)]]
-> [([Located (Pat GhcPs)], [Located (Pat GhcPs)])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Located (Pat GhcPs)] -> [[Located (Pat GhcPs)]]
forall a. [a] -> [[a]]
inits [Located (Pat GhcPs)]
pats) ([Located (Pat GhcPs)] -> [[Located (Pat GhcPs)]]
forall a. [a] -> [[a]]
tails [Located (Pat GhcPs)]
pats)) ((([Located (Pat GhcPs)], [Located (Pat GhcPs)])
  -> TransformT IO [Rewrite (LHsExpr GhcPs)])
 -> TransformT IO [[Rewrite (LHsExpr GhcPs)]])
-> (([Located (Pat GhcPs)], [Located (Pat GhcPs)])
    -> TransformT IO [Rewrite (LHsExpr GhcPs)])
-> TransformT IO [[Rewrite (LHsExpr GhcPs)]]
forall a b. (a -> b) -> a -> b
$
    LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> GRHSs GhcPs (LHsExpr GhcPs)
-> AppBuilder
-> ([LPat GhcPs], [LPat GhcPs])
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
makeFunctionQuery LHsExpr GhcPs
e AnnotatedImports
imps Direction
dir GRHSs GhcPs (LHsExpr GhcPs)
grhss AppBuilder
forall (m :: * -> *).
Monad m =>
LHsExpr GhcPs -> [LHsExpr GhcPs] -> TransformT m (LHsExpr GhcPs)
mkApps
  [Rewrite (LHsExpr GhcPs)]
qs <- LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> GRHSs GhcPs (LHsExpr GhcPs)
-> [LPat GhcPs]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
backtickRules LHsExpr GhcPs
e AnnotatedImports
imps Direction
dir GRHSs GhcPs (LHsExpr GhcPs)
grhss [LPat GhcPs]
[Located (Pat GhcPs)]
pats
  [Rewrite (LHsExpr GhcPs)]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rewrite (LHsExpr GhcPs)]
 -> TransformT IO [Rewrite (LHsExpr GhcPs)])
-> [Rewrite (LHsExpr GhcPs)]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ [Rewrite (LHsExpr GhcPs)]
qs [Rewrite (LHsExpr GhcPs)]
-> [Rewrite (LHsExpr GhcPs)] -> [Rewrite (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [[Rewrite (LHsExpr GhcPs)]] -> [Rewrite (LHsExpr GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Rewrite (LHsExpr GhcPs)]]
qss

type AppBuilder =
  LHsExpr GhcPs -> [LHsExpr GhcPs] -> TransformT IO (LHsExpr GhcPs)

irrefutablePat :: LPat GhcPs -> Bool
irrefutablePat :: LPat GhcPs -> Bool
irrefutablePat = Pat GhcPs -> Bool
go (Pat GhcPs -> Bool)
-> (Located (Pat GhcPs) -> Pat GhcPs)
-> Located (Pat GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Pat GhcPs) -> Pat GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc
  where
    go :: Pat GhcPs -> Bool
go WildPat{} = Bool
True
    go VarPat{} = Bool
True
    go (LazyPat XLazyPat GhcPs
_ LPat GhcPs
p) = LPat GhcPs -> Bool
irrefutablePat LPat GhcPs
p
    go (AsPat XAsPat GhcPs
_ Located (IdP GhcPs)
_ LPat GhcPs
p) = LPat GhcPs -> Bool
irrefutablePat LPat GhcPs
p
    go (ParPat XParPat GhcPs
_ LPat GhcPs
p) = LPat GhcPs -> Bool
irrefutablePat LPat GhcPs
p
    go (BangPat XBangPat GhcPs
_ LPat GhcPs
p) = LPat GhcPs -> Bool
irrefutablePat LPat GhcPs
p
    go Pat GhcPs
_ = Bool
False

makeFunctionQuery
  :: LHsExpr GhcPs
  -> AnnotatedImports
  -> Direction
  -> GRHSs GhcPs (LHsExpr GhcPs)
  -> AppBuilder
  -> ([LPat GhcPs], [LPat GhcPs])
  -> TransformT IO [Rewrite (LHsExpr GhcPs)]
makeFunctionQuery :: LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> GRHSs GhcPs (LHsExpr GhcPs)
-> AppBuilder
-> ([LPat GhcPs], [LPat GhcPs])
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
makeFunctionQuery LHsExpr GhcPs
e AnnotatedImports
imps Direction
dir GRHSs GhcPs (LHsExpr GhcPs)
grhss AppBuilder
mkAppFn ([LPat GhcPs]
argpats, [LPat GhcPs]
bndpats)
  | (Located (Pat GhcPs) -> Bool) -> [Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool)
-> (Located (Pat GhcPs) -> Bool) -> Located (Pat GhcPs) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> Bool
Located (Pat GhcPs) -> Bool
irrefutablePat) [LPat GhcPs]
[Located (Pat GhcPs)]
bndpats = [Rewrite (LHsExpr GhcPs)]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise = do
    let
      GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
rhss LHsLocalBinds GhcPs
lbs = GRHSs GhcPs (LHsExpr GhcPs)
grhss
      bs :: [IdP GhcPs]
bs = [LPat GhcPs] -> [IdP GhcPs]
forall (p :: Pass). [LPat (GhcPass p)] -> [IdP (GhcPass p)]
collectPatsBinders [LPat GhcPs]
argpats
    -- See Note [Wildcards]
    ([LHsExpr GhcPs]
es,([RdrName]
_,[RdrName]
bs')) <- StateT ([RdrName], [RdrName]) (TransformT IO) [LHsExpr GhcPs]
-> ([RdrName], [RdrName])
-> TransformT IO ([LHsExpr GhcPs], ([RdrName], [RdrName]))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((Located (Pat GhcPs)
 -> StateT ([RdrName], [RdrName]) (TransformT IO) (LHsExpr GhcPs))
-> [Located (Pat GhcPs)]
-> StateT ([RdrName], [RdrName]) (TransformT IO) [LHsExpr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Pat GhcPs)
-> StateT ([RdrName], [RdrName]) (TransformT IO) (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
LPat GhcPs -> PatQ m (LHsExpr GhcPs)
patToExpr [LPat GhcPs]
[Located (Pat GhcPs)]
argpats) ([RdrName] -> [RdrName]
wildSupply [RdrName]
bs, [RdrName]
bs)
    LHsExpr GhcPs
lhs <- AppBuilder
mkAppFn LHsExpr GhcPs
e [LHsExpr GhcPs]
es
    [LGRHS GhcPs (LHsExpr GhcPs)]
-> (LGRHS GhcPs (LHsExpr GhcPs)
    -> TransformT IO (Rewrite (LHsExpr GhcPs)))
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [LGRHS GhcPs (LHsExpr GhcPs)]
rhss ((LGRHS GhcPs (LHsExpr GhcPs)
  -> TransformT IO (Rewrite (LHsExpr GhcPs)))
 -> TransformT IO [Rewrite (LHsExpr GhcPs)])
-> (LGRHS GhcPs (LHsExpr GhcPs)
    -> TransformT IO (Rewrite (LHsExpr GhcPs)))
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ \ LGRHS GhcPs (LHsExpr GhcPs)
grhs -> do
      LHsExpr GhcPs
le <- HsLocalBinds GhcPs
-> LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
mkLet (LHsLocalBinds GhcPs -> SrcSpanLess (LHsLocalBinds GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsLocalBinds GhcPs
lbs) (LGRHS GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
forall p. LGRHS p (LHsExpr p) -> LHsExpr p
grhsToExpr LGRHS GhcPs (LHsExpr GhcPs)
grhs)
      LHsExpr GhcPs
rhs <- [LPat GhcPs] -> LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
mkLams [LPat GhcPs]
bndpats LHsExpr GhcPs
le
      let
        (LHsExpr GhcPs
pat, LHsExpr GhcPs
temp) =
          case Direction
dir of
            Direction
LeftToRight -> (LHsExpr GhcPs
lhs,LHsExpr GhcPs
rhs)
            Direction
RightToLeft -> (LHsExpr GhcPs
rhs,LHsExpr GhcPs
lhs)
      Annotated (LHsExpr GhcPs)
p <- LHsExpr GhcPs -> TransformT IO (Annotated (LHsExpr GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA LHsExpr GhcPs
pat
      Annotated (LHsExpr GhcPs)
t <- LHsExpr GhcPs -> TransformT IO (Annotated (LHsExpr GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA LHsExpr GhcPs
temp
      Rewrite (LHsExpr GhcPs) -> TransformT IO (Rewrite (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Rewrite (LHsExpr GhcPs)
 -> TransformT IO (Rewrite (LHsExpr GhcPs)))
-> Rewrite (LHsExpr GhcPs)
-> TransformT IO (Rewrite (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ AnnotatedImports
-> Rewrite (LHsExpr GhcPs) -> Rewrite (LHsExpr GhcPs)
forall ast. AnnotatedImports -> Rewrite ast -> Rewrite ast
addRewriteImports AnnotatedImports
imps (Rewrite (LHsExpr GhcPs) -> Rewrite (LHsExpr GhcPs))
-> Rewrite (LHsExpr GhcPs) -> Rewrite (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Quantifiers
-> Annotated (LHsExpr GhcPs)
-> Annotated (LHsExpr GhcPs)
-> Rewrite (LHsExpr GhcPs)
forall ast.
Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite ([RdrName] -> Quantifiers
mkQs [RdrName]
bs') Annotated (LHsExpr GhcPs)
p Annotated (LHsExpr GhcPs)
t

backtickRules
  :: LHsExpr GhcPs
  -> AnnotatedImports
  -> Direction
  -> GRHSs GhcPs (LHsExpr GhcPs)
  -> [LPat GhcPs]
  -> TransformT IO [Rewrite (LHsExpr GhcPs)]
backtickRules :: LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> GRHSs GhcPs (LHsExpr GhcPs)
-> [LPat GhcPs]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
backtickRules LHsExpr GhcPs
e AnnotatedImports
imps dir :: Direction
dir@Direction
LeftToRight GRHSs GhcPs (LHsExpr GhcPs)
grhss ps :: [LPat GhcPs]
ps@[LPat GhcPs
p1, LPat GhcPs
p2] = do
  let
    both, left, right :: AppBuilder
    both :: AppBuilder
both LHsExpr GhcPs
op [LHsExpr GhcPs
l, LHsExpr GhcPs
r] = HsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExtField
XOpApp GhcPs
noExtField LHsExpr GhcPs
l LHsExpr GhcPs
op LHsExpr GhcPs
r)
    both LHsExpr GhcPs
_ [LHsExpr GhcPs]
_ = String -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"backtickRules - both: impossible!"

    left :: AppBuilder
left LHsExpr GhcPs
op [LHsExpr GhcPs
l] = HsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc (XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL NoExtField
XSectionL GhcPs
noExtField LHsExpr GhcPs
l LHsExpr GhcPs
op)
    left LHsExpr GhcPs
_ [LHsExpr GhcPs]
_ = String -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"backtickRules - left: impossible!"

    right :: AppBuilder
right LHsExpr GhcPs
op [LHsExpr GhcPs
r] = HsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR NoExtField
XSectionR GhcPs
noExtField LHsExpr GhcPs
op LHsExpr GhcPs
r)
    right LHsExpr GhcPs
_ [LHsExpr GhcPs]
_ = String -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"backtickRules - right: impossible!"
  [Rewrite (LHsExpr GhcPs)]
qs <- LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> GRHSs GhcPs (LHsExpr GhcPs)
-> AppBuilder
-> ([LPat GhcPs], [LPat GhcPs])
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
makeFunctionQuery LHsExpr GhcPs
e AnnotatedImports
imps Direction
dir GRHSs GhcPs (LHsExpr GhcPs)
grhss AppBuilder
both ([LPat GhcPs]
ps, [])
  [Rewrite (LHsExpr GhcPs)]
qsl <- LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> GRHSs GhcPs (LHsExpr GhcPs)
-> AppBuilder
-> ([LPat GhcPs], [LPat GhcPs])
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
makeFunctionQuery LHsExpr GhcPs
e AnnotatedImports
imps Direction
dir GRHSs GhcPs (LHsExpr GhcPs)
grhss AppBuilder
left ([LPat GhcPs
p1], [LPat GhcPs
p2])
  [Rewrite (LHsExpr GhcPs)]
qsr <- LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> GRHSs GhcPs (LHsExpr GhcPs)
-> AppBuilder
-> ([LPat GhcPs], [LPat GhcPs])
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
makeFunctionQuery LHsExpr GhcPs
e AnnotatedImports
imps Direction
dir GRHSs GhcPs (LHsExpr GhcPs)
grhss AppBuilder
right ([LPat GhcPs
p2], [LPat GhcPs
p1])
  [Rewrite (LHsExpr GhcPs)]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rewrite (LHsExpr GhcPs)]
 -> TransformT IO [Rewrite (LHsExpr GhcPs)])
-> [Rewrite (LHsExpr GhcPs)]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ [Rewrite (LHsExpr GhcPs)]
qs [Rewrite (LHsExpr GhcPs)]
-> [Rewrite (LHsExpr GhcPs)] -> [Rewrite (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Rewrite (LHsExpr GhcPs)]
qsl [Rewrite (LHsExpr GhcPs)]
-> [Rewrite (LHsExpr GhcPs)] -> [Rewrite (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Rewrite (LHsExpr GhcPs)]
qsr
backtickRules LHsExpr GhcPs
_ AnnotatedImports
_ Direction
_ GRHSs GhcPs (LHsExpr GhcPs)
_ [LPat GhcPs]
_ = [Rewrite (LHsExpr GhcPs)]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Note [fold only]
-- Currently we only generate imports for folds, because it is easy.
-- (We only need to add an import for the module defining the folded
-- function.) Generating the imports for unfolds will require some
-- sort of analysis with haskell-names and is a TODO.