-- 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
import Retrie.Util

dfnsToRewrites
  :: LibDir
  -> [(FastString, Direction)]
  -> AnnotatedModule
  -> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)])
dfnsToRewrites :: String
-> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)])
dfnsToRewrites String
libdir [(FastString, Direction)]
specs AnnotatedModule
am = (Annotated
   (UniqFM
      FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
 -> UniqFM FastString [Rewrite (LHsExpr GhcPs)])
-> IO
     (Annotated
        (UniqFM
           FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
-> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated
  (UniqFM
     FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> UniqFM FastString [Rewrite (LHsExpr GhcPs)]
Annotated
  (UniqFM
     FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> UniqFM
     FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall ast. Annotated ast -> ast
astA (IO
   (Annotated
      (UniqFM
         FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
 -> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)]))
-> IO
     (Annotated
        (UniqFM
           FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
-> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)])
forall a b. (a -> b) -> a -> b
$ AnnotatedModule
-> (Located (HsModule GhcPs)
    -> TransformT
         IO
         (UniqFM
            FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
-> IO
     (Annotated
        (UniqFM
           FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
am ((Located (HsModule GhcPs)
  -> TransformT
       IO
       (UniqFM
          FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
 -> IO
      (Annotated
         (UniqFM
            FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])))
-> (Located (HsModule GhcPs)
    -> TransformT
         IO
         (UniqFM
            FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
-> IO
     (Annotated
        (UniqFM
           FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
forall a b. (a -> b) -> a -> b
$ \ (L SrcSpan
_ HsModule GhcPs
m) -> do
  let
    fsMap :: UniqFM FastString [Direction]
fsMap = [(FastString, Direction)] -> UniqFM FastString [Direction]
forall a b. Uniquable a => [(a, b)] -> UniqFM a [b]
uniqBag [(FastString, Direction)]
specs

  [(FastString, [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])]
rrs <- [TransformT
   IO (FastString, [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])]
-> TransformT
     IO
     [(FastString, [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ do
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
fe <- LocatedN RdrName -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsExpr GhcPs)
mkLocatedHsVar XRec GhcPs (IdP GhcPs)
LocatedN RdrName
fRdrName
        -- lift $ debugPrint Loud "dfnsToRewrites:ef="  [showAst fe]
        Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps <- String
-> Direction
-> Maybe (LocatedA ModuleName)
-> TransformT IO AnnotatedImports
getImports String
libdir Direction
dir (HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
m)
        (FastString
fName,) ([Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> (FastString, [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
-> ([[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
    -> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
-> (FastString, [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
 -> (FastString, [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]))
-> TransformT
     IO [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
-> TransformT
     IO (FastString, [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          [GenLocated
   (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
   (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> (GenLocated
      (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
      (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> TransformT
     IO [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (GenLocated
  (Anno
     [GenLocated
        (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
        (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
  [GenLocated
     (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
     (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
      (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. GenLocated l e -> e
unLoc (GenLocated
   (Anno
      [GenLocated
         (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
         (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
   [GenLocated
      (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
      (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> [GenLocated
       (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
       (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> GenLocated
     (Anno
        [GenLocated
           (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
           (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
     [GenLocated
        (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
        (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      (Anno (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
      (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
     GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts (MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> XRec
      GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
     GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr GhcPs)
fe AnnotatedImports
Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps Direction
dir)
    | L SrcSpanAnnA
_ (ValD XValD GhcPs
_ f :: HsBindLR GhcPs GhcPs
f@FunBind{}) <- HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
m
    , let fRdrName :: XRec GhcPs (IdP GhcPs)
fRdrName = HsBindLR GhcPs GhcPs -> XRec GhcPs (IdP GhcPs)
forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id HsBindLR GhcPs GhcPs
f
    , let fName :: FastString
fName = OccName -> FastString
occNameFS (IdP GhcPs -> OccName
forall name. HasOccName name => name -> OccName
occName (GenLocated SrcSpanAnnN (IdP GhcPs) -> IdP GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (IdP GhcPs)
GenLocated SrcSpanAnnN (IdP GhcPs)
fRdrName))
    , Direction
dir <- [Direction] -> Maybe [Direction] -> [Direction]
forall a. a -> Maybe a -> a
fromMaybe [] (UniqFM FastString [Direction] -> FastString -> Maybe [Direction]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM FastString [Direction]
fsMap FastString
fName)
    ]

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

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

getImports
  :: LibDir -> Direction -> Maybe (LocatedA ModuleName) -> TransformT IO AnnotatedImports
getImports :: String
-> Direction
-> Maybe (LocatedA ModuleName)
-> TransformT IO AnnotatedImports
getImports String
libdir Direction
RightToLeft (Just (L SrcSpanAnnA
_ ModuleName
mn)) = -- See Note [fold only]
  RWST () [String] Int IO AnnotatedImports
-> TransformT IO AnnotatedImports
forall (m :: * -> *) a. RWST () [String] Int m a -> TransformT m a
TransformT (RWST () [String] Int IO AnnotatedImports
 -> TransformT IO AnnotatedImports)
-> RWST () [String] Int IO AnnotatedImports
-> TransformT IO AnnotatedImports
forall a b. (a -> b) -> a -> b
$ IO AnnotatedImports -> RWST () [String] Int IO AnnotatedImports
forall (m :: * -> *) a. Monad m => m a -> RWST () [String] Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO AnnotatedImports -> RWST () [String] Int IO AnnotatedImports)
-> IO AnnotatedImports -> RWST () [String] Int IO AnnotatedImports
forall a b. (a -> b) -> a -> b
$ IO AnnotatedImports -> IO AnnotatedImports
forall a. IO a -> IO a
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 -> [String] -> IO AnnotatedImports
parseImports String
libdir [String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
mn]
getImports String
_ Direction
_ Maybe (LocatedA ModuleName)
_ = Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> TransformT
     IO (Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Annotated [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
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 SrcSpanAnnA
_ Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
alt) = do
  -- lift $ debugPrint Loud "matchToRewrites:e="  [showAst e]
  let
    pats :: [LPat GhcPs]
pats = Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> [LPat GhcPs]
forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
alt
    grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss = Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body. Match p body -> GRHSs p body
m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
alt
  [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
qss <- [([LPat GhcPs], [LPat GhcPs])]
-> (([LPat GhcPs], [LPat 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 ([[GenLocated SrcSpanAnnA (Pat GhcPs)]]
-> [[GenLocated SrcSpanAnnA (Pat GhcPs)]]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     [GenLocated SrcSpanAnnA (Pat GhcPs)])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [[GenLocated SrcSpanAnnA (Pat GhcPs)]]
forall a. [a] -> [[a]]
inits [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats) ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [[GenLocated SrcSpanAnnA (Pat GhcPs)]]
forall a. [a] -> [[a]]
tails [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats)) ((([LPat GhcPs], [LPat GhcPs])
  -> TransformT IO [Rewrite (LHsExpr GhcPs)])
 -> TransformT IO [[Rewrite (LHsExpr GhcPs)]])
-> (([LPat GhcPs], [LPat 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 GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss AppBuilder
forall (m :: * -> *).
MonadIO m =>
LHsExpr GhcPs -> [LHsExpr GhcPs] -> TransformT m (LHsExpr GhcPs)
mkApps
  [Rewrite (GenLocated SrcSpanAnnA (HsExpr 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 GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss [LPat GhcPs]
pats
  [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
qs [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. [a] -> [a] -> [a]
++ [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Rewrite (GenLocated SrcSpanAnnA (HsExpr 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)
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
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
#if __GLASGOW_HASKELL__ <= 904
    go (AsPat _ _ p) = irrefutablePat p
#else
    go (AsPat XAsPat GhcPs
_ XRec GhcPs (IdP GhcPs)
_ LHsToken "@" GhcPs
_ LPat GhcPs
p) = LPat GhcPs -> Bool
irrefutablePat LPat GhcPs
p
#endif
#if __GLASGOW_HASKELL__ < 904
    go (ParPat _ p) = irrefutablePat p
#else
    go (ParPat XParPat GhcPs
_ LHsToken "(" GhcPs
_ LPat GhcPs
p LHsToken ")" GhcPs
_) = LPat GhcPs -> Bool
irrefutablePat LPat GhcPs
p
#endif
    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)
  | (GenLocated SrcSpanAnnA (Pat GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool)
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> Bool)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcPs -> Bool
GenLocated SrcSpanAnnA (Pat GhcPs) -> Bool
irrefutablePat) [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
bndpats = [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise = do
    let
      GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
rhss HsLocalBinds GhcPs
lbs = GRHSs GhcPs (LHsExpr GhcPs)
grhss
      bs :: [IdP GhcPs]
bs = CollectFlag GhcPs -> [LPat GhcPs] -> [IdP GhcPs]
forall p. CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]
collectPatsBinders CollectFlag GhcPs
forall p. CollectFlag p
CollNoDictBinders [LPat GhcPs]
argpats
    -- See Note [Wildcards]
    ([GenLocated SrcSpanAnnA (HsExpr GhcPs)]
es,([RdrName]
_,[RdrName]
bs')) <- StateT
  ([RdrName], [RdrName])
  (TransformT IO)
  [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> ([RdrName], [RdrName])
-> TransformT
     IO
     ([GenLocated SrcSpanAnnA (HsExpr GhcPs)], ([RdrName], [RdrName]))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((GenLocated SrcSpanAnnA (Pat GhcPs)
 -> StateT
      ([RdrName], [RdrName])
      (TransformT IO)
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> StateT
     ([RdrName], [RdrName])
     (TransformT IO)
     [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
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 LPat GhcPs -> PatQ IO (LHsExpr GhcPs)
GenLocated SrcSpanAnnA (Pat GhcPs)
-> StateT
     ([RdrName], [RdrName])
     (TransformT IO)
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: * -> *).
MonadIO m =>
LPat GhcPs -> PatQ m (LHsExpr GhcPs)
patToExpr [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
argpats) ([RdrName] -> [RdrName]
wildSupply [RdrName]
bs, [RdrName]
bs)
    -- lift $ debugPrint Loud "makeFunctionQuery:e="  [showAst e]
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs <- AppBuilder
mkAppFn LHsExpr GhcPs
e [LHsExpr GhcPs]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
es
    [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> (GenLocated
      (SrcAnn NoEpAnns)
      (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> TransformT IO (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
rhss ((GenLocated
    (SrcAnn NoEpAnns)
    (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
  -> TransformT IO (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
 -> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> (GenLocated
      (SrcAnn NoEpAnns)
      (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    -> TransformT IO (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ \ GenLocated
  (SrcAnn NoEpAnns)
  (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
grhs -> do
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
le <- HsLocalBinds GhcPs
-> LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
HsLocalBinds GhcPs -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
mkLet HsLocalBinds GhcPs
lbs (LGRHS GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
grhsToExpr LGRHS GhcPs (LHsExpr GhcPs)
GenLocated
  (SrcAnn NoEpAnns)
  (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
grhs)
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs <- [LPat GhcPs] -> LHsExpr GhcPs -> TransformT IO (LHsExpr GhcPs)
mkLams [LPat GhcPs]
bndpats LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
le
      let
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)
pat, GenLocated SrcSpanAnnA (HsExpr GhcPs)
temp) =
          case Direction
dir of
            Direction
LeftToRight -> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs,GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs)
            Direction
RightToLeft -> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs,GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs)
      Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
p <- GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT
     IO (Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA GenLocated SrcSpanAnnA (HsExpr GhcPs)
pat
      Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
t <- GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> TransformT
     IO (Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA GenLocated SrcSpanAnnA (HsExpr GhcPs)
temp
      Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> TransformT IO (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> TransformT IO (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> TransformT IO (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ AnnotatedImports
-> Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall ast. AnnotatedImports -> Rewrite ast -> Rewrite ast
addRewriteImports AnnotatedImports
imps (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ Quantifiers
-> Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall ast.
Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite ([RdrName] -> Quantifiers
mkQs [RdrName]
bs') Annotated (GenLocated SrcSpanAnnA (HsExpr GhcPs))
p Annotated (GenLocated SrcSpanAnnA (HsExpr 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] = DeltaPos
-> HsExpr GhcPs
-> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsExpr GhcPs
l LHsExpr GhcPs
op LHsExpr GhcPs
r)
    both LHsExpr GhcPs
_ [LHsExpr GhcPs]
_ = String -> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. String -> TransformT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"backtickRules - both: impossible!"

    left :: AppBuilder
left LHsExpr GhcPs
op [LHsExpr GhcPs
l] = DeltaPos
-> HsExpr GhcPs
-> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) (XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcPs
EpAnn NoEpAnns
forall a. EpAnn a
noAnn LHsExpr GhcPs
l LHsExpr GhcPs
op)
    left LHsExpr GhcPs
_ [LHsExpr GhcPs]
_ = String -> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. String -> TransformT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"backtickRules - left: impossible!"

    right :: AppBuilder
right LHsExpr GhcPs
op [LHsExpr GhcPs
r] = DeltaPos
-> HsExpr GhcPs
-> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcPs
EpAnn NoEpAnns
forall a. EpAnn a
noAnn LHsExpr GhcPs
op LHsExpr GhcPs
r)
    right LHsExpr GhcPs
_ [LHsExpr GhcPs]
_ = String -> TransformT IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. String -> TransformT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"backtickRules - right: impossible!"
  [Rewrite (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
qs [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. [a] -> [a] -> [a]
++ [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
qsl [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. [a] -> [a] -> [a]
++ [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
qsr
backtickRules LHsExpr GhcPs
_ AnnotatedImports
_ Direction
_ GRHSs GhcPs (LHsExpr GhcPs)
_ [LPat GhcPs]
_ = [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. a -> TransformT IO a
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.