-- 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 GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Retrie.Rewrites.Patterns (patternSynonymsToRewrites) where

import Control.Monad.State (StateT(runStateT))
import Control.Monad
import Data.Maybe

import Retrie.ExactPrint
import Retrie.Expr
import Retrie.GHC
import Retrie.Quantifiers
import Retrie.Rewrites.Function
import Retrie.Types
import Retrie.Universe
import Retrie.Util

patternSynonymsToRewrites
  :: [(FastString, Direction)]
  -> AnnotatedModule
#if __GLASGOW_HASKELL__ < 900
  -> IO (UniqFM [Rewrite Universe])
#else
  -> IO (UniqFM FastString [Rewrite Universe])
#endif
patternSynonymsToRewrites :: [(FastString, Direction)]
-> AnnotatedModule -> IO (UniqFM [Rewrite Universe])
patternSynonymsToRewrites [(FastString, Direction)]
specs AnnotatedModule
am = (Annotated (UniqFM [Rewrite Universe])
 -> UniqFM [Rewrite Universe])
-> IO (Annotated (UniqFM [Rewrite Universe]))
-> IO (UniqFM [Rewrite Universe])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated (UniqFM [Rewrite Universe]) -> UniqFM [Rewrite Universe]
forall ast. Annotated ast -> ast
astA (IO (Annotated (UniqFM [Rewrite Universe]))
 -> IO (UniqFM [Rewrite Universe]))
-> IO (Annotated (UniqFM [Rewrite Universe]))
-> IO (UniqFM [Rewrite Universe])
forall a b. (a -> b) -> a -> b
$ AnnotatedModule
-> (Located HsModule -> TransformT IO (UniqFM [Rewrite Universe]))
-> IO (Annotated (UniqFM [Rewrite Universe]))
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
am ((Located HsModule -> TransformT IO (UniqFM [Rewrite Universe]))
 -> IO (Annotated (UniqFM [Rewrite Universe])))
-> (Located HsModule -> TransformT IO (UniqFM [Rewrite Universe]))
-> IO (Annotated (UniqFM [Rewrite Universe]))
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
  AnnotatedImports
imports <- Direction
-> Maybe (Located ModuleName) -> TransformT IO AnnotatedImports
getImports Direction
RightToLeft (HsModule -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
hsmodName HsModule
m)
  [(FastString, [Rewrite Universe])]
rrs <- [TransformT IO (FastString, [Rewrite Universe])]
-> TransformT IO [(FastString, [Rewrite Universe])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
      [ do
          Rewrite (Located (Pat GhcPs))
patRewrite <- Direction
-> AnnotatedImports
-> LRdrName
-> HsConDetails LRdrName [RecordPatSynField LRdrName]
-> Located (Pat GhcPs)
-> TransformT IO (Rewrite (Located (Pat GhcPs)))
mkPatRewrite Direction
dir AnnotatedImports
imports Located (IdP GhcPs)
LRdrName
nm HsPatSynDetails (Located (IdP GhcPs))
HsConDetails LRdrName [RecordPatSynField LRdrName]
params Located (Pat GhcPs)
lrhs
          [Rewrite (LHsExpr GhcPs)]
expRewrites <- Direction
-> AnnotatedImports
-> LRdrName
-> HsConDetails LRdrName [RecordPatSynField LRdrName]
-> LPat GhcPs
-> HsPatSynDir GhcPs
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
mkExpRewrite Direction
dir AnnotatedImports
imports Located (IdP GhcPs)
LRdrName
nm HsPatSynDetails (Located (IdP GhcPs))
HsConDetails LRdrName [RecordPatSynField LRdrName]
params LPat GhcPs
rhs HsPatSynDir GhcPs
patdir
          (FastString, [Rewrite Universe])
-> TransformT IO (FastString, [Rewrite Universe])
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString
rdr, Rewrite (Located (Pat GhcPs)) -> Rewrite Universe
forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite Rewrite (Located (Pat GhcPs))
patRewrite Rewrite Universe -> [Rewrite Universe] -> [Rewrite Universe]
forall a. a -> [a] -> [a]
: (Rewrite (LHsExpr GhcPs) -> Rewrite Universe)
-> [Rewrite (LHsExpr GhcPs)] -> [Rewrite Universe]
forall a b. (a -> b) -> [a] -> [b]
map Rewrite (LHsExpr GhcPs) -> Rewrite Universe
forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite [Rewrite (LHsExpr GhcPs)]
expRewrites)
      | L SrcSpan
_ (ValD XValD GhcPs
_ (PatSynBind XPatSynBind GhcPs GhcPs
_ (PSB XPSB GhcPs GhcPs
_ Located (IdP GhcPs)
nm HsPatSynDetails (Located (IdP GhcPs))
params LPat GhcPs
rhs HsPatSynDir GhcPs
patdir))) <- HsModule -> [GenLocated SrcSpan (HsDecl GhcPs)]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule
m
      , let rdr :: FastString
rdr = RdrName -> FastString
rdrFS (LRdrName -> SrcSpanLess LRdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcPs)
LRdrName
nm)
      , 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
