-- 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), lift)
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import Data.Void

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
  :: LibDir
  -> [(FastString, Direction)]
  -> AnnotatedModule
  -> IO (UniqFM FastString [Rewrite Universe])
patternSynonymsToRewrites :: LibDir
-> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite Universe])
patternSynonymsToRewrites LibDir
libdir [(FastString, Direction)]
specs AnnotatedModule
am = (Annotated (UniqFM FastString [Rewrite Universe])
 -> UniqFM FastString [Rewrite Universe])
-> IO (Annotated (UniqFM FastString [Rewrite Universe]))
-> IO (UniqFM FastString [Rewrite Universe])
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 Universe])
-> UniqFM FastString [Rewrite Universe]
forall ast. Annotated ast -> ast
astA (IO (Annotated (UniqFM FastString [Rewrite Universe]))
 -> IO (UniqFM FastString [Rewrite Universe]))
-> IO (Annotated (UniqFM FastString [Rewrite Universe]))
-> IO (UniqFM FastString [Rewrite Universe])
forall a b. (a -> b) -> a -> b
$ AnnotatedModule
-> (Located (HsModule GhcPs)
    -> TransformT IO (UniqFM FastString [Rewrite Universe]))
-> IO (Annotated (UniqFM FastString [Rewrite Universe]))
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 Universe]))
 -> IO (Annotated (UniqFM FastString [Rewrite Universe])))
-> (Located (HsModule GhcPs)
    -> TransformT IO (UniqFM FastString [Rewrite Universe]))
-> IO (Annotated (UniqFM FastString [Rewrite Universe]))
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
  Annotated [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
imports <- LibDir
-> Direction
-> Maybe (LocatedA ModuleName)
-> TransformT IO AnnotatedImports
getImports LibDir
libdir Direction
RightToLeft (HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ do
          Rewrite (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
patRewrite <- Direction
-> AnnotatedImports
-> LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> LPat GhcPs
-> TransformT IO (Rewrite (LPat GhcPs))
mkPatRewrite Direction
dir AnnotatedImports
Annotated [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
imports LIdP GhcPs
LocatedN RdrName
nm HsPatSynDetails GhcPs
HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params LPat GhcPs
GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
lrhs
          [Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]
expRewrites <- Direction
-> AnnotatedImports
-> LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> LPat GhcPs
-> HsPatSynDir GhcPs
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
mkExpRewrite Direction
dir AnnotatedImports
Annotated [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
imports LIdP GhcPs
LocatedN RdrName
nm HsPatSynDetails GhcPs
HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params LPat GhcPs
rhs HsPatSynDir GhcPs
patdir
          (FastString, [Rewrite Universe])
-> TransformT IO (FastString, [Rewrite Universe])
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString
rdr, Rewrite (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
-> Rewrite Universe
forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite Rewrite (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
patRewrite Rewrite Universe -> [Rewrite Universe] -> [Rewrite Universe]
forall a. a -> [a] -> [a]
: (Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))
 -> Rewrite Universe)
-> [Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]
-> [Rewrite Universe]
forall a b. (a -> b) -> [a] -> [b]
map Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))
-> Rewrite Universe
forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite [Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]
expRewrites)
      | L SrcAnn AnnListItem
_ (ValD XValD GhcPs
_ (PatSynBind XPatSynBind GhcPs GhcPs
_ (PSB XPSB GhcPs GhcPs
_ LIdP GhcPs
nm HsPatSynDetails GhcPs
params LPat GhcPs
rhs HsPatSynDir GhcPs
patdir))) <- HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
m
      , let rdr :: FastString
rdr = RdrName -> FastString
rdrFS (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
LocatedN RdrName
nm)
      , 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
rdr)
      , Just GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
lrhs <- [LPat GhcPs -> Maybe (LPat GhcPs)
forall (p :: Pass). LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat LPat GhcPs
rhs]
      ]

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

mkPatRewrite
  :: Direction
  -> AnnotatedImports
  -> LocatedN RdrName
  -> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
  -> LPat GhcPs
  -> TransformT IO (Rewrite (LPat GhcPs))
mkPatRewrite :: Direction
-> AnnotatedImports
-> LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> LPat GhcPs
-> TransformT IO (Rewrite (LPat GhcPs))
mkPatRewrite Direction
dir AnnotatedImports
imports LocatedN RdrName
patName HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params LPat GhcPs
rhs = do
  GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
