{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE ViewPatterns        #-}

module Ide.Plugin.Tactic.GHC where

import           Control.Monad.State
import           Data.Function (on)
import           Data.List (isPrefixOf)
import qualified Data.Map as M
import           Data.Maybe (isJust)
import           Data.Set (Set)
import qualified Data.Set as S
import           Data.Traversable
import           DataCon
import           Development.IDE.GHC.Compat
import           GHC.SourceGen (match, case', lambda)
import           Generics.SYB (mkQ, everything, listify, Data, mkT, everywhere)
import           Ide.Plugin.Tactic.Types
import           OccName
import           TcType
import           TyCoRep
import           Type
import           TysWiredIn (intTyCon, floatTyCon, doubleTyCon, charTyCon)
import           Unique
import           Var


tcTyVar_maybe :: Type -> Maybe Var
tcTyVar_maybe :: Type -> Maybe Var
tcTyVar_maybe Type
ty | Just Type
ty' <- Type -> Maybe Type
tcView Type
ty = Type -> Maybe Var
tcTyVar_maybe Type
ty'
tcTyVar_maybe (CastTy Type
ty KindCoercion
_) = Type -> Maybe Var
tcTyVar_maybe Type
ty  -- look through casts, as
                                                -- this is only used for
                                                -- e.g., FlexibleContexts
tcTyVar_maybe (TyVarTy Var
v)   = Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v
tcTyVar_maybe Type
_             = Maybe Var
forall a. Maybe a
Nothing


instantiateType :: Type -> ([TyVar], Type)
instantiateType :: Type -> ([Var], Type)
instantiateType Type
t = do
  let vs :: [Var]
vs  = Type -> [Var]
tyCoVarsOfTypeList Type
t
      vs' :: [Var]
vs' = (Var -> Var) -> [Var] -> [Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> Var
cloneTyVar [Var]
vs
      subst :: TCvSubst
subst = ((Var, Var) -> TCvSubst -> TCvSubst)
-> TCvSubst -> [(Var, Var)] -> TCvSubst
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Var
v,Var
t) TCvSubst
a -> TCvSubst -> Var -> Type -> TCvSubst
extendTCvSubst TCvSubst
a Var
v (Type -> TCvSubst) -> Type -> TCvSubst
forall a b. (a -> b) -> a -> b
$ Var -> Type
TyVarTy Var
t) TCvSubst
emptyTCvSubst
            ([(Var, Var)] -> TCvSubst) -> [(Var, Var)] -> TCvSubst
forall a b. (a -> b) -> a -> b
$ [Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vs [Var]
vs'
   in ([Var]
vs', HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
t)


cloneTyVar :: TyVar -> TyVar
cloneTyVar :: Var -> Var
cloneTyVar Var
t =
  let uniq :: Unique
uniq = Var -> Unique
forall a. Uniquable a => a -> Unique
getUnique Var
t
      some_magic_number :: Int
some_magic_number = Int
49
   in Var -> Unique -> Var
setVarUnique Var
t (Unique -> Var) -> Unique -> Var
forall a b. (a -> b) -> a -> b
$ Unique -> Int -> Unique
deriveUnique Unique
uniq Int
some_magic_number


------------------------------------------------------------------------------
-- | Is this a function type?
isFunction :: Type -> Bool
isFunction :: Type -> Bool
isFunction (Type -> ([Var], ThetaType, ThetaType, Type)
tacticsSplitFunTy -> ([Var]
_, ThetaType
_, [], Type
_)) = Bool
False
isFunction Type
_ = Bool
True


------------------------------------------------------------------------------
-- | Split a function, also splitting out its quantified variables and theta
-- context.
tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Type], Type)
tacticsSplitFunTy :: Type -> ([Var], ThetaType, ThetaType, Type)
tacticsSplitFunTy Type
t
  = let ([Var]
vars, ThetaType
theta, Type
t') = Type -> ([Var], ThetaType, Type)
tcSplitSigmaTy Type
t
        (ThetaType
args, Type
res) = Type -> (ThetaType, Type)
tcSplitFunTys Type
t'
     in ([Var]
vars, ThetaType
theta, ThetaType
args, Type
res)


------------------------------------------------------------------------------
-- | Rip the theta context out of a regular type.
tacticsThetaTy :: Type -> ThetaType
tacticsThetaTy :: Type -> ThetaType
tacticsThetaTy (Type -> ([Var], ThetaType, Type)
tcSplitSigmaTy -> ([Var]
_, ThetaType
theta,  Type
_)) = ThetaType
theta


------------------------------------------------------------------------------
-- | Instantiate all of the quantified type variables in a type with fresh
-- skolems.
freshTyvars :: MonadState TacticState m => Type -> m Type
freshTyvars :: Type -> m Type
freshTyvars Type
t = do
  let ([Var]
tvs, ThetaType
_, ThetaType
_, Type
_) = Type -> ([Var], ThetaType, ThetaType, Type)
tacticsSplitFunTy Type
t
  Map Var Var
reps <- ([(Var, Var)] -> Map Var Var) -> m [(Var, Var)] -> m (Map Var Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Var, Var)] -> Map Var Var
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        (m [(Var, Var)] -> m (Map Var Var))
-> m [(Var, Var)] -> m (Map Var Var)
forall a b. (a -> b) -> a -> b
$ [Var] -> (Var -> m (Var, Var)) -> m [(Var, Var)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Var]
tvs ((Var -> m (Var, Var)) -> m [(Var, Var)])
-> (Var -> m (Var, Var)) -> m [(Var, Var)]
forall a b. (a -> b) -> a -> b
$ \Var
tv -> do
            Unique