rdr)
      , Just Located (Pat GhcPs)
lrhs <- [LPat GhcPs -> Maybe (Located (Pat GhcPs))
forall (p :: Pass).
LPat (GhcPass p) -> Maybe (Located (Pat (GhcPass p)))
dLPat LPat GhcPs
rhs]
      ]

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

mkPatRewrite
  :: Direction
  -> AnnotatedImports
  -> LRdrName
  -> HsConDetails LRdrName [RecordPatSynField LRdrName]
  -> Located (Pat GhcPs)
  -> TransformT IO (Rewrite (Located (Pat GhcPs)))
mkPatRewrite :: Direction
-> AnnotatedImports
-> LRdrName
-> HsConDetails LRdrName [RecordPatSynField LRdrName]
-> Located (Pat GhcPs)
-> TransformT IO (Rewrite (Located (Pat GhcPs)))
mkPatRewrite Direction
dir AnnotatedImports
imports LRdrName
patName HsConDetails LRdrName [RecordPatSynField LRdrName]
params Located (Pat GhcPs)
rhs = do
  Located (Pat GhcPs)
lhs <- LRdrName
-> HsConDetails LRdrName [RecordPatSynField LRdrName]
-> TransformT IO (Located (Pat GhcPs))
forall (m :: * -> *).
Monad m =>
LRdrName
-> HsConDetails LRdrName [RecordPatSynField LRdrName]
-> TransformT m (Located (Pat GhcPs))
asPat LRdrName
patName HsConDetails LRdrName [RecordPatSynField LRdrName]
params

  (Located (Pat GhcPs)
pat, Located (Pat GhcPs)
temp) <- case Direction
dir of
    Direction
LeftToRight -> (Located (Pat GhcPs), Located (Pat GhcPs))
-> TransformT IO (Located (Pat GhcPs), Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Pat GhcPs)
lhs, Located (Pat GhcPs)
rhs)
    Direction
RightToLeft -> do
      Located (Pat GhcPs) -> DeltaPos -> TransformT IO ()
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> DeltaPos -> TransformT m ()
setEntryDPT Located (Pat GhcPs)
lhs ((Int, Int) -> DeltaPos
DP (Int
0,Int
0))
      -- Patterns from lhs have wonky annotations,
      -- the space will be attached to the name, not to the ConPatIn ast node
      Located (Pat GhcPs) -> DeltaPos -> TransformT IO ()
forall (m :: * -> *).
Monad m =>
Located (Pat GhcPs) -> DeltaPos -> TransformT m ()
setEntryDPTunderConPatIn Located (Pat GhcPs)
lhs ((Int, Int) -> DeltaPos
DP (Int
0,Int
0))
      (Located (Pat GhcPs), Located (Pat GhcPs))