lhs <- LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> TransformT IO (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> TransformT m (LPat GhcPs)
asPat LocatedN RdrName
patName HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params

  (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
pat, GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
temp) <- case Direction
dir of
    Direction
LeftToRight -> (GenLocated (SrcAnn AnnListItem) (Pat GhcPs),
 GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
-> TransformT
     IO
     (GenLocated (SrcAnn AnnListItem) (Pat GhcPs),
      GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
lhs, LPat GhcPs
GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
rhs)
    Direction
RightToLeft -> do
      let lhs' :: GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
lhs' = GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
-> DeltaPos -> GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
lhs (Int -> DeltaPos
SameLine Int
0)
      -- Patterns from lhs have wonky annotations,
      -- the space will be attached to the name, not to the ConPatIn ast node
      let lhs'' :: LPat GhcPs
lhs'' = LPat GhcPs -> DeltaPos -> LPat GhcPs
setEntryDPTunderConPatIn LPat GhcPs
GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
lhs' (Int -> DeltaPos
SameLine Int
0)
      (GenLocated (SrcAnn AnnListItem) (Pat GhcPs),
 GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
-> TransformT
     IO
     (GenLocated (SrcAnn AnnListItem) (Pat GhcPs),
      GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs
GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
rhs, LPat GhcPs
GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
lhs'')

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

  where
    setEntryDPTunderConPatIn :: LPat GhcPs -> DeltaPos -> LPat GhcPs
    setEntryDPTunderConPatIn :: LPat GhcPs -> DeltaPos -> LPat GhcPs
setEntryDPTunderConPatIn (L SrcAnn AnnListItem
l (ConPat XConPat GhcPs
x XRec GhcPs (ConLikeP GhcPs)
nm HsConPatDetails GhcPs
args)) DeltaPos
dp
      = (SrcAnn AnnListItem
-> Pat GhcPs -> GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcAnn AnnListItem
l (XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConPatDetails GhcPs
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
x (LocatedN RdrName -> DeltaPos -> LocatedN RdrName
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
nm DeltaPos
dp) HsConPatDetails GhcPs
args))
    setEntryDPTunderConPatIn LPat GhcPs
p DeltaPos
_ = LPat GhcPs
p

asPat
  :: Monad m
  => LocatedN RdrName
  -> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
  -> TransformT m (LPat GhcPs)
asPat :: forall (m :: * -> *).
Monad m =>
LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> TransformT m (LPat GhcPs)
asPat LocatedN RdrName
patName HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params = do
  HsConDetails
  (HsConPatTyArg GhcPs)
  (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
  (HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
params' <- ([Void] -> TransformT m [HsConPatTyArg GhcPs])
-> (LocatedN RdrName
    -> TransformT m (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
-> ([RecordPatSynField GhcPs]
    -> TransformT
         m
         (HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))))
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> TransformT
     m
     (HsConDetails
        (HsConPatTyArg GhcPs)
        (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
        (HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))))
forall (m :: * -> *) tyarg tyarg' arg arg' rec rec'.
Applicative m =>
([tyarg] -> m [tyarg'])
-> (arg -> m arg')
-> (rec -> m rec')
-> HsConDetails tyarg arg rec
-> m (HsConDetails tyarg' arg' rec')
bitraverseHsConDetails [Void] -> TransformT m [HsConPatTyArg GhcPs]
forall (m :: * -> *).
Monad m =>
[Void] -> TransformT m [HsConPatTyArg GhcPs]
convertTyVars LocatedN RdrName -> TransformT m (LPat GhcPs)
LocatedN RdrName
-> TransformT m (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LPat GhcPs)
mkVarPat [RecordPatSynField GhcPs]
-> TransformT m (HsRecFields GhcPs (LPat GhcPs))
[RecordPatSynField GhcPs]
-> TransformT
     m (HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
forall (m :: * -> *).
Monad m =>
[RecordPatSynField GhcPs]
-> TransformT m (HsRecFields GhcPs (LPat GhcPs))
convertFields HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params
  LocatedN RdrName
-> HsConPatDetails GhcPs -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
LocatedN RdrName
-> HsConPatDetails GhcPs -> TransformT m (LPat GhcPs)
mkConPatIn LocatedN RdrName
patName HsConPatDetails GhcPs
HsConDetails
  (HsConPatTyArg GhcPs)
  (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
  (HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
params'
  where

#if __GLASGOW_HASKELL__ <= 904
    convertTyVars :: (Monad m) => [Void] -> TransformT m [HsPatSigType GhcPs]
#else
    convertTyVars :: (Monad m) => [Void] -> TransformT m [HsConPatTyArg GhcPs]
#endif
    convertTyVars :: forall (m :: * -> *).
Monad m =>
[Void] -> TransformT m [HsConPatTyArg GhcPs]
convertTyVars [Void]
_ = [HsConPatTyArg GhcPs] -> TransformT m [HsConPatTyArg GhcPs]
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return []

    convertFields :: (Monad m) => [RecordPatSynField GhcPs]
                      -> TransformT m (HsRecFields GhcPs (LPat GhcPs))
    convertFields :: forall (m :: * -> *).
Monad m =>
[RecordPatSynField GhcPs]
-> TransformT m (HsRecFields GhcPs (LPat GhcPs))
convertFields [RecordPatSynField GhcPs]
fields =
      [LHsRecField GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))]
-> Maybe (XRec GhcPs RecFieldsDotDot)
-> HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
[GenLocated
   (SrcAnn AnnListItem)
   (HsFieldBind
      (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
      (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))]
-> Maybe (GenLocated SrcSpan RecFieldsDotDot)
-> HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields ([GenLocated
    (SrcAnn AnnListItem)
    (HsFieldBind
       (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
       (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))]
 -> Maybe (GenLocated SrcSpan RecFieldsDotDot)
 -> HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
-> TransformT
     m
     [GenLocated
        (SrcAnn AnnListItem)
        (HsFieldBind
           (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
           (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))]
-> TransformT
     m
     (Maybe (GenLocated SrcSpan RecFieldsDotDot)
      -> HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordPatSynField GhcPs
 -> TransformT
      m
      (GenLocated
         (SrcAnn AnnListItem)
         (HsFieldBind
            (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
            (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))))
-> [RecordPatSynField GhcPs]
-> TransformT
     m
     [GenLocated
        (SrcAnn AnnListItem)
        (HsFieldBind
           (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
           (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse RecordPatSynField GhcPs
-> TransformT m (LHsRecField GhcPs (LPat GhcPs))
RecordPatSynField GhcPs
-> TransformT
     m
     (GenLocated
        (SrcAnn AnnListItem)
        (HsFieldBind
           (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
           (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))))
forall (m :: * -> *).
Monad m =>
RecordPatSynField GhcPs
-> TransformT m (LHsRecField GhcPs (LPat GhcPs))
convertField [RecordPatSynField GhcPs]
fields TransformT
  m
  (Maybe (GenLocated SrcSpan RecFieldsDotDot)
   -> HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
-> TransformT m (Maybe (GenLocated SrcSpan RecFieldsDotDot))
-> TransformT
     m (HsRecFields GhcPs (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
forall a b.
TransformT m (a -> b) -> TransformT m a -> TransformT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (GenLocated SrcSpan RecFieldsDotDot)
-> TransformT m (Maybe (GenLocated SrcSpan RecFieldsDotDot))
forall a. a -> TransformT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (GenLocated SrcSpan RecFieldsDotDot)
forall a. Maybe a
Nothing

    convertField :: (Monad m) => RecordPatSynField GhcPs
                      -> TransformT m (LHsRecField GhcPs (LPat GhcPs))
    convertField :: forall (m :: * -> *).
Monad m =>
RecordPatSynField GhcPs
-> TransformT m (LHsRecField GhcPs (LPat GhcPs))
convertField RecordPatSynField{LIdP GhcPs
FieldOcc GhcPs
recordPatSynField :: FieldOcc GhcPs
recordPatSynPatVar :: LIdP GhcPs
recordPatSynField :: forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynPatVar :: forall pass. RecordPatSynField pass -> LIdP pass
..} = do
#if __GLASGOW_HASKELL__ < 904
      hsRecFieldLbl <- mkLoc $ recordPatSynField
      hsRecFieldArg <- mkVarPat recordPatSynPatVar
      let hsRecPun = False
      let hsRecFieldAnn = noAnn
      mkLocA (SameLine 0) HsRecField{..}
#else
      SrcSpan
s <- TransformT m SrcSpan
forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT
      EpAnn NoEpAnns
an <- DeltaPos -> NoEpAnns -> TransformT m (EpAnn NoEpAnns)
forall (m :: * -> *) an.
Monad m =>
DeltaPos -> an -> TransformT m (EpAnn an)
mkEpAnn (Int -> DeltaPos
SameLine Int
0) NoEpAnns
NoEpAnns
      let srcspan :: SrcSpanAnn' (EpAnn NoEpAnns)
srcspan = EpAnn NoEpAnns -> SrcSpan -> SrcSpanAnn' (EpAnn NoEpAnns)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn NoEpAnns
an SrcSpan
s
          hfbLHS :: GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
hfbLHS = SrcSpanAnn' (EpAnn NoEpAnns)
-> FieldOcc GhcPs
-> GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NoEpAnns)
srcspan FieldOcc GhcPs
recordPatSynField
      GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
hfbRHS <- LocatedN RdrName -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LPat GhcPs)
mkVarPat LIdP GhcPs
LocatedN RdrName
recordPatSynPatVar
      let hfbPun :: Bool
hfbPun = Bool
False
          hfbAnn :: EpAnn a
hfbAnn = EpAnn a
forall a. EpAnn a
noAnn
      DeltaPos
-> HsFieldBind
     (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
     (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
-> TransformT
     m
     (GenLocated
        (SrcAnn AnnListItem)
        (HsFieldBind
           (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
           (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))))
forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
0) HsFieldBind{Bool
XHsFieldBind
  (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
EpAnn [AddEpAnn]
forall a. EpAnn a
hfbLHS :: GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
hfbRHS :: GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
hfbPun :: Bool
hfbAnn :: forall a. EpAnn a
hfbAnn :: XHsFieldBind
  (GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs))
hfbLHS :: GenLocated (SrcSpanAnn' (EpAnn NoEpAnns)) (FieldOcc GhcPs)
hfbRHS :: GenLocated (SrcAnn AnnListItem) (Pat GhcPs)
hfbPun :: Bool
..}
#endif

mkExpRewrite
  :: Direction
  -> AnnotatedImports
  -> LocatedN RdrName
  -> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
  -> LPat GhcPs
  -> HsPatSynDir GhcPs
  -> TransformT IO [Rewrite (LHsExpr GhcPs)]
mkExpRewrite :: Direction
-> AnnotatedImports
-> LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> LPat GhcPs
-> HsPatSynDir GhcPs
-> TransformT IO [Rewrite (LHsExpr GhcPs)]
mkExpRewrite Direction
dir AnnotatedImports
imports LocatedN RdrName
patName HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params LPat GhcPs
rhs HsPatSynDir GhcPs
patDir = do
  GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)
fe <- LocatedN RdrName -> TransformT IO (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsExpr GhcPs)
mkLocatedHsVar LocatedN RdrName
patName
  -- lift $ debugPrint Loud "mkExpRewrite:fe="  [showAst fe]
  let altsFromParams :: TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
altsFromParams = case HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params of
        PrefixCon [Void]
_tyargs [LocatedN RdrName]
names -> [LocatedN RdrName]
-> LPat GhcPs -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall (m :: * -> *).
MonadIO m =>
[LocatedN RdrName]
-> LPat GhcPs -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
buildMatch [LocatedN RdrName]
names LPat GhcPs
rhs
        InfixCon LocatedN RdrName
a1 LocatedN RdrName
a2 -> [LocatedN RdrName]
-> LPat GhcPs -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall (m :: * -> *).
MonadIO m =>
[LocatedN RdrName]
-> LPat GhcPs -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
buildMatch [LocatedN RdrName
a1, LocatedN RdrName
a2] LPat GhcPs
rhs
        RecCon{} -> LibDir
-> TransformT
     IO
     [GenLocated
        (SrcAnn AnnListItem)
        (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
forall a. LibDir -> a
missingSyntax LibDir
"RecCon"
  [GenLocated
   (SrcAnn AnnListItem)
   (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
alts <- case HsPatSynDir GhcPs
patDir of
    ExplicitBidirectional MG{XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts :: XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts} -> [GenLocated
   (SrcAnn AnnListItem)
   (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
-> TransformT
     IO
     [GenLocated
        (SrcAnn AnnListItem)
        (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
forall a. a -> TransformT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated
    (SrcAnn AnnListItem)
    (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
 -> TransformT
      IO
      [GenLocated
         (SrcAnn AnnListItem)
         (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))])
-> [GenLocated
      (SrcAnn AnnListItem)
      (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
-> TransformT
     IO
     [GenLocated
        (SrcAnn AnnListItem)
        (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ GenLocated
  SrcSpanAnnL
  [GenLocated
     (SrcAnn AnnListItem)
     (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
-> [GenLocated
      (SrcAnn AnnListItem)
      (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
forall l e. GenLocated l e -> e
unLoc XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
GenLocated
  SrcSpanAnnL
  [GenLocated
     (SrcAnn AnnListItem)
     (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
mg_alts
    HsPatSynDir GhcPs
ImplicitBidirectional -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
TransformT
  IO
  [GenLocated
     (SrcAnn AnnListItem)
     (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
altsFromParams
    HsPatSynDir GhcPs
_ -> [GenLocated
   (SrcAnn AnnListItem)
   (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
-> TransformT
     IO
     [GenLocated
        (SrcAnn AnnListItem)
        (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
forall a. a -> TransformT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  ([[Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]]
 -> [Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))])
-> TransformT
     IO [[Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]]
-> TransformT
     IO [Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]
forall a b. (a -> b) -> TransformT IO a -> TransformT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]]
-> [Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (TransformT
   IO [[Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]]
 -> TransformT
      IO [Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))])
-> TransformT
     IO [[Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))]]
-> TransformT
     IO [Rewrite (GenLocated (SrcAnn AnnListItem) (HsExpr 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)]
[GenLocated
   (SrcAnn AnnListItem)
   (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr 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
GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)
fe AnnotatedImports
imports Direction
dir

buildMatch
  :: MonadIO m
  => [LocatedN RdrName]
  -> LPat GhcPs
  -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
buildMatch :: forall (m :: * -> *).
MonadIO m =>
[LocatedN RdrName]
-> LPat GhcPs -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
buildMatch [LocatedN RdrName]
names LPat GhcPs
rhs = do
  [GenLocated (SrcAnn AnnListItem) (Pat GhcPs)]
pats <- (LocatedN RdrName
 -> TransformT m (GenLocated (SrcAnn AnnListItem) (Pat GhcPs)))
-> [LocatedN RdrName]
-> TransformT m [GenLocated (SrcAnn AnnListItem) (Pat GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LocatedN RdrName -> TransformT m (LPat GhcPs)
LocatedN RdrName
-> TransformT m (GenLocated (SrcAnn AnnListItem) (Pat GhcPs))
forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LPat GhcPs)
mkVarPat [LocatedN RdrName]
names
  let bs :: [IdP GhcPs]
bs = CollectFlag GhcPs -> LPat GhcPs -> [IdP GhcPs]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcPs
forall p. CollectFlag p
CollNoDictBinders LPat GhcPs
rhs
  (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)
rhsExpr,([RdrName]
_,[RdrName]
_bs')) <- StateT
  ([RdrName], [RdrName])
  (TransformT m)
  (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))
-> ([RdrName], [RdrName])
-> TransformT
     m
     (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs),
      ([RdrName], [RdrName]))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (LPat GhcPs -> PatQ m (LHsExpr GhcPs)
forall (m :: * -> *).
MonadIO 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 GhcPs
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> HsLocalBinds GhcPs
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch HsMatchContext GhcPs
forall p. HsMatchContext p
PatSyn [LPat GhcPs]
[GenLocated (SrcAnn AnnListItem) (Pat GhcPs)]
pats LHsExpr GhcPs
GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)
rhsExpr HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
  [GenLocated
   (SrcAnn AnnListItem)
   (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
-> TransformT
     m
     [GenLocated
        (SrcAnn AnnListItem)
        (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))]
forall a. a -> TransformT m a
forall (m :: * -> *) a. Monad m => a -> m a
return [LMatch GhcPs (LHsExpr GhcPs)
GenLocated
  (SrcAnn AnnListItem)
  (Match GhcPs (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))
alt]