-- 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 (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
    -> 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
  -> TransformT IO (UniqFM FastString [Rewrite Universe]))
 -> IO (Annotated (UniqFM FastString [Rewrite Universe])))
-> (Located HsModule
    -> TransformT IO (UniqFM FastString [Rewrite Universe]))
-> IO (Annotated (UniqFM FastString [Rewrite Universe]))
forall a b. (a -> b) -> a -> b
$ \(L SrcSpan
_ HsModule
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 SrcSpanAnnA (ImportDecl GhcPs)]
imports <- LibDir
-> Direction
-> Maybe (LocatedA ModuleName)
-> TransformT IO AnnotatedImports
getImports LibDir
libdir Direction
RightToLeft (HsModule -> Maybe (LocatedA 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 (LocatedAn 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 SrcSpanAnnA (ImportDecl GhcPs)]
imports LIdP GhcPs
LocatedN RdrName
nm HsPatSynDetails GhcPs
HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
params LPat GhcPs
LocatedAn AnnListItem (Pat GhcPs)
lrhs
          [Rewrite (GenLocated SrcSpanAnnA (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 SrcSpanAnnA (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 (m :: * -> *) a. Monad m => a -> m a
return (FastString
rdr, Rewrite (LocatedAn AnnListItem (Pat GhcPs)) -> Rewrite Universe
forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite Rewrite (LocatedAn AnnListItem (Pat GhcPs))
patRewrite Rewrite Universe -> [Rewrite Universe] -> [Rewrite Universe]
forall a. a -> [a] -> [a]
: (Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Rewrite Universe)
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Rewrite Universe]
forall a b. (a -> b) -> [a] -> [b]
map Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Rewrite Universe
forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
expRewrites)
      | L SrcSpanAnnA
_ (ValD XValD GhcPs
_ (PatSynBind XPatSynBind GhcPs GhcPs
_ (PSB XPSB GhcPs GhcPs
_ LIdP GhcPs
nm HsPatSynDetails GhcPs
params LPat GhcPs
rhs HsPatSynDir GhcPs
patdir))) <- HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
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 LocatedAn 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 (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
  LocatedAn 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

  (LocatedAn AnnListItem (Pat GhcPs)
pat, LocatedAn AnnListItem (Pat GhcPs)
temp) <- case Direction
dir of
    Direction
LeftToRight -> (LocatedAn AnnListItem (Pat GhcPs),
 LocatedAn AnnListItem (Pat GhcPs))
-> TransformT
     IO
     (LocatedAn AnnListItem (Pat GhcPs),
      LocatedAn AnnListItem (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedAn AnnListItem (Pat GhcPs)
lhs, LPat GhcPs
LocatedAn AnnListItem (Pat GhcPs)
rhs)
    Direction
RightToLeft -> do
      let lhs' :: LocatedAn AnnListItem (Pat GhcPs)
lhs' = LocatedAn AnnListItem (Pat GhcPs)
-> DeltaPos -> LocatedAn AnnListItem (Pat GhcPs)
forall t a. Monoid t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LocatedAn 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
LocatedAn AnnListItem (Pat GhcPs)
lhs' (Int -> DeltaPos
SameLine Int
0)
      (LocatedAn AnnListItem (Pat GhcPs),
 LocatedAn AnnListItem (Pat GhcPs))
-> TransformT
     IO
     (LocatedAn AnnListItem (Pat GhcPs),
      LocatedAn AnnListItem (Pat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs
LocatedAn AnnListItem (Pat GhcPs)
rhs, LPat GhcPs
LocatedAn AnnListItem (Pat GhcPs)
lhs'')

  Annotated (LocatedAn AnnListItem (Pat GhcPs))
p <- LocatedAn AnnListItem (Pat GhcPs)
-> TransformT IO (Annotated (LocatedAn AnnListItem (Pat GhcPs)))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA LocatedAn AnnListItem (Pat GhcPs)
pat
  Annotated (LocatedAn AnnListItem (Pat GhcPs))
t <- LocatedAn AnnListItem (Pat GhcPs)
-> TransformT IO (Annotated (LocatedAn AnnListItem (Pat GhcPs)))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA LocatedAn 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
LocatedAn AnnListItem (Pat GhcPs)
temp)
  Rewrite (LocatedAn AnnListItem (Pat GhcPs))
-> TransformT IO (Rewrite (LocatedAn AnnListItem (Pat GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Rewrite (LocatedAn AnnListItem (Pat GhcPs))
 -> TransformT IO (Rewrite (LocatedAn AnnListItem (Pat GhcPs))))
-> Rewrite (LocatedAn AnnListItem (Pat GhcPs))
-> TransformT IO (Rewrite (LocatedAn AnnListItem (Pat GhcPs)))
forall a b. (a -> b) -> a -> b
$ AnnotatedImports
-> Rewrite (LocatedAn AnnListItem (Pat GhcPs))
-> Rewrite (LocatedAn AnnListItem (Pat GhcPs))
forall ast. AnnotatedImports -> Rewrite ast -> Rewrite ast
addRewriteImports AnnotatedImports
imports (Rewrite (LocatedAn AnnListItem (Pat GhcPs))
 -> Rewrite (LocatedAn AnnListItem (Pat GhcPs)))
-> Rewrite (LocatedAn AnnListItem (Pat GhcPs))
-> Rewrite (LocatedAn AnnListItem (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ Quantifiers
-> Annotated (LocatedAn AnnListItem (Pat GhcPs))
-> Annotated (LocatedAn AnnListItem (Pat GhcPs))
-> Rewrite (LocatedAn AnnListItem (Pat GhcPs))
forall ast.
Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite ([RdrName] -> Quantifiers
mkQs [RdrName]
[IdP GhcPs]
bs) Annotated (LocatedAn AnnListItem (Pat GhcPs))
p Annotated (LocatedAn AnnListItem (Pat GhcPs))
t

  where
    setEntryDPTunderConPatIn :: LPat GhcPs -> DeltaPos -> LPat GhcPs
    setEntryDPTunderConPatIn :: LPat GhcPs -> DeltaPos -> LPat GhcPs
setEntryDPTunderConPatIn (L SrcSpanAnnA
l (ConPat XConPat GhcPs
x XRec GhcPs (ConLikeP GhcPs)
nm HsConPatDetails GhcPs
args)) DeltaPos
dp
      = (SrcSpanAnnA -> Pat GhcPs -> LocatedAn AnnListItem (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
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. Monoid 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
  (HsPatSigType GhcPs)
  (LocatedAn AnnListItem (Pat GhcPs))
  (HsRecFields GhcPs (LocatedAn AnnListItem (Pat GhcPs)))
params' <- ([Void] -> TransformT m [HsPatSigType GhcPs])
-> (LocatedN RdrName
    -> TransformT m (LocatedAn AnnListItem (Pat GhcPs)))
-> ([RecordPatSynField GhcPs]
    -> TransformT
         m (HsRecFields GhcPs (LocatedAn AnnListItem (Pat GhcPs))))
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
-> TransformT
     m
     (HsConDetails
        (HsPatSigType GhcPs)
        (LocatedAn AnnListItem (Pat GhcPs))
        (HsRecFields GhcPs (LocatedAn 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 [HsPatSigType GhcPs]
forall (m :: * -> *).
Monad m =>
[Void] -> TransformT m [HsPatSigType GhcPs]
convertTyVars LocatedN RdrName
-> TransformT m (LocatedAn AnnListItem (Pat GhcPs))
forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LPat GhcPs)
mkVarPat [RecordPatSynField GhcPs]
-> TransformT
     m (HsRecFields GhcPs (LocatedAn 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 HsConDetails
  (HsPatSigType GhcPs)
  (LocatedAn AnnListItem (Pat GhcPs))
  (HsRecFields GhcPs (LocatedAn AnnListItem (Pat GhcPs)))
HsConPatDetails GhcPs
params'
  where

    convertTyVars :: (Monad m) => [Void] -> TransformT m [HsPatSigType GhcPs]
    convertTyVars :: forall (m :: * -> *).
Monad m =>
[Void] -> TransformT m [HsPatSigType GhcPs]
convertTyVars [Void]
_ = [HsPatSigType GhcPs] -> TransformT m [HsPatSigType GhcPs]
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 =
      [GenLocated
   SrcSpanAnnA
   (HsRecField' (FieldOcc GhcPs) (LocatedAn AnnListItem (Pat GhcPs)))]
-> Maybe (Located Int)
-> HsRecFields GhcPs (LocatedAn AnnListItem (Pat GhcPs))
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields ([GenLocated
    SrcSpanAnnA
    (HsRecField' (FieldOcc GhcPs) (LocatedAn AnnListItem (Pat GhcPs)))]
 -> Maybe (Located Int)
 -> HsRecFields GhcPs (LocatedAn AnnListItem (Pat GhcPs)))
-> TransformT
     m
     [GenLocated
        SrcSpanAnnA
        (HsRecField' (FieldOcc GhcPs) (LocatedAn AnnListItem (Pat GhcPs)))]
-> TransformT
     m
     (Maybe (Located Int)
      -> HsRecFields GhcPs (LocatedAn AnnListItem (Pat GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordPatSynField GhcPs
 -> TransformT
      m
      (GenLocated
         SrcSpanAnnA
         (HsRecField'
            (FieldOcc GhcPs) (LocatedAn AnnListItem (Pat GhcPs)))))
-> [RecordPatSynField GhcPs]
-> TransformT
     m
     [GenLocated
        SrcSpanAnnA
        (HsRecField' (FieldOcc GhcPs) (LocatedAn AnnListItem (Pat GhcPs)))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RecordPatSynField GhcPs
-> TransformT
     m
     (GenLocated
        SrcSpanAnnA
        (HsRecField' (FieldOcc GhcPs) (LocatedAn AnnListItem (Pat GhcPs))))
forall (m :: * -> *).
Monad m =>
RecordPatSynField GhcPs
-> TransformT m (LHsRecField GhcPs (LPat GhcPs))
convertField [RecordPatSynField GhcPs]
fields TransformT
  m
  (Maybe (Located Int)
   -> HsRecFields GhcPs (LocatedAn AnnListItem (Pat GhcPs)))
-> TransformT m (Maybe (Located Int))
-> TransformT
     m (HsRecFields GhcPs (LocatedAn AnnListItem (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 :: (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{FieldOcc GhcPs
LIdP GhcPs
recordPatSynField :: forall pass. RecordPatSynField pass -> FieldOcc pass
recordPatSynPatVar :: forall pass. RecordPatSynField pass -> LIdP pass
recordPatSynPatVar :: LIdP GhcPs
recordPatSynField :: FieldOcc GhcPs
..} = 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
$ FieldOcc GhcPs
recordPatSynField
      LocatedAn AnnListItem (Pat GhcPs)
hsRecFieldArg <- LocatedN RdrName -> TransformT m (LPat GhcPs)
forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LPat GhcPs)
mkVarPat LIdP GhcPs
LocatedN RdrName
recordPatSynPatVar
      let hsRecPun :: Bool
hsRecPun = Bool
False
      let hsRecFieldAnn :: EpAnn a
hsRecFieldAnn = EpAnn a
forall a. EpAnn a
noAnn
      DeltaPos
-> HsRecField' (FieldOcc GhcPs) (LocatedAn AnnListItem (Pat GhcPs))
-> TransformT
     m
     (GenLocated
        SrcSpanAnnA
        (HsRecField' (FieldOcc GhcPs) (LocatedAn 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) HsRecField{Bool
XHsRecField (FieldOcc GhcPs)
LocatedAn AnnListItem (Pat GhcPs)
Located (FieldOcc GhcPs)
forall a. EpAnn a
hsRecFieldAnn :: XHsRecField (FieldOcc GhcPs)
hsRecFieldArg :: LocatedAn AnnListItem (Pat GhcPs)
hsRecFieldLbl :: Located (FieldOcc GhcPs)
hsRecPun :: Bool
hsRecFieldAnn :: forall a. EpAnn a
hsRecPun :: Bool
hsRecFieldArg :: LocatedAn AnnListItem (Pat GhcPs)
hsRecFieldLbl :: Located (FieldOcc GhcPs)
..}


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 SrcSpanAnnA (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
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. LibDir -> a
missingSyntax LibDir
"RecCon"
  [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts <- case HsPatSynDir GhcPs
patDir of
    ExplicitBidirectional MG{XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts :: XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts} -> [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> TransformT
     IO
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated
    SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> TransformT
      IO
      [GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> TransformT
     IO
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. GenLocated l e -> e
unLoc XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
mg_alts
    HsPatSynDir GhcPs
ImplicitBidirectional -> TransformT IO [LMatch GhcPs (LHsExpr GhcPs)]
TransformT
  IO
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
altsFromParams
    HsPatSynDir GhcPs
_ -> [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> TransformT
     IO
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  ([[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
 -> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> TransformT
     IO [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
-> TransformT IO [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
-> [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (TransformT IO [[Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]]
 -> TransformT IO [Rewrite (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
$ [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
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (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 SrcSpanAnnA (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
  [LocatedAn AnnListItem (Pat GhcPs)]
pats <- (LocatedN RdrName
 -> TransformT m (LocatedAn AnnListItem (Pat GhcPs)))
-> [LocatedN RdrName]
-> TransformT m [LocatedAn AnnListItem (Pat GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LocatedN RdrName
-> TransformT m (LocatedAn 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 SrcSpanAnnA (HsExpr GhcPs)
rhsExpr,([RdrName]
_,[RdrName]
_bs')) <- StateT
  ([RdrName], [RdrName])
  (TransformT m)
  (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ([RdrName], [RdrName])
-> TransformT
     m (GenLocated SrcSpanAnnA (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 [RdrName]
[IdP GhcPs]
bs, [RdrName]
[IdP GhcPs]
bs)
  let alt :: LMatch GhcPs (LHsExpr GhcPs)
alt = HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> HsLocalBinds GhcPs
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch HsMatchContext (NoGhcTc GhcPs)
forall p. HsMatchContext p
PatSyn [LPat GhcPs]
[LocatedAn AnnListItem (Pat GhcPs)]
pats LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhsExpr HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
  [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> TransformT
     m
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (m :: * -> *) a. Monad m => a -> m a
return [LMatch GhcPs (LHsExpr GhcPs)
GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
alt]