uniq <- m Unique
forall (m :: * -> *). MonadState TacticState m => m Unique
freshUnique
            (Var, Var) -> m (Var, Var)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Var
tv, Var -> Unique -> Var
setTyVarUnique Var
tv Unique
uniq)
  Type -> m Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$
    (forall a. Data a => a -> a) -> Type -> Type
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere
      ((Var -> Var) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((Var -> Var) -> a -> a) -> (Var -> Var) -> a -> a
forall a b. (a -> b) -> a -> b
$ \Var
tv ->
        case Var -> Map Var Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
tv Map Var Var
reps of
          Just Var
tv' -> Var
tv'
          Maybe Var
Nothing -> Var
tv
      ) Type
t


------------------------------------------------------------------------------
-- | Given a datacon, extract its record fields' names and types. Returns
-- nothing if the datacon is not a record.
getRecordFields :: DataCon -> Maybe [(OccName, CType)]
getRecordFields :: DataCon -> Maybe [(OccName, CType)]
getRecordFields DataCon
dc =
  case DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc of
    [] -> Maybe [(OccName, CType)]
forall a. Maybe a
Nothing
    [FieldLabel]
lbls -> [FieldLabel]
-> (FieldLabel -> Maybe (OccName, CType))
-> Maybe [(OccName, CType)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [FieldLabel]
lbls ((FieldLabel -> Maybe (OccName, CType))
 -> Maybe [(OccName, CType)])
-> (FieldLabel -> Maybe (OccName, CType))
-> Maybe [(OccName, CType)]
forall a b. (a -> b) -> a -> b
$ \FieldLabel
lbl -> do
      (FieldLabel
_, Type
ty) <- DataCon -> FieldLabelString -> Maybe (FieldLabel, Type)
dataConFieldType_maybe DataCon
dc (FieldLabelString -> Maybe (FieldLabel, Type))
-> FieldLabelString -> Maybe (FieldLabel, Type)
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLabel
lbl
      (OccName, CType) -> Maybe (OccName, CType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldLabelString -> OccName
mkVarOccFS (FieldLabelString -> OccName) -> FieldLabelString -> OccName
forall a b. (a -> b) -> a -> b
$ FieldLabel -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLabel
lbl, Type -> CType
CType Type
ty)


------------------------------------------------------------------------------
-- | Is this an algebraic type?
algebraicTyCon :: Type -> Maybe TyCon
algebraicTyCon :: Type -> Maybe TyCon
algebraicTyCon (HasDebugCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
splitTyConApp_maybe -> Just (TyCon
tycon, ThetaType
_))
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intTyCon    = Maybe TyCon
forall a. Maybe a
Nothing
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
floatTyCon  = Maybe TyCon
forall a. Maybe a
Nothing
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
doubleTyCon = Maybe TyCon
forall a. Maybe a
Nothing
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
charTyCon   = Maybe TyCon
forall a. Maybe a
Nothing
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon    = Maybe TyCon
forall a. Maybe a
Nothing
  | Bool
otherwise = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tycon
algebraicTyCon Type
_ = Maybe TyCon
forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | We can't compare 'RdrName' for equality directly. Instead, compare them by
-- their 'OccName's.
eqRdrName :: RdrName -> RdrName -> Bool
eqRdrName :: RdrName -> RdrName -> Bool
eqRdrName = String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool)
-> (RdrName -> String) -> RdrName -> RdrName -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OccName -> String
occNameString (OccName -> String) -> (RdrName -> OccName) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName


------------------------------------------------------------------------------
-- | Does this thing contain any references to 'HsVar's with the given
-- 'RdrName'?
containsHsVar :: Data a => RdrName -> a -> Bool
containsHsVar :: RdrName -> a -> Bool
containsHsVar RdrName
name a
x = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [HsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([HsExpr GhcPs] -> Bool) -> [HsExpr GhcPs] -> Bool
forall a b. (a -> b) -> a -> b
$ (HsExpr GhcPs -> Bool) -> a -> [HsExpr GhcPs]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (
  \case
    ((HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
a)) :: HsExpr GhcPs) | RdrName -> RdrName -> Bool
eqRdrName IdP GhcPs
RdrName
a RdrName
name -> Bool
True
    HsExpr GhcPs
_ -> Bool
False
  ) a
x


------------------------------------------------------------------------------
-- | Does this thing contain any holes?
containsHole :: Data a => a -> Bool
containsHole :: a -> Bool
containsHole a
x = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [HsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([HsExpr GhcPs] -> Bool) -> [HsExpr GhcPs] -> Bool
forall a b. (a -> b) -> a -> b
$ (HsExpr GhcPs -> Bool) -> a -> [HsExpr GhcPs]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (
  \case
    ((HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
name)) :: HsExpr GhcPs) -> OccName -> Bool
isHole (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName IdP GhcPs
RdrName
name
    HsExpr GhcPs
_ -> Bool
False
  ) a
x


------------------------------------------------------------------------------
-- | Check if an 'OccName' is a hole
isHole :: OccName -> Bool
-- TODO(sandy): Make this more robust
isHole :: OccName -> Bool
isHole = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"_" (String -> Bool) -> (OccName -> String) -> OccName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString


------------------------------------------------------------------------------
-- | Get all of the referenced occnames.
allOccNames :: Data a => a -> Set OccName
allOccNames :: a -> Set OccName
allOccNames = (Set OccName -> Set OccName -> Set OccName)
-> GenericQ (Set OccName) -> GenericQ (Set OccName)
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Set OccName -> Set OccName -> Set OccName
forall a. Semigroup a => a -> a -> a
(<>) (GenericQ (Set OccName) -> GenericQ (Set OccName))
-> GenericQ (Set OccName) -> GenericQ (Set OccName)
forall a b. (a -> b) -> a -> b
$ Set OccName -> (OccName -> Set OccName) -> a -> Set OccName
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Set OccName
forall a. Monoid a => a
mempty ((OccName -> Set OccName) -> a -> Set OccName)
-> (OccName -> Set OccName) -> a -> Set OccName
forall a b. (a -> b) -> a -> b
$ \case
    OccName
a -> OccName -> Set OccName
forall a. a -> Set a
S.singleton OccName
a




------------------------------------------------------------------------------
-- | A pattern over the otherwise (extremely) messy AST for lambdas.
pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
pattern $bLambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
$mLambda :: forall r.
HsExpr GhcPs
-> ([Pat GhcPs] -> HsExpr GhcPs -> r) -> (Void# -> r) -> r
Lambda pats body <-
  HsLam _
    (MG {mg_alts = L _ [L _
      (Match { m_pats = fmap fromPatCompatPs -> pats
             , m_grhss = UnguardedRHSs body
             })]})
  where
    -- If there are no patterns to bind, just stick in the body
    Lambda [] HsExpr GhcPs
body   = HsExpr GhcPs
body
    Lambda [Pat GhcPs]
pats HsExpr GhcPs
body = [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
lambda [Pat GhcPs]
pats HsExpr GhcPs
body


------------------------------------------------------------------------------
-- | A GRHS that caontains no guards.
pattern UnguardedRHSs :: HsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
pattern $mUnguardedRHSs :: forall r.
GRHSs GhcPs (LHsExpr GhcPs)
-> (HsExpr GhcPs -> r) -> (Void# -> r) -> r
UnguardedRHSs body <-
  GRHSs {grhssGRHSs = [L _ (GRHS _ [] (L _ body))]}


------------------------------------------------------------------------------
-- | A match with a single pattern. Case matches are always 'SinglePatMatch'es.
pattern SinglePatMatch :: Pat GhcPs -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)
pattern $mSinglePatMatch :: forall r.
Match GhcPs (LHsExpr GhcPs)
-> (Pat GhcPs -> HsExpr GhcPs -> r) -> (Void# -> r) -> r
SinglePatMatch pat body <-
  Match { m_pats = [fromPatCompatPs -> pat]
        , m_grhss = UnguardedRHSs body
        }


------------------------------------------------------------------------------
-- | Helper function for defining the 'Case' pattern.
unpackMatches :: [Match GhcPs (LHsExpr GhcPs)] -> Maybe [(Pat GhcPs, HsExpr GhcPs)]
unpackMatches :: [Match GhcPs (LHsExpr GhcPs)] -> Maybe [(Pat GhcPs, HsExpr GhcPs)]
unpackMatches [] = [(Pat GhcPs, HsExpr GhcPs)] -> Maybe [(Pat GhcPs, HsExpr GhcPs)]
forall a. a -> Maybe a
Just []
unpackMatches (SinglePatMatch Pat GhcPs
pat HsExpr GhcPs
body : [Match GhcPs (LHsExpr GhcPs)]
matches) =
  (:) ((Pat GhcPs, HsExpr GhcPs)
 -> [(Pat GhcPs, HsExpr GhcPs)] -> [(Pat GhcPs, HsExpr GhcPs)])
-> Maybe (Pat GhcPs, HsExpr GhcPs)
-> Maybe
     ([(Pat GhcPs, HsExpr GhcPs)] -> [(Pat GhcPs, HsExpr GhcPs)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat GhcPs, HsExpr GhcPs) -> Maybe (Pat GhcPs, HsExpr GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat GhcPs
pat, HsExpr GhcPs
body) Maybe ([(Pat GhcPs, HsExpr GhcPs)] -> [(Pat GhcPs, HsExpr GhcPs)])
-> Maybe [(Pat GhcPs, HsExpr GhcPs)]
-> Maybe [(Pat GhcPs, HsExpr GhcPs)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Match GhcPs (LHsExpr GhcPs)] -> Maybe [(Pat GhcPs, HsExpr GhcPs)]
unpackMatches [Match GhcPs (LHsExpr GhcPs)]
matches
unpackMatches [Match GhcPs (LHsExpr GhcPs)]
_ = Maybe [(Pat GhcPs, HsExpr GhcPs)]
forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | A pattern over the otherwise (extremely) messy AST for lambdas.
pattern Case :: HsExpr GhcPs -> [(Pat GhcPs, HsExpr GhcPs)] -> HsExpr GhcPs
pattern $bCase :: HsExpr GhcPs -> [(Pat GhcPs, HsExpr GhcPs)] -> HsExpr GhcPs
$mCase :: forall r.
HsExpr GhcPs
-> (HsExpr GhcPs -> [(Pat GhcPs, HsExpr GhcPs)] -> r)
-> (Void# -> r)
-> r
Case scrutinee matches <-
  HsCase _ (L _ scrutinee)
    (MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)})
  where
    Case HsExpr GhcPs
scrutinee [(Pat GhcPs, HsExpr GhcPs)]
matches =
      HsExpr GhcPs -> [RawMatch] -> HsExpr GhcPs
case' HsExpr GhcPs
scrutinee ([RawMatch] -> HsExpr GhcPs) -> [RawMatch] -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ((Pat GhcPs, HsExpr GhcPs) -> RawMatch)
-> [(Pat GhcPs, HsExpr GhcPs)] -> [RawMatch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pat GhcPs
pat, HsExpr GhcPs
body) -> [Pat GhcPs] -> HsExpr GhcPs -> RawMatch
match [Pat GhcPs
pat] HsExpr GhcPs
body) [(Pat GhcPs, HsExpr GhcPs)]
matches


------------------------------------------------------------------------------
-- | Can ths type be lambda-cased?
--
-- Return: 'Nothing' if no
--         @Just False@ if it can't be homomorphic
--         @Just True@ if it can
lambdaCaseable :: Type -> Maybe Bool
lambdaCaseable :: Type -> Maybe Bool
lambdaCaseable (Type -> Maybe (Type, Type)
splitFunTy_maybe -> Just (Type
arg, Type
res))
  | Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe TyCon
algebraicTyCon Type
arg)
  = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust (Maybe TyCon -> Bool) -> Maybe TyCon -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Maybe TyCon
algebraicTyCon Type
res
lambdaCaseable Type
_ = Maybe Bool
forall a. Maybe a
Nothing

-- It's hard to generalize over these since weird type families are involved.
fromPatCompatTc :: PatCompat GhcTc -> Pat GhcTc
fromPatCompatPs :: PatCompat GhcPs -> Pat GhcPs
#if __GLASGOW_HASKELL__ == 808
type PatCompat pass = Pat pass
fromPatCompatTc = id
fromPatCompatPs = id
#else
type PatCompat pass = LPat pass
fromPatCompatTc :: PatCompat GhcTc -> Pat GhcTc
fromPatCompatTc = PatCompat GhcTc -> Pat GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc
fromPatCompatPs :: PatCompat GhcPs -> Pat GhcPs
fromPatCompatPs = PatCompat GhcPs -> Pat GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc
#endif

------------------------------------------------------------------------------
-- | Should make sure it's a fun bind
pattern TopLevelRHS :: OccName -> [PatCompat GhcTc] -> LHsExpr GhcTc -> Match GhcTc (LHsExpr GhcTc)
pattern $mTopLevelRHS :: forall r.
Match GhcTc (LHsExpr GhcTc)
-> (OccName -> [PatCompat GhcTc] -> LHsExpr GhcTc -> r)
-> (Void# -> r)
-> r
TopLevelRHS name ps body <-
  Match _
    (FunRhs (L _ (occName -> name)) _ _)
    ps
    (GRHSs _
      [L _ (GRHS _ [] body)] _)

getPatName :: PatCompat GhcTc -> Maybe OccName
getPatName :: PatCompat GhcTc -> Maybe OccName
getPatName (PatCompat GhcTc -> Pat GhcTc
fromPatCompatTc -> Pat GhcTc
p0) =
  case Pat GhcTc
p0 of
    VarPat  XVarPat GhcTc
_ Located (IdP GhcTc)
x   -> OccName -> Maybe OccName
forall a. a -> Maybe a
Just (OccName -> Maybe OccName) -> OccName -> Maybe OccName
forall a b. (a -> b) -> a -> b
$ Var -> OccName
forall name. HasOccName name => name -> OccName
occName (Var -> OccName) -> Var -> OccName
forall a b. (a -> b) -> a -> b
$ Located Var -> SrcSpanLess (Located Var)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcTc)
Located Var
x
    LazyPat XLazyPat GhcTc
_ PatCompat GhcTc
p   -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
    AsPat   XAsPat GhcTc
_ Located (IdP GhcTc)
x PatCompat GhcTc
_ -> OccName -> Maybe OccName
forall a. a -> Maybe a
Just (OccName -> Maybe OccName) -> OccName -> Maybe OccName
forall a b. (a -> b) -> a -> b
$ Var -> OccName
forall name. HasOccName name => name -> OccName
occName (Var -> OccName) -> Var -> OccName
forall a b. (a -> b) -> a -> b
$ Located Var -> SrcSpanLess (Located Var)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcTc)
Located Var
x
    ParPat  XParPat GhcTc
_ PatCompat GhcTc
p   -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
    BangPat XBangPat GhcTc
_ PatCompat GhcTc
p   -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
    ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
_ PatCompat GhcTc
p -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
#if __GLASGOW_HASKELL__ >= 808
    SigPat  XSigPat GhcTc
_ PatCompat GhcTc
p LHsSigWcType (NoGhcTc GhcTc)
_ -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
#endif
#if __GLASGOW_HASKELL__ == 808
    XPat   p      -> getPatName $ unLoc p
#endif
    Pat GhcTc
_             -> Maybe OccName
forall a. Maybe a
Nothing

dataConExTys :: DataCon -> [TyCoVar]
#if __GLASGOW_HASKELL__ >= 808
dataConExTys :: DataCon -> [Var]
dataConExTys = DataCon -> [Var]
DataCon.dataConExTyCoVars
#else
dataConExTys = DataCon.dataConExTyVars
#endif


------------------------------------------------------------------------------
-- | In GHC 8.8, sometimes patterns are wrapped in 'XPat'.
-- The nitty gritty details are explained at
-- https://blog.shaynefletcher.org/2020/03/ghc-haskell-pats-and-lpats.html
--
-- We need to remove these in order to succesfull find patterns.
unXPat :: Pat GhcPs -> Pat GhcPs
#if __GLASGOW_HASKELL__ == 808
unXPat (XPat (L _ pat)) = unXPat pat
#endif
unXPat :: Pat GhcPs -> Pat GhcPs
unXPat Pat GhcPs
pat = Pat GhcPs
pat