-> TransformT IO (Located (Pat GhcPs), Located (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (Pat GhcPs)
rhs, Located (Pat GhcPs)
lhs)

  Annotated (Located (Pat GhcPs))
p <- Located (Pat GhcPs)
-> TransformT IO (Annotated (Located (Pat GhcPs)))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA Located (Pat GhcPs)
pat
  Annotated (Located (Pat GhcPs))
t <- Located (Pat GhcPs)
-> TransformT IO (Annotated (Located (Pat GhcPs)))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA Located (Pat GhcPs)
temp
  let bs :: [IdP GhcPs]
bs = LPat GhcPs -> [IdP GhcPs]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders (Located (Pat GhcPs) -> LPat GhcPs
forall (p :: Pass). Located (Pat (GhcPass p)) -> LPat (GhcPass p)
cLPat Located (Pat GhcPs)
temp)
  Rewrite (Located (Pat GhcPs))
-> TransformT IO (Rewrite (Located (Pat GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Rewrite (Located (Pat GhcPs))
 -> TransformT IO (Rewrite (Located (Pat GhcPs))))
-> Rewrite (Located (Pat GhcPs))
-> TransformT IO (Rewrite (Located (Pat GhcPs)))
forall a b. (a -> b) -> a -> b
$ AnnotatedImports
-> Rewrite (Located (Pat GhcPs)) -> Rewrite (Located (Pat GhcPs))
forall ast. AnnotatedImports -> Rewrite ast -> Rewrite ast
addRewriteImports AnnotatedImports
imports (Rewrite (Located (Pat GhcPs)) -> Rewrite (Located (Pat GhcPs)))
-> Rewrite (Located (Pat GhcPs)) -> Rewrite (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ Quantifiers
-> Annotated (Located (Pat GhcPs))
-> Annotated (Located (Pat GhcPs))
-> Rewrite (Located (Pat GhcPs))
forall ast.
Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite ([RdrName] -> Quantifiers
mkQs [IdP GhcPs]
[RdrName]
bs) Annotated (Located (Pat GhcPs))
p Annotated (Located (Pat GhcPs))
t

  where
    setEntryDPTunderConPatIn
      :: Monad m => Located (Pat GhcPs) -> DeltaPos -> TransformT m ()
#if __GLASGOW_HASKELL__ < 900
    setEntryDPTunderConPatIn :: Located (Pat GhcPs) -> DeltaPos -> TransformT m ()
setEntryDPTunderConPatIn (L SrcSpan
_ (ConPatIn Located (IdP GhcPs)
nm HsConPatDetails GhcPs
_)) = LRdrName -> DeltaPos -> TransformT m ()
forall a (m :: * -> *).
(Data a, Monad m) =>
Located a -> DeltaPos -> TransformT m ()
setEntryDPT Located (IdP GhcPs)
LRdrName
nm
#else
    setEntryDPTunderConPatIn (L _ (ConPat _ nm _)) = setEntryDPT nm
#endif
    setEntryDPTunderConPatIn Located (Pat GhcPs)
_ = TransformT m () -> DeltaPos -> TransformT m ()
forall a b. a -> b -> a
const (TransformT m () -> DeltaPos -> TransformT m ())
-> TransformT m () -> DeltaPos -> TransformT m ()
forall a b. (a -> b) -> a -> b
$ () -> TransformT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

asPat
  :: Monad m
  => LRdrName
  -> HsConDetails LRdrName [RecordPatSynField LRdrName]
  -> TransformT m (Located (Pat GhcPs))
asPat :: LRdrName
-> HsConDetails LRdrName [RecordPatSynField LRdrName]
-> TransformT m (Located (Pat GhcPs))
asPat LRdrName
patName HsConDetails LRdrName [RecordPatSynField LRdrName]
params = do
  HsConDetails
  (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
params' <- (LRdrName -> TransformT m (Located (Pat GhcPs)))
-> ([RecordPatSynField LRdrName]
    -> TransformT m (HsRecFields GhcPs (Located (Pat GhcPs))))
-> HsConDetails LRdrName [RecordPatSynField LRdrName]
-> TransformT
     m
     (HsConDetails
        (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs))))
forall (m :: * -> *) arg arg' rec rec'.
Applicative m =>
(arg -> m arg')
-> (rec -> m rec')
-> HsConDetails arg rec
-> m (HsConDetails arg' rec')
bitraverseHsConDetails LRdrName -> TransformT m (Located (Pat GhcPs))
forall (m :: * -> *).
Monad m =>
LRdrName -> TransformT m (LPat GhcPs)
mkVarPat [RecordPatSynField LRdrName]
-> TransformT m (HsRecFields GhcPs (Located (Pat GhcPs)))
forall (m :: * -> *).
Monad m =>
[RecordPatSynField LRdrName]
-> TransformT m (HsRecFields GhcPs (Located (Pat GhcPs)))
convertFields HsConDetails LRdrName [RecordPatSynField LRdrName]
params
  LRdrName
-> HsConPatDetails GhcPs -> TransformT m (Located (Pat GhcPs))
forall (m :: * -> *).
Monad m =>
LRdrName
-> HsConPatDetails GhcPs -> TransformT m (Located (Pat GhcPs))
mkConPatIn LRdrName
patName HsConPatDetails GhcPs
HsConDetails
  (Located (Pat GhcPs)) (HsRecFields GhcPs (Located (Pat GhcPs)))
params'
  where

    convertFields :: [RecordPatSynField LRdrName]
-> TransformT m (HsRecFields GhcPs (Located (Pat GhcPs)))
convertFields [RecordPatSynField LRdrName]
fields =
      [LHsRecField GhcPs (Located (Pat GhcPs))]
-> Maybe (Located Int) -> HsRecFields GhcPs (Located (Pat GhcPs))
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields ([LHsRecField GhcPs (Located (Pat GhcPs))]
 -> Maybe (Located Int) -> HsRecFields GhcPs (Located (Pat GhcPs)))
-> TransformT m [LHsRecField GhcPs (Located (Pat GhcPs))]
-> TransformT
     m (Maybe (Located Int) -> HsRecFields GhcPs (Located (Pat GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordPatSynField LRdrName
 -> TransformT m (LHsRecField GhcPs (Located (Pat GhcPs))))
-> [RecordPatSynField LRdrName]
-> TransformT m [LHsRecField GhcPs (Located (Pat GhcPs))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RecordPatSynField LRdrName
-> TransformT m (LHsRecField GhcPs (Located (Pat GhcPs)))
forall (m :: * -> *).
Monad m =>
RecordPatSynField LRdrName
-> TransformT m (LHsRecField GhcPs (Located (Pat GhcPs)))
convertField [RecordPatSynField LRdrName]
fields TransformT
  m (Maybe (Located Int) -> HsRecFields GhcPs (Located (Pat GhcPs)))
-> TransformT m (Maybe (Located Int))
-> TransformT m (HsRecFields GhcPs (Located (Pat GhcPs)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Located Int) -> TransformT m (Maybe (Located Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Located Int)
forall a. Maybe a
Nothing

    convertField :: RecordPatSynField LRdrName
-> TransformT m (LHsRecField GhcPs (Located (Pat GhcPs)))
convertField RecordPatSynField{LRdrName
recordPatSynSelectorId :: forall a. RecordPatSynField a -> a
recordPatSynPatVar :: forall a. RecordPatSynField a -> a
recordPatSynPatVar :: LRdrName
recordPatSynSelectorId :: LRdrName
..} = do
      Located (FieldOcc GhcPs)
hsRecFieldLbl <- FieldOcc GhcPs -> TransformT m (Located (FieldOcc GhcPs))
forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc (FieldOcc GhcPs -> TransformT m (Located (FieldOcc GhcPs)))
-> FieldOcc GhcPs -> TransformT m (Located (FieldOcc GhcPs))
forall a b. (a -> b) -> a -> b
$ LRdrName -> FieldOcc GhcPs
mkFieldOcc LRdrName
recordPatSynSelectorId
      Located (Pat GhcPs)
hsRecFieldArg <- LRdrName -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
LRdrName -> TransformT m (LPat GhcPs)
mkVarPat LRdrName
recordPatSynPatVar
      let hsRecPun :: Bool
hsRecPun = Bool
False
      HsRecField' (FieldOcc GhcPs) (Located (Pat GhcPs))
-> TransformT m (LHsRecField GhcPs (Located (Pat GhcPs)))
forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc HsRecField :: forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField{Bool
Located (FieldOcc GhcPs)
Located (Pat GhcPs)
hsRecFieldLbl :: Located (FieldOcc GhcPs)
hsRecFieldArg :: Located (Pat GhcPs)
hsRecPun :: Bool
hsRecPun :: Bool
hsRecFieldArg :: Located (Pat GhcPs)
hsRecFieldLbl :: Located (FieldOcc GhcPs)
..}


mkExpRewrite
  :: Direction
  -> AnnotatedImports
  -> LRdrName
  -> HsConDetails LRdrName [RecordPatSynField LRdrName]
  -> LPat GhcPs
  -> HsPatSynDir GhcPs
  -> TransformT IO [Rewrite (LHsExpr GhcPs)]
mkExpRewrite :: Direction
-> AnnotatedImports
-> LRdrName
-> HsConDetails LRdrName [RecordPatSynField LRdrName]
-> LPat GhcPs
-> HsPatSynDir GhcPs
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
mkExpRewrite Direction
dir AnnotatedImports
imports LRdrName
patName HsConDetails LRdrName [RecordPatSynField LRdrName]
params LPat GhcPs
rhs HsPatSynDir GhcPs
patDir = do
  LHsExpr GhcPs
fe <- LRdrName -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
LRdrName -> TransformT m (LHsExpr GhcPs)
mkLocatedHsVar LRdrName
patName
  let altsFromParams :: TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
altsFromParams = case HsConDetails LRdrName [RecordPatSynField LRdrName]
params of
        PrefixCon [LRdrName]
names -> [Located (IdP GhcPs)]
-> LPat GhcPs -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall (m :: * -> *).
Monad m =>
[Located (IdP GhcPs)]
-> LPat GhcPs -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
buildMatch [Located (IdP GhcPs)]
[LRdrName]
names LPat GhcPs
rhs
        InfixCon LRdrName
a1 LRdrName
a2 -> [Located (IdP GhcPs)]
-> LPat GhcPs -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall (m :: * -> *).
Monad m =>
[Located (IdP GhcPs)]
-> LPat GhcPs -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
buildMatch [Located (IdP GhcPs)
LRdrName
a1, Located (IdP GhcPs)
LRdrName
a2] LPat GhcPs
rhs
        RecCon{} -> String -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall a. String -> a
missingSyntax String
"RecCon"
  [LMatch GhcPs (LHsExpr GhcPs)]
alts <- case HsPatSynDir GhcPs
patDir of
    ExplicitBidirectional MG{Located [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts :: Located [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts} -> [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LMatch GhcPs (LHsExpr GhcPs)]
 -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)])
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ Located [LMatch GhcPs (LHsExpr GhcPs)]
-> SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts
    HsPatSynDir GhcPs
ImplicitBidirectional -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
altsFromParams
    HsPatSynDir GhcPs
_ -> [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  ([[Rewrite (LHsExpr GhcPs)]] -> [Rewrite (LHsExpr GhcPs)])
-> TransformT IO [[Rewrite (LHsExpr GhcPs)]]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Rewrite (LHsExpr GhcPs)]] -> [Rewrite (LHsExpr GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (TransformT IO [[Rewrite (LHsExpr GhcPs)]]
 -> TransformT IO [Rewrite (LHsExpr GhcPs)])
-> TransformT IO [[Rewrite (LHsExpr GhcPs)]]
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> 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 [LMatch GhcPs (LHsExpr GhcPs)]
alts ((LMatch GhcPs (LHsExpr GhcPs)
  -> TransformT IO [Rewrite (LHsExpr GhcPs)])
 -> TransformT IO [[Rewrite (LHsExpr GhcPs)]])
-> (LMatch GhcPs (LHsExpr GhcPs)
    -> TransformT IO [Rewrite (LHsExpr GhcPs)])
-> TransformT IO [[Rewrite (LHsExpr GhcPs)]]
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
-> AnnotatedImports
-> Direction
-> LMatch GhcPs (LHsExpr GhcPs)
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
matchToRewrites LHsExpr GhcPs
fe AnnotatedImports
imports Direction
dir

buildMatch
  :: Monad m
  => [Located (IdP GhcPs)]
  -> LPat GhcPs
  -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
buildMatch :: [Located (IdP GhcPs)]
-> LPat GhcPs -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
buildMatch [Located (IdP GhcPs)]
names LPat GhcPs
rhs = do
  [Located (Pat GhcPs)]
pats <- (LRdrName -> TransformT m (Located (Pat GhcPs)))
-> [LRdrName] -> TransformT m [Located (Pat GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LRdrName -> TransformT m (Located (Pat GhcPs))
forall (m :: * -> *).
Monad m =>
LRdrName -> TransformT m (LPat GhcPs)
mkVarPat [Located (IdP GhcPs)]
[LRdrName]
names
  let bs :: [IdP GhcPs]
bs = LPat GhcPs -> [IdP GhcPs]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcPs
rhs
  (LHsExpr GhcPs
rhsExpr,([RdrName]
_,[RdrName]
_bs')) <- StateT ([RdrName], [RdrName]) (TransformT m) (LHsExpr GhcPs)
-> ([RdrName], [RdrName])
-> TransformT m (LHsExpr GhcPs, ([RdrName], [RdrName]))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (LPat GhcPs
-> StateT ([RdrName], [RdrName]) (TransformT m) (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
LPat GhcPs -> PatQ m (LHsExpr GhcPs)
patToExpr LPat GhcPs
rhs) ([RdrName] -> [RdrName]
wildSupply [IdP GhcPs]
[RdrName]
bs, [IdP GhcPs]
[RdrName]
bs)
  let alt :: LMatch GhcPs (LHsExpr GhcPs)
alt = HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Located (HsLocalBinds GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch HsMatchContext (NameOrRdrName (IdP GhcPs))
forall id. HsMatchContext id
PatSyn [LPat GhcPs]
[Located (Pat GhcPs)]
pats LHsExpr GhcPs
rhsExpr (SrcSpanLess (Located (HsLocalBinds GhcPs))
-> Located (HsLocalBinds GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located (HsLocalBinds GhcPs))
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
  [LMatch GhcPs (LHsExpr GhcPs)]
-> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
forall (m :: * -> *) a. Monad m => a -> m a
return [LMatch GhcPs (LHsExpr GhcPs)
alt]