{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

TcPat: Typechecking patterns
-}

{-# LANGUAGE CPP, RankNTypes, TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..)
             , tcPat, tcPat_O, tcPats
             , addDataConStupidTheta, badFieldCon, polyPatSig ) where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )

import HsSyn
import TcHsSyn
import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags )
import TcRnMonad
import Inst
import Id
import Var
import Name
import RdrName
import TcEnv
import TcMType
import TcValidity( arityErr )
import Type ( pprTyVars )
import TcType
import TcUnify
import TcHsType
import TysWiredIn
import TcEvidence
import TyCon
import DataCon
import PatSyn
import ConLike
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import DynFlags
import SrcLoc
import VarSet
import Util
import Outputable
import qualified GHC.LanguageExtensions as LangExt
import Control.Arrow  ( second )
import ListSetOps ( getNth )

{-
************************************************************************
*                                                                      *
                External interface
*                                                                      *
************************************************************************
-}

tcLetPat :: (Name -> Maybe TcId)
         -> LetBndrSpec
         -> LPat GhcRn -> ExpSigmaType
         -> TcM a
         -> TcM (LPat GhcTcId, a)
tcLetPat sig_fn no_gen pat pat_ty thing_inside
  = do { bind_lvl <- getTcLevel
       ; let ctxt = LetPat { pc_lvl    = bind_lvl
                           , pc_sig_fn = sig_fn
                           , pc_new    = no_gen }
             penv = PE { pe_lazy = True
                       , pe_ctxt = ctxt
                       , pe_orig = PatOrigin }

       ; tc_lpat pat pat_ty penv thing_inside }

-----------------
tcPats :: HsMatchContext Name
       -> [LPat GhcRn]            -- Patterns,
       -> [ExpSigmaType]         --   and their types
       -> TcM a                  --   and the checker for the body
       -> TcM ([LPat GhcTcId], a)

-- This is the externally-callable wrapper function
-- Typecheck the patterns, extend the environment to bind the variables,
-- do the thing inside, use any existentially-bound dictionaries to
-- discharge parts of the returning LIE, and deal with pattern type
-- signatures

--   1. Initialise the PatState
--   2. Check the patterns
--   3. Check the body
--   4. Check that no existentials escape

tcPats ctxt pats pat_tys thing_inside
  = tc_lpats penv pats pat_tys thing_inside
  where
    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }

tcPat :: HsMatchContext Name
      -> LPat GhcRn -> ExpSigmaType
      -> TcM a                     -- Checker for body
      -> TcM (LPat GhcTcId, a)
tcPat ctxt = tcPat_O ctxt PatOrigin

-- | A variant of 'tcPat' that takes a custom origin
tcPat_O :: HsMatchContext Name
        -> CtOrigin              -- ^ origin to use if the type needs inst'ing
        -> LPat GhcRn -> ExpSigmaType
        -> TcM a                 -- Checker for body
        -> TcM (LPat GhcTcId, a)
tcPat_O ctxt orig pat pat_ty thing_inside
  = tc_lpat pat pat_ty penv thing_inside
  where
    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }

{-
************************************************************************
*                                                                      *
                PatEnv, PatCtxt, LetBndrSpec
*                                                                      *
************************************************************************
-}

data PatEnv
  = PE { pe_lazy :: Bool        -- True <=> lazy context, so no existentials allowed
       , pe_ctxt :: PatCtxt     -- Context in which the whole pattern appears
       , pe_orig :: CtOrigin    -- origin to use if the pat_ty needs inst'ing
       }

data PatCtxt
  = LamPat   -- Used for lambdas, case etc
       (HsMatchContext Name)

  | LetPat   -- Used only for let(rec) pattern bindings
             -- See Note [Typing patterns in pattern bindings]
       { pc_lvl    :: TcLevel
                   -- Level of the binding group

       , pc_sig_fn :: Name -> Maybe TcId
                   -- Tells the expected type
                   -- for binders with a signature

       , pc_new :: LetBndrSpec
                -- How to make a new binder
       }        -- for binders without signatures

data LetBndrSpec
  = LetLclBndr            -- We are going to generalise, and wrap in an AbsBinds
                          -- so clone a fresh binder for the local monomorphic Id

  | LetGblBndr TcPragEnv  -- Generalisation plan is NoGen, so there isn't going
                          -- to be an AbsBinds; So we must bind the global version
                          -- of the binder right away.
                          -- And here is the inline-pragma information

instance Outputable LetBndrSpec where
  ppr LetLclBndr      = text "LetLclBndr"
  ppr (LetGblBndr {}) = text "LetGblBndr"

makeLazy :: PatEnv -> PatEnv
makeLazy penv = penv { pe_lazy = True }

inPatBind :: PatEnv -> Bool
inPatBind (PE { pe_ctxt = LetPat {} }) = True
inPatBind (PE { pe_ctxt = LamPat {} }) = False

{- *********************************************************************
*                                                                      *
                Binders
*                                                                      *
********************************************************************* -}

tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId)
-- (coi, xp) = tcPatBndr penv x pat_ty
-- Then coi : pat_ty ~ typeof(xp)
--
tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl
                                      , pc_sig_fn = sig_fn
                                      , pc_new    = no_gen } })
          bndr_name exp_pat_ty
  -- For the LetPat cases, see
  -- Note [Typechecking pattern bindings] in TcBinds

  | Just bndr_id <- sig_fn bndr_name   -- There is a signature
  = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id)
           -- See Note [Subsumption check at pattern variables]
       ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
       ; return (wrap, bndr_id) }

  | otherwise                          -- No signature
  = do { (co, bndr_ty) <- case exp_pat_ty of
             Check pat_ty    -> promoteTcType bind_lvl pat_ty
             Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )
                                -- If we were under a constructor that bumped
                                -- the level, we'd be in checking mode
                                do { bndr_ty <- inferResultToType infer_res
                                   ; return (mkTcNomReflCo bndr_ty, bndr_ty) }
       ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty
       ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl
                                          , ppr exp_pat_ty, ppr bndr_ty, ppr co
                                          , ppr bndr_id ])
       ; return (mkWpCastN co, bndr_id) }

tcPatBndr _ bndr_name pat_ty
  = do { pat_ty <- expTypeToType pat_ty
       ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)
       ; return (idHsWrapper, mkLocalId bndr_name pat_ty) }
               -- Whether or not there is a sig is irrelevant,
               -- as this is local

newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
-- Make up a suitable Id for the pattern-binder.
-- See Note [Typechecking pattern bindings], item (4) in TcBinds
--
-- In the polymorphic case when we are going to generalise
--    (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version"
--    of the Id; the original name will be bound to the polymorphic version
--    by the AbsBinds
-- In the monomorphic case when we are not going to generalise
--    (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds,
--    and we use the original name directly
newLetBndr LetLclBndr name ty
  = do { mono_name <- cloneLocalName name
       ; return (mkLocalId mono_name ty) }
newLetBndr (LetGblBndr prags) name ty
  = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)

tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
-- Used when typechecking patterns
tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2

{- Note [Subsumption check at pattern variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we come across a variable with a type signature, we need to do a
subsumption, not equality, check against the context type.  e.g.

    data T = MkT (forall a. a->a)
      f :: forall b. [b]->[b]
      MkT f = blah

Since 'blah' returns a value of type T, its payload is a polymorphic
function of type (forall a. a->a).  And that's enough to bind the
less-polymorphic function 'f', but we need some impedance matching
to witness the instantiation.

************************************************************************
*                                                                      *
                The main worker functions
*                                                                      *
************************************************************************

Note [Nesting]
~~~~~~~~~~~~~~
tcPat takes a "thing inside" over which the pattern scopes.  This is partly
so that tcPat can extend the environment for the thing_inside, but also
so that constraints arising in the thing_inside can be discharged by the
pattern.

This does not work so well for the ErrCtxt carried by the monad: we don't
want the error-context for the pattern to scope over the RHS.
Hence the getErrCtxt/setErrCtxt stuff in tcMultiple
-}

--------------------
type Checker inp out =  forall r.
                          inp
                       -> PatEnv
                       -> TcM r
                       -> TcM (out, r)

tcMultiple :: Checker inp out -> Checker [inp] [out]
tcMultiple tc_pat args penv thing_inside
  = do  { err_ctxt <- getErrCtxt
        ; let loop _ []
                = do { res <- thing_inside
                     ; return ([], res) }

              loop penv (arg:args)
                = do { (p', (ps', res))
                                <- tc_pat arg penv $
                                   setErrCtxt err_ctxt $
                                   loop penv args
                -- setErrCtxt: restore context before doing the next pattern
                -- See note [Nesting] above

                     ; return (p':ps', res) }

        ; loop penv args }

--------------------
tc_lpat :: LPat GhcRn
        -> ExpSigmaType
        -> PatEnv
        -> TcM a
        -> TcM (LPat GhcTcId, a)
tc_lpat (dL->L span pat) pat_ty penv thing_inside
  = setSrcSpan span $
    do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
                                          thing_inside
        ; return (cL span pat', res) }

tc_lpats :: PatEnv
         -> [LPat GhcRn] -> [ExpSigmaType]
         -> TcM a
         -> TcM ([LPat GhcTcId], a)
tc_lpats penv pats tys thing_inside
  = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )
    tcMultiple (\(p,t) -> tc_lpat p t)
                (zipEqual "tc_lpats" pats tys)
                penv thing_inside

--------------------
tc_pat  :: PatEnv
        -> Pat GhcRn
        -> ExpSigmaType  -- Fully refined result type
        -> TcM a                -- Thing inside
        -> TcM (Pat GhcTcId,    -- Translated pattern
                a)              -- Result of thing inside

tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside
  = do  { (wrap, id) <- tcPatBndr penv name pat_ty
        ; res <- tcExtendIdEnv1 name id thing_inside
        ; pat_ty <- readExpType pat_ty
        ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) }

tc_pat penv (ParPat x pat) pat_ty thing_inside
  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
        ; return (ParPat x pat', res) }

tc_pat penv (BangPat x pat) pat_ty thing_inside
  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
        ; return (BangPat x pat', res) }

tc_pat penv (LazyPat x pat) pat_ty thing_inside
  = do  { (pat', (res, pat_ct))
                <- tc_lpat pat pat_ty (makeLazy penv) $
                   captureConstraints thing_inside
                -- Ignore refined penv', revert to penv

        ; emitConstraints pat_ct
        -- captureConstraints/extendConstraints:
        --   see Note [Hopping the LIE in lazy patterns]

        -- Check that the expected pattern type is itself lifted
        ; pat_ty <- readExpType pat_ty
        ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind

        ; return (LazyPat x pat', res) }

tc_pat _ (WildPat _) pat_ty thing_inside
  = do  { res <- thing_inside
        ; pat_ty <- expTypeToType pat_ty
        ; return (WildPat pat_ty, res) }

tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside
  = do  { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
                         tc_lpat pat (mkCheckExpType $ idType bndr_id)
                                 penv thing_inside
            -- NB: if we do inference on:
            --          \ (y@(x::forall a. a->a)) = e
            -- we'll fail.  The as-pattern infers a monotype for 'y', which then
            -- fails to unify with the polymorphic type for 'x'.  This could
            -- perhaps be fixed, but only with a bit more work.
            --
            -- If you fix it, don't forget the bindInstsOfPatIds!
        ; pat_ty <- readExpType pat_ty
        ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty,
                  res) }

tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
  = do  {
         -- Expr must have type `forall a1...aN. OPT' -> B`
         -- where overall_pat_ty is an instance of OPT'.
        ; (expr',expr'_inferred) <- tcInferSigma expr

         -- expression must be a function
        ; let expr_orig = lexprCtOrigin expr
              herald    = text "A view pattern expression expects"
        ; (expr_wrap1, [inf_arg_ty], inf_res_ty)
            <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr'_inferred
            -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)

         -- check that overall pattern is more polymorphic than arg type
        ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty
            -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty

         -- pattern must have inf_res_ty
        ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside

        ; overall_pat_ty <- readExpType overall_pat_ty
        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
                                    overall_pat_ty inf_res_ty doc
               -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"
               --                (overall_pat_ty -> inf_res_ty)
              expr_wrap = expr_wrap2' <.> expr_wrap1
              doc = text "When checking the view pattern function:" <+> (ppr expr)
        ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)}

-- Type signatures in patterns
-- See Note [Pattern coercions] below
tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside
  = do  { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
                                                            sig_ty pat_ty
                -- Using tcExtendNameTyVarEnv is appropriate here
                -- because we're not really bringing fresh tyvars into scope.
                -- We're *naming* existing tyvars. Note that it is OK for a tyvar
                -- from an outer scope to mention one of these tyvars in its kind.
        ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
                         tcExtendNameTyVarEnv tv_binds $
                         tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
        ; pat_ty <- readExpType pat_ty
        ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }

------------------------
-- Lists, tuples, arrays
tc_pat penv (ListPat Nothing pats) pat_ty thing_inside
  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
                                     pats penv thing_inside
        ; pat_ty <- readExpType pat_ty
        ; return (mkHsWrapPat coi
                         (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)
}

tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside
  = do  { tau_pat_ty <- expTypeToType pat_ty
        ; ((pats', res, elt_ty), e')
            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
                                          SynList $
                 \ [elt_ty] ->
                 do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
                                                 pats penv thing_inside
                    ; return (pats', res, elt_ty) }
        ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)
}

tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
  = do  { let arity = length pats
              tc = tupleTyCon boxity arity
        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
                                               penv pat_ty
                     -- Unboxed tuples have RuntimeRep vars, which we discard:
                     -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
        ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
                                           Boxed   -> arg_tys
        ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)
                                   thing_inside

        ; dflags <- getDynFlags

        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
        -- so that we can experiment with lazy tuple-matching.
        -- This is a pretty odd place to make the switch, but
        -- it was easy to do.
        ; let
              unmangled_result = TuplePat con_arg_tys pats' boxity
                                 -- pat_ty /= pat_ty iff coi /= IdCo
              possibly_mangled_result
                | gopt Opt_IrrefutableTuples dflags &&
                  isBoxed boxity      = LazyPat noExt (noLoc unmangled_result)
                | otherwise           = unmangled_result

        ; pat_ty <- readExpType pat_ty
        ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced
          return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
        }

tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
  = do  { let tc = sumTyCon arity
        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
                                               penv pat_ty
        ; -- Drop levity vars, we don't care about them here
          let con_arg_tys = drop arity arg_tys
        ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
                                 penv thing_inside
        ; pat_ty <- readExpType pat_ty
        ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
                 , res)
        }

------------------------
-- Data constructors
tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
  = tcConPat penv con pat_ty arg_pats thing_inside

------------------------
-- Literal patterns
tc_pat penv (LitPat x simple_lit) pat_ty thing_inside
  = do  { let lit_ty = hsLitType simple_lit
        ; wrap   <- tcSubTypePat penv pat_ty lit_ty
        ; res    <- thing_inside
        ; pat_ty <- readExpType pat_ty
        ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
                 , res) }

------------------------
-- Overloaded patterns: n, and n+k

-- In the case of a negative literal (the more complicated case),
-- we get
--
--   case v of (-5) -> blah
--
-- becoming
--
--   if v == (negate (fromInteger 5)) then blah else ...
--
-- There are two bits of rebindable syntax:
--   (==)   :: pat_ty -> neg_lit_ty -> Bool
--   negate :: lit_ty -> neg_lit_ty
-- where lit_ty is the type of the overloaded literal 5.
--
-- When there is no negation, neg_lit_ty and lit_ty are the same
tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside
  = do  { let orig = LiteralOrigin over_lit
        ; ((lit', mb_neg'), eq')
            <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]
                          (mkCheckExpType boolTy) $
               \ [neg_lit_ty] ->
               let new_over_lit lit_ty = newOverloadedLit over_lit
                                           (mkCheckExpType lit_ty)
               in case mb_neg of
                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
                 Just neg -> -- Negative literal
                             -- The 'negate' is re-mappable syntax
                   second Just <$>
                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
                    \ [lit_ty] -> new_over_lit lit_ty)

        ; res <- thing_inside
        ; pat_ty <- readExpType pat_ty
        ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) }

{-
Note [NPlusK patterns]
~~~~~~~~~~~~~~~~~~~~~~
From

  case v of x + 5 -> blah

we get

  if v >= 5 then (\x -> blah) (v - 5) else ...

There are two bits of rebindable syntax:
  (>=) :: pat_ty -> lit1_ty -> Bool
  (-)  :: pat_ty -> lit2_ty -> var_ty

lit1_ty and lit2_ty could conceivably be different.
var_ty is the type inferred for x, the variable in the pattern.

If the pushed-down pattern type isn't a tau-type, the two pat_ty's above
could conceivably be different specializations. But this is very much
like the situation in Note [Case branches must be taus] in TcMatches.
So we tauify the pat_ty before proceeding.

Note that we need to type-check the literal twice, because it is used
twice, and may be used at different types. The second HsOverLit stored in the
AST is used for the subtraction operation.
-}

-- See Note [NPlusK patterns]
tc_pat penv (NPlusKPat _ (dL->L nm_loc name)
               (dL->L loc lit) _ ge minus) pat_ty
              thing_inside
  = do  { pat_ty <- expTypeToType pat_ty
        ; let orig = LiteralOrigin lit
        ; (lit1', ge')
            <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho]
                                  (mkCheckExpType boolTy) $
               \ [lit1_ty] ->
               newOverloadedLit lit (mkCheckExpType lit1_ty)
        ; ((lit2', minus_wrap, bndr_id), minus')
            <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $
               \ [lit2_ty, var_ty] ->
               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
                  ; (wrap, bndr_id) <- setSrcSpan nm_loc $
                                     tcPatBndr penv name (mkCheckExpType var_ty)
                           -- co :: var_ty ~ idType bndr_id

                           -- minus_wrap is applicable to minus'
                  ; return (lit2', wrap, bndr_id) }

        -- The Report says that n+k patterns must be in Integral
        -- but it's silly to insist on this in the RebindableSyntax case
        ; unlessM (xoptM LangExt.RebindableSyntax) $
          do { icls <- tcLookupClass integralClassName
             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }

        ; res <- tcExtendIdEnv1 name bndr_id thing_inside

        ; let minus'' = minus' { syn_res_wrap =
                                    minus_wrap <.> syn_res_wrap minus' }
              pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2'
                               ge' minus''
        ; return (pat', res) }

-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.
-- Here we get rid of it and add the finalizers to the global environment.
--
-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat)))
            pat_ty thing_inside
  = do addModFinalizersWithLclEnv mod_finalizers
       tc_pat penv pat pat_ty thing_inside

tc_pat _ _other_pat _ _ = panic "tc_pat"        -- ConPatOut, SigPatOut

{-
Note [Hopping the LIE in lazy patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a lazy pattern, we must *not* discharge constraints from the RHS
from dictionaries bound in the pattern.  E.g.
        f ~(C x) = 3
We can't discharge the Num constraint from dictionaries bound by
the pattern C!

So we have to make the constraints from thing_inside "hop around"
the pattern.  Hence the captureConstraints and emitConstraints.

The same thing ensures that equality constraints in a lazy match
are not made available in the RHS of the match. For example
        data T a where { T1 :: Int -> T Int; ... }
        f :: T a -> Int -> a
        f ~(T1 i) y = y
It's obviously not sound to refine a to Int in the right
hand side, because the argument might not match T1 at all!

Finally, a lazy pattern should not bind any existential type variables
because they won't be in scope when we do the desugaring

************************************************************************
*                                                                      *
        Most of the work for constructors is here
        (the rest is in the ConPatIn case of tc_pat)
*                                                                      *
************************************************************************

[Pattern matching indexed data types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following declarations:

  data family Map k :: * -> *
  data instance Map (a, b) v = MapPair (Map a (Pair b v))

and a case expression

  case x :: Map (Int, c) w of MapPair m -> ...

As explained by [Wrappers for data instance tycons] in MkIds.hs, the
worker/wrapper types for MapPair are

  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v

So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is
:R123Map, which means the straight use of boxySplitTyConApp would give a type
error.  Hence, the smart wrapper function boxySplitTyConAppWithFamily calls
boxySplitTyConApp with the family tycon Map instead, which gives us the family
type list {(Int, c), w}.  To get the correct split for :R123Map, we need to
unify the family type list {(Int, c), w} with the instance types {(a, b), v}
(provided by tyConFamInst_maybe together with the family tycon).  This
unification yields the substitution [a -> Int, b -> c, v -> w], which gives us
the split arguments for the representation tycon :R123Map as {Int, c, w}

In other words, boxySplitTyConAppWithFamily implicitly takes the coercion

  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}

moving between representation and family type into account.  To produce type
correct Core, this coercion needs to be used to case the type of the scrutinee
from the family to the representation type.  This is achieved by
unwrapFamInstScrutinee using a CoPat around the result pattern.

Now it might appear seem as if we could have used the previous GADT type
refinement infrastructure of refineAlt and friends instead of the explicit
unification and CoPat generation.  However, that would be wrong.  Why?  The
whole point of GADT refinement is that the refinement is local to the case
alternative.  In contrast, the substitution generated by the unification of
the family type list and instance types needs to be propagated to the outside.
Imagine that in the above example, the type of the scrutinee would have been
(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the
substitution [x -> (a, b), v -> w].  In contrast to GADT matching, the
instantiation of x with (a, b) must be global; ie, it must be valid in *all*
alternatives of the case expression, whereas in the GADT case it might vary
between alternatives.

RIP GADT refinement: refinements have been replaced by the use of explicit
equality constraints that are used in conjunction with implication constraints
to express the local scope of GADT refinements.
-}

--      Running example:
-- MkT :: forall a b c. (a~[b]) => b -> c -> T a
--       with scrutinee of type (T ty)

tcConPat :: PatEnv -> Located Name
         -> ExpSigmaType           -- Type of the pattern
         -> HsConPatDetails GhcRn -> TcM a
         -> TcM (Pat GhcTcId, a)
tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside
  = do  { con_like <- tcLookupConLike con_name
        ; case con_like of
            RealDataCon data_con -> tcDataConPat penv con_lname data_con
                                                 pat_ty arg_pats thing_inside
            PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn
                                             pat_ty arg_pats thing_inside
        }

tcDataConPat :: PatEnv -> Located Name -> DataCon
             -> ExpSigmaType               -- Type of the pattern
             -> HsConPatDetails GhcRn -> TcM a
             -> TcM (Pat GhcTcId, a)
tcDataConPat penv (dL->L con_span con_name) data_con pat_ty
             arg_pats thing_inside
  = do  { let tycon = dataConTyCon data_con
                  -- For data families this is the representation tycon
              (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
                = dataConFullSig data_con
              header = cL con_span (RealDataCon data_con)

          -- Instantiate the constructor type variables [a->ty]
          -- This may involve doing a family-instance coercion,
          -- and building a wrapper
        ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty
        ; pat_ty <- readExpType pat_ty

          -- Add the stupid theta
        ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys

        ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys
        ; checkExistentials ex_tvs all_arg_tys penv

        ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys
                  -- NB: Do not use zipTvSubst!  See Trac #14154
                  -- We want to create a well-kinded substitution, so
                  -- that the instantiated type is well-kinded

        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs
                     -- Get location from monad, not from ex_tvs

        ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
              -- pat_ty' is type of the actual constructor application
              -- pat_ty' /= pat_ty iff coi /= IdCo

              arg_tys' = substTys tenv arg_tys

        ; traceTc "tcConPat" (vcat [ ppr con_name
                                   , pprTyVars univ_tvs
                                   , pprTyVars ex_tvs
                                   , ppr eq_spec
                                   , ppr theta
                                   , pprTyVars ex_tvs'
                                   , ppr ctxt_res_tys
                                   , ppr arg_tys'
                                   , ppr arg_pats ])
        ; if null ex_tvs && null eq_spec && null theta
          then do { -- The common case; no class bindings etc
                    -- (see Note [Arrows and patterns])
                    (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'
                                                  arg_pats penv thing_inside
                  ; let res_pat = ConPatOut { pat_con = header,
                                              pat_tvs = [], pat_dicts = [],
                                              pat_binds = emptyTcEvBinds,
                                              pat_args = arg_pats',
                                              pat_arg_tys = ctxt_res_tys,
                                              pat_wrap = idHsWrapper }

                  ; return (mkHsWrapPat wrap res_pat pat_ty, res) }

          else do   -- The general case, with existential,
                    -- and local equality constraints
        { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)
                           -- order is *important* as we generate the list of
                           -- dictionary binders from theta'
              no_equalities = null eq_spec && not (any isEqPred theta)
              skol_info = PatSkol (RealDataCon data_con) mc
              mc = case pe_ctxt penv of
                     LamPat mc -> mc
                     LetPat {} -> PatBindRhs

        ; gadts_on    <- xoptM LangExt.GADTs
        ; families_on <- xoptM LangExt.TypeFamilies
        ; checkTc (no_equalities || gadts_on || families_on)
                  (text "A pattern match on a GADT requires the" <+>
                   text "GADTs or TypeFamilies language extension")
                  -- Trac #2905 decided that a *pattern-match* of a GADT
                  -- should require the GADT language flag.
                  -- Re TypeFamilies see also #7156

        ; given <- newEvVars theta'
        ; (ev_binds, (arg_pats', res))
             <- checkConstraints skol_info ex_tvs' given $
                tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside

        ; let res_pat = ConPatOut { pat_con   = header,
                                    pat_tvs   = ex_tvs',
                                    pat_dicts = given,
                                    pat_binds = ev_binds,
                                    pat_args  = arg_pats',
                                    pat_arg_tys = ctxt_res_tys,
                                    pat_wrap  = idHsWrapper }
        ; return (mkHsWrapPat wrap res_pat pat_ty, res)
        } }

tcPatSynPat :: PatEnv -> Located Name -> PatSyn
            -> ExpSigmaType                -- Type of the pattern
            -> HsConPatDetails GhcRn -> TcM a
            -> TcM (Pat GhcTcId, a)
tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside
  = do  { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn

        ; (subst, univ_tvs') <- newMetaTyVars univ_tvs

        ; let all_arg_tys = ty : prov_theta ++ arg_tys
        ; checkExistentials ex_tvs all_arg_tys penv
        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs
        ; let ty'         = substTy tenv ty
              arg_tys'    = substTys tenv arg_tys
              prov_theta' = substTheta tenv prov_theta
              req_theta'  = substTheta tenv req_theta

        ; wrap <- tcSubTypePat penv pat_ty ty'
        ; traceTc "tcPatSynPat" (ppr pat_syn $$
                                 ppr pat_ty $$
                                 ppr ty' $$
                                 ppr ex_tvs' $$
                                 ppr prov_theta' $$
                                 ppr req_theta' $$
                                 ppr arg_tys')

        ; prov_dicts' <- newEvVars prov_theta'

        ; let skol_info = case pe_ctxt penv of
                            LamPat mc -> PatSkol (PatSynCon pat_syn) mc
                            LetPat {} -> UnkSkol -- Doesn't matter

        ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta'
        ; traceTc "instCall" (ppr req_wrap)

        ; traceTc "checkConstraints {" Outputable.empty
        ; (ev_binds, (arg_pats', res))
             <- checkConstraints skol_info ex_tvs' prov_dicts' $
                tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside

        ; traceTc "checkConstraints }" (ppr ev_binds)
        ; let res_pat = ConPatOut { pat_con   = cL con_span $ PatSynCon pat_syn,
                                    pat_tvs   = ex_tvs',
                                    pat_dicts = prov_dicts',
                                    pat_binds = ev_binds,
                                    pat_args  = arg_pats',
                                    pat_arg_tys = mkTyVarTys univ_tvs',
                                    pat_wrap  = req_wrap }
        ; pat_ty <- readExpType pat_ty
        ; return (mkHsWrapPat wrap res_pat pat_ty, res) }

----------------------------
-- | Convenient wrapper for calling a matchExpectedXXX function
matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))
                    -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a)
-- See Note [Matching polytyped patterns]
-- Returns a wrapper : pat_ty ~R inner_ty
matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty
  = do { pat_ty <- expTypeToType pat_ty
       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
       ; (co, res) <- inner_match pat_rho
       ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap)
       ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) }

----------------------------
matchExpectedConTy :: PatEnv
                   -> TyCon      -- The TyCon that this data
                                 -- constructor actually returns
                                 -- In the case of a data family this is
                                 -- the /representation/ TyCon
                   -> ExpSigmaType  -- The type of the pattern; in the case
                                    -- of a data family this would mention
                                    -- the /family/ TyCon
                   -> TcM (HsWrapper, [TcSigmaType])
-- See Note [Matching constructor patterns]
-- Returns a wrapper : pat_ty "->" T ty1 ... tyn
matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
  | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
         -- Comments refer to Note [Matching constructor patterns]
         -- co_tc :: forall a. T [a] ~ T7 a
  = do { pat_ty <- expTypeToType exp_pat_ty
       ; (wrap, pat_rho) <- topInstantiate orig pat_ty

       ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)
             -- tys = [ty1,ty2]

       ; traceTc "matchExpectedConTy" (vcat [ppr data_tc,
                                             ppr (tyConTyVars data_tc),
                                             ppr fam_tc, ppr fam_args,
                                             ppr exp_pat_ty,
                                             ppr pat_ty,
                                             ppr pat_rho, ppr wrap])
       ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho
             -- co1 : T (ty1,ty2) ~N pat_rho
             -- could use tcSubType here... but it's the wrong way round
             -- for actual vs. expected in error messages.

       ; let tys' = mkTyVarTys tvs'
             co2 = mkTcUnbranchedAxInstCo co_tc tys' []
             -- co2 : T (ty1,ty2) ~R T7 ty1 ty2

             full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2
             -- full_co :: pat_rho ~R T7 ty1 ty2

       ; return ( mkWpCastR full_co <.> wrap, tys') }

  | otherwise
  = do { pat_ty <- expTypeToType exp_pat_ty
       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
       ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho
       ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) }

{-
Note [Matching constructor patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose (coi, tys) = matchExpectedConType data_tc pat_ty

 * In the simple case, pat_ty = tc tys

 * If pat_ty is a polytype, we want to instantiate it
   This is like part of a subsumption check.  Eg
      f :: (forall a. [a]) -> blah
      f [] = blah

 * In a type family case, suppose we have
          data family T a
          data instance T (p,q) = A p | B q
       Then we'll have internally generated
              data T7 p q = A p | B q
              axiom coT7 p q :: T (p,q) ~ T7 p q

       So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that
           coi = coi2 . coi1 : T7 t ~ pat_ty
           coi1 : T (ty1,ty2) ~ pat_ty
           coi2 : T7 ty1 ty2 ~ T (ty1,ty2)

   For families we do all this matching here, not in the unifier,
   because we never want a whisper of the data_tycon to appear in
   error messages; it's a purely internal thing
-}

tcConArgs :: ConLike -> [TcSigmaType]
          -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc)

tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside
  = do  { checkTc (con_arity == no_of_args)     -- Check correct arity
                  (arityErr (text "constructor") con_like con_arity no_of_args)
        ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
        ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys
                                              penv thing_inside
        ; return (PrefixCon arg_pats', res) }
  where
    con_arity  = conLikeArity con_like
    no_of_args = length arg_pats

tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside
  = do  { checkTc (con_arity == 2)      -- Check correct arity
                  (arityErr (text "constructor") con_like con_arity 2)
        ; let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after the arity check
        ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
                                              penv thing_inside
        ; return (InfixCon p1' p2', res) }
  where
    con_arity  = conLikeArity con_like

tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
  = do  { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
        ; return (RecCon (HsRecFields rpats' dd), res) }
  where
    tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
                        (LHsRecField GhcTcId (LPat GhcTcId))
    tc_field (dL->L l (HsRecField (dL->L loc
                                    (FieldOcc sel (dL->L lr rdr))) pat pun))
             penv thing_inside
      = do { sel'   <- tcLookupId sel
           ; pat_ty <- setSrcSpan loc $ find_field_ty sel
                                          (occNameFS $ rdrNameOcc rdr)
           ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
           ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat'
                                                                    pun), res) }
    tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _
           = panic "tcConArgs"
    tc_field _ _ _ = panic "tc_field: Impossible Match"
                             -- due to #15884

    find_field_ty :: Name -> FieldLabelString -> TcM TcType
    find_field_ty sel lbl
        = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of

                -- No matching field; chances are this field label comes from some
                -- other record type (or maybe none).  If this happens, just fail,
                -- otherwise we get crashes later (Trac #8570), and similar:
                --      f (R { foo = (a,b) }) = a+b
                -- If foo isn't one of R's fields, we don't want to crash when
                -- typechecking the "a+b".
           [] -> failWith (badFieldCon con_like lbl)

                -- The normal case, when the field comes from the right constructor
           (pat_ty : extras) -> do
                traceTc "find_field" (ppr pat_ty <+> ppr extras)
                ASSERT( null extras ) (return pat_ty)

    field_tys :: [(FieldLabel, TcType)]
    field_tys = zip (conLikeFieldLabels con_like) arg_tys
          -- Don't use zipEqual! If the constructor isn't really a record, then
          -- dataConFieldLabels will be empty (and each field in the pattern
          -- will generate an error below).

tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc)
tcConArg (arg_pat, arg_ty) penv thing_inside
  = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside

addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw
-- the constraints into the constraint set
addDataConStupidTheta data_con inst_tys
  | null stupid_theta = return ()
  | otherwise         = instStupidTheta origin inst_theta
  where
    origin = OccurrenceOf (dataConName data_con)
        -- The origin should always report "occurrence of C"
        -- even when C occurs in a pattern
    stupid_theta = dataConStupidTheta data_con
    univ_tvs     = dataConUnivTyVars data_con
    tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys)
         -- NB: inst_tys can be longer than the univ tyvars
         --     because the constructor might have existentials
    inst_theta = substTheta tenv stupid_theta

{-
Note [Arrows and patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~
(Oct 07) Arrow notation has the odd property that it involves
"holes in the scope". For example:
  expr :: Arrow a => a () Int
  expr = proc (y,z) -> do
          x <- term -< y
          expr' -< x

Here the 'proc (y,z)' binding scopes over the arrow tails but not the
arrow body (e.g 'term').  As things stand (bogusly) all the
constraints from the proc body are gathered together, so constraints
from 'term' will be seen by the tcPat for (y,z).  But we must *not*
bind constraints from 'term' here, because the desugarer will not make
these bindings scope over 'term'.

The Right Thing is not to confuse these constraints together. But for
now the Easy Thing is to ensure that we do not have existential or
GADT constraints in a 'proc', and to short-cut the constraint
simplification for such vanilla patterns so that it binds no
constraints. Hence the 'fast path' in tcConPat; but it's also a good
plan for ordinary vanilla patterns to bypass the constraint
simplification step.

************************************************************************
*                                                                      *
                Note [Pattern coercions]
*                                                                      *
************************************************************************

In principle, these program would be reasonable:

        f :: (forall a. a->a) -> Int
        f (x :: Int->Int) = x 3

        g :: (forall a. [a]) -> Bool
        g [] = True

In both cases, the function type signature restricts what arguments can be passed
in a call (to polymorphic ones).  The pattern type signature then instantiates this
type.  For example, in the first case,  (forall a. a->a) <= Int -> Int, and we
generate the translated term
        f = \x' :: (forall a. a->a).  let x = x' Int in x 3

From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.
And it requires a significant amount of code to implement, because we need to decorate
the translated pattern with coercion functions (generated from the subsumption check
by tcSub).

So for now I'm just insisting on type *equality* in patterns.  No subsumption.

Old notes about desugaring, at a time when pattern coercions were handled:

A SigPat is a type coercion and must be handled one at at time.  We can't
combine them unless the type of the pattern inside is identical, and we don't
bother to check for that.  For example:

        data T = T1 Int | T2 Bool
        f :: (forall a. a -> a) -> T -> t
        f (g::Int->Int)   (T1 i) = T1 (g i)
        f (g::Bool->Bool) (T2 b) = T2 (g b)

We desugar this as follows:

        f = \ g::(forall a. a->a) t::T ->
            let gi = g Int
            in case t of { T1 i -> T1 (gi i)
                           other ->
            let gb = g Bool
            in case t of { T2 b -> T2 (gb b)
                           other -> fail }}

Note that we do not treat the first column of patterns as a
column of variables, because the coerced variables (gi, gb)
would be of different types.  So we get rather grotty code.
But I don't think this is a common case, and if it was we could
doubtless improve it.

Meanwhile, the strategy is:
        * treat each SigPat coercion (always non-identity coercions)
                as a separate block
        * deal with the stuff inside, and then wrap a binding round
                the result to bind the new variable (gi, gb, etc)

************************************************************************
*                                                                      *
\subsection{Errors and contexts}
*                                                                      *
************************************************************************

Note [Existential check]
~~~~~~~~~~~~~~~~~~~~~~~~
Lazy patterns can't bind existentials.  They arise in two ways:
  * Let bindings      let { C a b = e } in b
  * Twiddle patterns  f ~(C a b) = e
The pe_lazy field of PatEnv says whether we are inside a lazy
pattern (perhaps deeply)

See also Note [Typechecking pattern bindings] in TcBinds
-}

maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b
-- Not all patterns are worth pushing a context
maybeWrapPatCtxt pat tcm thing_inside
  | not (worth_wrapping pat) = tcm thing_inside
  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
                               -- Remember to pop before doing thing_inside
  where
   worth_wrapping (VarPat {}) = False
   worth_wrapping (ParPat {}) = False
   worth_wrapping (AsPat {})  = False
   worth_wrapping _           = True
   msg = hang (text "In the pattern:") 2 (ppr pat)

-----------------------------------------------
checkExistentials :: [TyVar]   -- existentials
                  -> [Type]    -- argument types
                  -> PatEnv -> TcM ()
    -- See Note [Existential check]]
    -- See Note [Arrows and patterns]
checkExistentials ex_tvs tys _
  | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return ()
checkExistentials _ _ (PE { pe_ctxt = LetPat {}})         = return ()
checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr })  = failWithTc existentialProcPat
checkExistentials _ _ (PE { pe_lazy = True })             = failWithTc existentialLazyPat
checkExistentials _ _ _                                   = return ()

existentialLazyPat :: SDoc
existentialLazyPat
  = hang (text "An existential or GADT data constructor cannot be used")
       2 (text "inside a lazy (~) pattern")

existentialProcPat :: SDoc
existentialProcPat
  = text "Proc patterns cannot use existential or GADT data constructors"

badFieldCon :: ConLike -> FieldLabelString -> SDoc
badFieldCon con field
  = hsep [text "Constructor" <+> quotes (ppr con),
          text "does not have field", quotes (ppr field)]

polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
  = hang (text "Illegal polymorphic type signature in pattern:")
       2 (ppr sig_ty)


{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[TcPatSyn]{Typechecking pattern synonym declarations}
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind
                , tcPatSynBuilderOcc, nonBidirectionalErr
  ) where

import GhcPrelude

import HsSyn
import TcPat
import Type( tidyTyCoVarBinders, tidyTypes, tidyType )
import TcRnMonad
import TcSigs( emptyPragEnv, completeSigFromId )
import TcEnv
import TcMType
import TcHsSyn
import TysPrim
import Name
import SrcLoc
import PatSyn
import NameSet
import Panic
import Outputable
import FastString
import Var
import VarEnv( emptyTidyEnv, mkInScopeSet )
import Id
import IdInfo( RecSelParent(..), setLevityInfoWithType )
import TcBinds
import BasicTypes
import TcSimplify
import TcUnify
import Type( PredTree(..), EqRel(..), classifyPredType )
import TysWiredIn
import TcType
import TcEvidence
import BuildTyCl
import VarSet
import MkId
import TcTyDecls
import ConLike
import FieldLabel
import Bag
import Util
import ErrUtils
import Data.Maybe( mapMaybe )
import Control.Monad ( zipWithM )
import Data.List( partition )

#include "HsVersions.h"

{-
************************************************************************
*                                                                      *
                    Type checking a pattern synonym
*                                                                      *
************************************************************************
-}

tcPatSynDecl :: PatSynBind GhcRn GhcRn
             -> Maybe TcSigInfo
             -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl psb mb_sig
  = recoverM (recoverPSB psb) $
    case mb_sig of
      Nothing                 -> tcInferPatSynDecl psb
      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
      _                       -> panic "tcPatSynDecl"

recoverPSB :: PatSynBind GhcRn GhcRn
           -> TcM (LHsBinds GhcTc, TcGblEnv)
-- See Note [Pattern synonym error recovery]
recoverPSB (PSB { psb_id = (dL->L _ name)
                , psb_args = details })
 = do { matcher_name <- newImplicitBinder name mkMatcherOcc
      ; let placeholder = AConLike $ PatSynCon $
                          mk_placeholder matcher_name
      ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
      ; return (emptyBag, gbl_env) }
  where
    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
    mk_placeholder matcher_name
      = mkPatSyn name is_infix
                        ([mkTyVarBinder Specified alphaTyVar], []) ([], [])
                        [] -- Arg tys
                        alphaTy
                        (matcher_id, True) Nothing
                        []  -- Field labels
       where
         -- The matcher_id is used only by the desugarer, so actually
         -- and error-thunk would probably do just as well here.
         matcher_id = mkLocalId matcher_name $
                      mkSpecForAllTys [alphaTyVar] alphaTy

recoverPSB (XPatSynBind {}) = panic "recoverPSB"

{- Note [Pattern synonym error recovery]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If type inference for a pattern synonym fails, we can't continue with
the rest of tc_patsyn_finish, because we may get knock-on errors, or
even a crash.  E.g. from
   pattern What = True :: Maybe
we get a kind error; and we must stop right away (Trac #15289).

We stop if there are /any/ unsolved constraints, not just insoluble
ones; because pattern synonyms are top-level things, we will never
solve them later if we can't solve them now.  And if we were to carry
on, tc_patsyn_finish does zonkTcTypeToType, which defaults any
unsolved unificatdion variables to Any, which confuses the error
reporting no end (Trac #15685).

So we use simplifyTop to completely solve the constraint, report
any errors, throw an exception.

Even in the event of such an error we can recover and carry on, just
as we do for value bindings, provided we plug in placeholder for the
pattern synonym: see recoverPSB.  The goal of the placeholder is not
to cause a raft of follow-on errors.  I've used the simplest thing for
now, but we might need to elaborate it a bit later.  (e.g.  I've given
it zero args, which may cause knock-on errors if it is used in a
pattern.) But it'll do for now.

-}

tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details
                       , psb_def = lpat, psb_dir = dir })
  = addPatSynCtxt lname $
    do { traceTc "tcInferPatSynDecl {" $ ppr name

       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
       ; (tclvl, wanted, ((lpat', args), pat_ty))
            <- pushLevelAndCaptureConstraints  $
               tcInferNoInst                   $ \ exp_ty ->
               tcPat PatSyn lpat exp_ty        $
               mapM tcLookupId arg_names

       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'

             named_taus = (name, pat_ty) : map mk_named_tau args
             mk_named_tau arg
               = (getName arg, mkSpecForAllTys ex_tvs (varType arg))
               -- The mkSpecForAllTys is important (Trac #14552), albeit
               -- slightly artifical (there is no variable with this funny type).
               -- We do not want to quantify over variable (alpha::k)
               -- that mention the existentially-bound type variables
               -- ex_tvs in its kind k.
               -- See Note [Type variables whose kind is captured]

       ; (univ_tvs, req_dicts, ev_binds, residual, _)
               <- simplifyInfer tclvl NoRestrictions [] named_taus wanted
       ; top_ev_binds <- checkNoErrs (simplifyTop residual)
       ; addTopEvBinds top_ev_binds $

    do { prov_dicts <- mapM zonkId prov_dicts
       ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
             -- Filtering: see Note [Remove redundant provided dicts]
             (prov_theta, prov_evs)
                 = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
             req_theta = map evVarPred req_dicts

       -- Report coercions that esacpe
       -- See Note [Coercions that escape]
       ; args <- mapM zonkId args
       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
                              , let bad_cos = filterDVarSet isId $
                                              (tyCoVarsOfTypeDSet (idType arg))
                              , not (isEmptyDVarSet bad_cos) ]
       ; mapM_ dependentArgErr bad_args

       ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (mkTyVarBinders Inferred univ_tvs
                            , req_theta,  ev_binds, req_dicts)
                          (mkTyVarBinders Inferred ex_tvs
                            , mkTyVarTys ex_tvs, prov_theta, prov_evs)
                          (map nlHsVar args, map idType args)
                          pat_ty rec_fields } }
tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"

mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
-- See Note [Equality evidence in pattern synonyms]
mkProvEvidence ev_id
  | EqPred r ty1 ty2 <- classifyPredType pred
  , let k1 = tcTypeKind ty1
        k2 = tcTypeKind ty2
        is_homo = k1 `tcEqType` k2
        homo_tys   = [k1, ty1, ty2]
        hetero_tys = [k1, k2, ty1, ty2]
  = case r of
      ReprEq | is_homo
             -> Just ( mkClassPred coercibleClass    homo_tys
                     , evDataConApp coercibleDataCon homo_tys eq_con_args )
             | otherwise -> Nothing
      NomEq  | is_homo
             -> Just ( mkClassPred eqClass    homo_tys
                     , evDataConApp eqDataCon homo_tys eq_con_args )
             | otherwise
             -> Just ( mkClassPred heqClass    hetero_tys
                     , evDataConApp heqDataCon hetero_tys eq_con_args )

  | otherwise
  = Just (pred, EvExpr (evId ev_id))
  where
    pred = evVarPred ev_id
    eq_con_args = [evId ev_id]

dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
-- See Note [Coercions that escape]
dependentArgErr (arg, bad_cos)
  = addErrTc $
    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
         , hang (text "Pattern-bound variable")
              2 (ppr arg <+> dcolon <+> ppr (idType arg))
         , nest 2 $
           hang (text "has a type that mentions pattern-bound coercion"
                 <> plural bad_co_list <> colon)
              2 (pprWithCommas ppr bad_co_list)
         , text "Hint: use -fprint-explicit-coercions to see the coercions"
         , text "Probable fix: add a pattern signature" ]
  where
    bad_co_list = dVarSetElems bad_cos

{- Note [Type variables whose kind is captured]
~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data AST a = Sym [a]
  class Prj s where { prj :: [a] -> Maybe (s a)
  pattern P x <= Sym (prj -> Just x)

Here we get a matcher with this type
  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r

No problem.  But note that 's' is not fixed by the type of the
pattern (AST a), nor is it existentially bound.  It's really only
fixed by the type of the continuation.

Trac #14552 showed that this can go wrong if the kind of 's' mentions
existentially bound variables.  We obviously can't make a type like
  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
                                   -> r -> r
But neither is 's' itself existentially bound, so the forall (s::k->*)
can't go in the inner forall either.  (What would the matcher apply
the continuation to?)

Solution: do not quantiify over any unification variable whose kind
mentions the existentials.  We can conveniently do that by making the
"taus" passed to simplifyInfer look like
   forall ex_tvs. arg_ty

After that, Note [Naughty quantification candidates] in TcMType takes
over, and zonks any such naughty variables to Any.

Note [Remove redundant provided dicts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that
   HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
                                       => a1 :~~: a2
(NB: technically the (k1~k2) existential dictionary is not necessary,
but it's there at the moment.)

Now consider (Trac #14394):
   pattern Foo = HRefl
in a non-poly-kinded module.  We don't want to get
    pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b
with that redundant (* ~ *).  We'd like to remove it; hence the call to
mkMinimalWithSCs.

Similarly consider
  data S a where { MkS :: Ord a => a -> S a }
  pattern Bam x y <- (MkS (x::a), MkS (y::a)))

The pattern (Bam x y) binds two (Ord a) dictionaries, but we only
need one.  Agian mkMimimalWithSCs removes the redundant one.

Note [Equality evidence in pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data X a where
     MkX :: Eq a => [a] -> X (Maybe a)
  pattern P x = MkG x

Then there is a danger that GHC will infer
  P :: forall a.  () =>
       forall b. (a ~# Maybe b, Eq b) => [b] -> X a

The 'builder' for P, which is called in user-code, will then
have type
  $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a

and that is bad because (a ~# Maybe b) is not a predicate type
(see Note [Types for coercions, predicates, and evidence] in Type)
and is not implicitly instantiated.

So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and
marginally less efficient, if the builder/martcher are not inlined.

See also Note [Lift equality constaints when quantifying] in TcType

Note [Coercions that escape]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trac #14507 showed an example where the inferred type of the matcher
for the pattern synonym was somethign like
   $mSO :: forall (r :: TYPE rep) kk (a :: k).
           TypeRep k a
           -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)
           -> (Void# -> r)
           -> r

What is that co_a2sv :: Bool ~# *??  It was bound (via a superclass
selection) by the pattern being matched; and indeed it is implicit in
the context (Bool ~ k).  You could imagine trying to extract it like
this:
   $mSO :: forall (r :: TYPE rep) kk (a :: k).
           TypeRep k a
           -> ( co :: ((Bool :: *) ~ (k :: *)) =>
                  let co_a2sv = sc_sel co
                  in TypeRep Bool (a |> co_a2sv) -> r)
           -> (Void# -> r)
           -> r

But we simply don't allow that in types.  Maybe one day but not now.

How to detect this situation?  We just look for free coercion variables
in the types of any of the arguments to the matcher.  The error message
is not very helpful, but at least we don't get a Lint error.
-}

tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
                  -> TcPatSynInfo
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details
                         , psb_def = lpat, psb_dir = dir }
                  TPSI{ patsig_implicit_bndrs = implicit_tvs
                      , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
                      , patsig_ex_bndrs   = explicit_ex_tvs,   patsig_req  = req_theta
                      , patsig_body_ty    = sig_body_ty }
  = addPatSynCtxt lname $
    do { let decl_arity = length arg_names
             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details

       ; traceTc "tcCheckPatSynDecl" $
         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]

       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
                                 Right stuff  -> return stuff
                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing

       -- Complain about:  pattern P :: () => forall x. x -> P x
       -- The existential 'x' should not appear in the result type
       -- Can't check this until we know P's arity
       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
       ; checkTc (null bad_tvs) $
         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
                   , text "namely" <+> quotes (ppr pat_ty) ])
            2 (text "mentions existential type variable" <> plural bad_tvs
               <+> pprQuotedList bad_tvs)

         -- See Note [The pattern-synonym signature splitting rule] in TcSigs
       ; let univ_fvs = closeOverKinds $
                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
             univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs
             ex_bndrs   = extra_ex   ++ mkTyVarBinders Specified explicit_ex_tvs
             univ_tvs   = binderVars univ_bndrs
             ex_tvs     = binderVars ex_bndrs

       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
       ; req_dicts <- newEvVars req_theta
       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
           pushLevelAndCaptureConstraints            $
           tcExtendTyVarEnv univ_tvs                 $
           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)
                    empty_subst = mkEmptyTCvSubst in_scope
              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
                    -- newMetaTyVarX: see the "Existential type variables"
                    -- part of Note [Checking against a pattern signature]
              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
              ; let prov_theta' = substTheta subst prov_theta
                  -- Add univ_tvs to the in_scope set to
                  -- satisfy the substitution invariant. There's no need to
                  -- add 'ex_tvs' as they are already in the domain of the
                  -- substitution.
                  -- See also Note [The substitution invariant] in TyCoRep.
              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
              ; return (ex_tvs', prov_dicts, args') }

       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
                         -- The type here is a bit bogus, but we do not print
                         -- the type for PatSynCtxt, so it doesn't matter
                         -- See TcRnTypes Note [Skolem info for pattern synonyms]
       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted

       -- Solve the constraints now, because we are about to make a PatSyn,
       -- which should not contain unification variables and the like (Trac #10997)
       ; simplifyTopImplic implics

       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
       -- Otherwise we may get a type error when typechecking the builder,
       -- when that should be impossible

       ; traceTc "tcCheckPatSynDecl }" $ ppr name
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_bndrs, req_theta, ev_binds, req_dicts)
                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
                          (args', arg_tys)
                          pat_ty rec_fields }
  where
    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)
    tc_arg subst arg_name arg_ty
      = do {   -- Look up the variable actually bound by lpat
               -- and check that it has the expected type
             arg_id <- tcLookupId arg_name
           ; wrap <- tcSubType_NC GenSigCtxt
                                 (idType arg_id)
                                 (substTyUnchecked subst arg_ty)
                -- Why do we need tcSubType here?
                -- See Note [Pattern synonyms and higher rank types]
           ; return (mkLHsWrap wrap $ nlHsVar arg_id) }
tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"

{- [Pattern synonyms and higher rank types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data T = MkT (forall a. a->a)

  pattern P :: (Int -> Int) -> T
  pattern P x <- MkT x

This should work.  But in the matcher we must match against MkT, and then
instantiate its argument 'x', to get a function of type (Int -> Int).
Equality is not enough!  Trac #13752 was an example.

Note [The pattern-synonym signature splitting rule]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given a pattern signature, we must split
     the kind-generalised variables, and
     the implicitly-bound variables
into universal and existential.  The rule is this
(see discussion on Trac #11224):

     The universal tyvars are the ones mentioned in
          - univ_tvs: the user-specified (forall'd) universals
          - req_theta
          - res_ty
     The existential tyvars are all the rest

For example

   pattern P :: () => b -> T a
   pattern P x = ...

Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:
how do we split the arg_tys from req_ty?  Consider

   pattern Q :: () => b -> S c -> T a
   pattern Q x = ...

This is an odd example because Q has only one syntactic argument, and
so presumably is defined by a view pattern matching a function.  But
it can happen (Trac #11977, #12108).

We don't know Q's arity from the pattern signature, so we have to wait
until we see the pattern declaration itself before deciding res_ty is,
and hence which variables are existential and which are universal.

And that in turn is why TcPatSynInfo has a separate field,
patsig_implicit_bndrs, to capture the implicitly bound type variables,
because we don't yet know how to split them up.

It's a slight compromise, because it means we don't really know the
pattern synonym's real signature until we see its declaration.  So,
for example, in hs-boot file, we may need to think what to do...
(eg don't have any implicitly-bound variables).

Note [Checking against a pattern signature]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When checking the actual supplied pattern against the pattern synonym
signature, we need to be quite careful.

----- Provided constraints
Example

    data T a where
      MkT :: Ord a => a -> T a

    pattern P :: () => Eq a => a -> [T a]
    pattern P x = [MkT x]

We must check that the (Eq a) that P claims to bind (and to
make available to matches against P), is derivable from the
actual pattern.  For example:
    f (P (x::a)) = ...here (Eq a) should be available...
And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.

----- Existential type variables
Unusually, we instantiate the existential tyvars of the pattern with
*meta* type variables.  For example

    data S where
      MkS :: Eq a => [a] -> S

    pattern P :: () => Eq x => x -> S
    pattern P x <- MkS x

The pattern synonym conceals from its client the fact that MkS has a
list inside it.  The client just thinks it's a type 'x'.  So we must
unify x := [a] during type checking, and then use the instantiating type
[a] (called ex_tys) when building the matcher.  In this case we'll get

   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
   $mP x k = case x of
               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
                                              dl = $dfunEqList d
                                          in k [a] dl ys

All this applies when type-checking the /matching/ side of
a pattern synonym.  What about the /building/ side?

* For Unidirectional, there is no builder

* For ExplicitBidirectional, the builder is completely separate
  code, typechecked in tcPatSynBuilderBind

* For ImplicitBidirectional, the builder is still typechecked in
  tcPatSynBuilderBind, by converting the pattern to an expression and
  typechecking it.

  At one point, for ImplicitBidirectional I used TyVarTvs (instead of
  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here
  is redundant since tcPatSynBuilderBind does the job, (b) it was
  still incomplete (TyVarTvs can unify with each other), and (c) it
  didn't even work (Trac #13441 was accepted with
  ExplicitBidirectional, but rejected if expressed in
  ImplicitBidirectional form.  Conclusion: trying to be too clever is
  a bad idea.
-}

collectPatSynArgInfo :: HsPatSynDetails (Located Name)
                     -> ([Name], [Name], Bool)
collectPatSynArgInfo details =
  case details of
    PrefixCon names      -> (map unLoc names, [], False)
    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
    RecCon names         -> (vars, sels, False)
                         where
                            (vars, sels) = unzip (map splitRecordPatSyn names)
  where
    splitRecordPatSyn :: RecordPatSynField (Located Name)
                      -> (Name, Name)
    splitRecordPatSyn (RecordPatSynField
                       { recordPatSynPatVar     = (dL->L _ patVar)
                       , recordPatSynSelectorId = (dL->L _ selId) })
      = (patVar, selId)

addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (dL->L loc name) thing_inside
  = setSrcSpan loc $
    addErrCtxt (text "In the declaration for pattern synonym"
                <+> quotes (ppr name)) $
    thing_inside

wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr name decl_arity missing
  = failWithTc $
    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
          <+> speakNOf decl_arity (text "argument"))
       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")

-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
                 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                 -> Bool              -- ^ Whether infix
                 -> LPat GhcTc        -- ^ Pattern of the PatSyn
                 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
                 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
                 -> ([LHsExpr GhcTcId], [TcType])   -- ^ Pattern arguments and
                                                    -- types
                 -> TcType            -- ^ Pattern type
                 -> [Name]            -- ^ Selector names
                 -- ^ Whether fields, empty if not record PatSyn
                 -> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish lname dir is_infix lpat'
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
                 (args, arg_tys)
                 pat_ty field_labels
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there

         (ze, univ_tvs') <- zonkTyVarBinders univ_tvs
       ; req_theta'      <- zonkTcTypesToTypesX ze req_theta
       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs
       ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta
       ; pat_ty'         <- zonkTcTypeToTypeX ze pat_ty
       ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys

       ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'
             (env2, ex_tvs)   = tidyTyCoVarBinders env1 ex_tvs'
             req_theta  = tidyTypes env2 req_theta'
             prov_theta = tidyTypes env2 prov_theta'
             arg_tys    = tidyTypes env2 arg_tys'
             pat_ty     = tidyType  env2 pat_ty'

       ; traceTc "tc_patsyn_finish {" $
           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
           ppr (ex_tvs, prov_theta, prov_dicts) $$
           ppr args $$
           ppr arg_tys $$
           ppr pat_ty

       -- Make the 'matcher'
       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
                                         (args, arg_tys)
                                         pat_ty

       -- Make the 'builder'
       ; builder_id <- mkPatSynBuilderId dir lname
                                         univ_tvs req_theta
                                         ex_tvs   prov_theta
                                         arg_tys pat_ty

         -- TODO: Make this have the proper information
       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
                                            , flIsOverloaded = False
                                            , flSelector = name }
             field_labels' = map mkFieldLabel field_labels

       -- Make the PatSyn itself
       ; let patSyn = mkPatSyn (unLoc lname) is_infix
                        (univ_tvs, req_theta)
                        (ex_tvs, prov_theta)
                        arg_tys
                        pat_ty
                        matcher_id builder_id
                        field_labels'

       -- Selectors
       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
             tything = AConLike (PatSynCon patSyn)
       ; tcg_env <- tcExtendGlobalEnv [tything] $
                    tcRecSelBinds rn_rec_sel_binds

       ; traceTc "tc_patsyn_finish }" empty
       ; return (matcher_bind, tcg_env) }

{-
************************************************************************
*                                                                      *
         Constructing the "matcher" Id and its binding
*                                                                      *
************************************************************************
-}

tcPatSynMatcher :: Located Name
                -> LPat GhcTc
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                -> ([LHsExpr GhcTcId], [TcType])
                -> TcType
                -> TcM ((Id, Bool), LHsBinds GhcTc)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
tcPatSynMatcher (dL->L loc name) lpat
                (univ_tvs, req_theta, req_ev_binds, req_dicts)
                (ex_tvs, ex_tys, prov_theta, prov_dicts)
                (args, arg_tys) pat_ty
  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc
       ; let rr_tv  = mkTyVar rr_name runtimeRepTy
             rr     = mkTyVarTy rr_tv
             res_tv = mkTyVar tv_name (tYPE rr)
             res_ty = mkTyVarTy res_tv
             is_unlifted = null args && null prov_dicts
             (cont_args, cont_arg_tys)
               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
               | otherwise   = (args,                 arg_tys)
             cont_ty = mkInfSigmaTy ex_tvs prov_theta $
                       mkVisFunTys cont_arg_tys res_ty

             fail_ty  = mkVisFunTy voidPrimTy res_ty

       ; matcher_name <- newImplicitBinder name mkMatcherOcc
       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty

       ; let matcher_tau   = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty
             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
                             -- See Note [Exported LocalIds] in Id

             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
             cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args

             fail' = nlHsApps fail [nlHsVar voidPrimId]

             args = map nlVarPat [scrutinee, cont, fail]
             lwpat = noLoc $ WildPat pat_ty
             cases = if isIrrefutableHsPat lpat
                     then [mkHsCaseAlt lpat  cont']
                     else [mkHsCaseAlt lpat  cont',
                           mkHsCaseAlt lwpat fail']
             body = mkLHsWrap (mkWpLet req_ev_binds) $
                    cL (getLoc lpat) $
                    HsCase noExt (nlHsVar scrutinee) $
                    MG{ mg_alts = cL (getLoc lpat) cases
                      , mg_ext = MatchGroupTc [pat_ty] res_ty
                      , mg_origin = Generated
                      }
             body' = noLoc $
                     HsLam noExt $
                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
                                                        args body]
                       , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty
                       , mg_origin = Generated
                       }
             match = mkMatch (mkPrefixFunRhs (cL loc name)) []
                             (mkHsLams (rr_tv:res_tv:univ_tvs)
                                       req_dicts body')
                             (noLoc (EmptyLocalBinds noExt))
             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
             mg = MG{ mg_alts = cL (getLoc match) [match]
                    , mg_ext = MatchGroupTc [] res_ty
                    , mg_origin = Generated
                    }

       ; let bind = FunBind{ fun_ext = emptyNameSet
                           , fun_id = cL loc matcher_id
                           , fun_matches = mg
                           , fun_co_fn = idHsWrapper
                           , fun_tick = [] }
             matcher_bind = unitBag (noLoc bind)

       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)

       ; return ((matcher_id, is_unlifted), matcher_bind) }

mkPatSynRecSelBinds :: PatSyn
                    -> [FieldLabel]  -- ^ Visible field labels
                    -> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds ps fields
  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
    | fld_lbl <- fields ]

isUnidirectional :: HsPatSynDir a -> Bool
isUnidirectional Unidirectional          = True
isUnidirectional ImplicitBidirectional   = False
isUnidirectional ExplicitBidirectional{} = False

{-
************************************************************************
*                                                                      *
         Constructing the "builder" Id
*                                                                      *
************************************************************************
-}

mkPatSynBuilderId :: HsPatSynDir a -> Located Name
                  -> [TyVarBinder] -> ThetaType
                  -> [TyVarBinder] -> ThetaType
                  -> [Type] -> Type
                  -> TcM (Maybe (Id, Bool))
mkPatSynBuilderId dir (dL->L _ name)
                  univ_bndrs req_theta ex_bndrs prov_theta
                  arg_tys pat_ty
  | isUnidirectional dir
  = return Nothing
  | otherwise
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
       ; let theta          = req_theta ++ prov_theta
             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
             builder_sigma  = add_void need_dummy_arg $
                              mkForAllTys univ_bndrs $
                              mkForAllTys ex_bndrs $
                              mkPhiTy theta $
                              mkVisFunTys arg_tys $
                              pat_ty
             builder_id     = mkExportedVanillaId builder_name builder_sigma
              -- See Note [Exported LocalIds] in Id

             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id

       ; return (Just (builder_id', need_dummy_arg)) }
  where

tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
                    -> TcM (LHsBinds GhcTc)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name)
                         , psb_def = lpat
                         , psb_dir = dir
                         , psb_args = details })
  | isUnidirectional dir
  = return emptyBag

  | Left why <- mb_match_group       -- Can't invert the pattern
  = setSrcSpan (getLoc lpat) $ failWithTc $
    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
                 <+> quotes (ppr name) <> colon)
              2 why
         , text "RHS pattern:" <+> ppr lpat ]

  | Right match_group <- mb_match_group  -- Bidirectional
  = do { patsyn <- tcLookupPatSyn name
       ; case patSynBuilder patsyn of {
           Nothing -> return emptyBag ;
             -- This case happens if we found a type error in the
             -- pattern synonym, recovered, and put a placeholder
             -- with patSynBuilder=Nothing in the environment

           Just (builder_id, need_dummy_arg) ->  -- Normal case
    do { -- Bidirectional, so patSynBuilder returns Just
         let match_group' | need_dummy_arg = add_dummy_arg match_group
                          | otherwise      = match_group

             bind = FunBind { fun_ext = placeHolderNamesTc
                            , fun_id      = cL loc (idName builder_id)
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , fun_tick    = [] }

             sig = completeSigFromId (PatSynCtxt name) builder_id

       ; traceTc "tcPatSynBuilderBind {" $
         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
       ; return builder_binds } } }

  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
  where
    mb_match_group
       = case dir of
           ExplicitBidirectional explicit_mg -> Right explicit_mg
           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
           Unidirectional -> panic "tcPatSynBuilderBind"

    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
    mk_mg body = mkMatchGroup Generated [builder_match]
          where
            builder_args  = [cL loc (VarPat noExt (cL loc n))
                            | (dL->L loc n) <- args]
            builder_match = mkMatch (mkPrefixFunRhs (cL loc name))
                                    builder_args body
                                    (noLoc (EmptyLocalBinds noExt))

    args = case details of
              PrefixCon args     -> args
              InfixCon arg1 arg2 -> [arg1, arg2]
              RecCon args        -> map recordPatSynPatVar args

    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
                  -> MatchGroup GhcRn (LHsExpr GhcRn)
    add_dummy_arg mg@(MG { mg_alts =
                           (dL->L l [dL->L loc
                                           match@(Match { m_pats = pats })]) })
      = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] }
    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
                             pprMatches other_mg
tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"

tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
-- monadic only for failure
tcPatSynBuilderOcc ps
  | Just (builder_id, add_void_arg) <- builder
  , let builder_expr = HsConLikeOut noExt (PatSynCon ps)
        builder_ty   = idType builder_id
  = return $
    if add_void_arg
    then ( builder_expr   -- still just return builder_expr; the void# arg is added
                          -- by dsConLike in the desugarer
         , tcFunResultTy builder_ty )
    else (builder_expr, builder_ty)

  | otherwise  -- Unidirectional
  = nonBidirectionalErr name
  where
    name    = patSynName ps
    builder = patSynBuilder ps

add_void :: Bool -> Type -> Type
add_void need_dummy_arg ty
  | need_dummy_arg = mkVisFunTy voidPrimTy ty
  | otherwise      = ty

tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
            -> Either MsgDoc (LHsExpr GhcRn)
-- Given a /pattern/, return an /expression/ that builds a value
-- that matches the pattern.  E.g. if the pattern is (Just [x]),
-- the expression is (Just [x]).  They look the same, but the
-- input uses constructors from HsPat and the output uses constructors
-- from HsExpr.
--
-- Returns (Left r) if the pattern is not invertible, for reason r.
-- See Note [Builder for a bidirectional pattern synonym]
tcPatToExpr name args pat = go pat
  where
    lhsVars = mkNameSet (map unLoc args)

    -- Make a prefix con for prefix and infix patterns for simplicity
    mkPrefixConExpr :: Located Name -> [LPat GhcRn]
                    -> Either MsgDoc (HsExpr GhcRn)
    mkPrefixConExpr lcon@(dL->L loc _) pats
      = do { exprs <- mapM go pats
           ; return (foldl' (\x y -> HsApp noExt (cL loc x) y)
                            (HsVar noExt lcon) exprs) }

    mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
                    -> Either MsgDoc (HsExpr GhcRn)
    mkRecordConExpr con fields
      = do { exprFields <- mapM go fields
           ; return (RecordCon noExt con exprFields) }

    go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
    go (dL->L loc p) = cL loc <$> go1 p

    go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
    go1 (ConPatIn con info)
      = case info of
          PrefixCon ps  -> mkPrefixConExpr con ps
          InfixCon l r  -> mkPrefixConExpr con [l,r]
          RecCon fields -> mkRecordConExpr con fields

    go1 (SigPat _ pat _) = go1 (unLoc pat)
        -- See Note [Type signatures and the builder expression]

    go1 (VarPat _ (dL->L l var))
        | var `elemNameSet` lhsVars
        = return $ HsVar noExt (cL l var)
        | otherwise
        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
    go1 (ParPat _ pat)          = fmap (HsPar noExt) $ go pat
    go1 p@(ListPat reb pats)
      | Nothing <- reb = do { exprs <- mapM go pats
                            ; return $ ExplicitList noExt Nothing exprs }
      | otherwise                   = notInvertibleListPat p
    go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats
                                         ; return $ ExplicitTuple noExt
                                           (map (noLoc . (Present noExt)) exprs)
                                                                           box }
    go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)
                                         ; return $ ExplicitSum noExt alt arity
                                                                   (noLoc expr)
                                         }
    go1 (LitPat _ lit)              = return $ HsLit noExt lit
    go1 (NPat _ (dL->L _ n) mb_neg _)
        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg
                                                     [noLoc (HsOverLit noExt n)]
        | otherwise                 = return $ HsOverLit noExt n
    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
    go1 (CoPat{})                   = panic "CoPat in output of renamer"
    go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                                    = go1 pat
    go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
    go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety"

    -- The following patterns are not invertible.
    go1 p@(BangPat {})                       = notInvertible p -- #14112
    go1 p@(LazyPat {})                       = notInvertible p
    go1 p@(WildPat {})                       = notInvertible p
    go1 p@(AsPat {})                         = notInvertible p
    go1 p@(ViewPat {})                       = notInvertible p
    go1 p@(NPlusKPat {})                     = notInvertible p
    go1 p@(XPat {})                          = notInvertible p
    go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p
    go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
    go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p
    go1 p@(SplicePat _ (XSplice {}))         = notInvertible p

    notInvertible p = Left (not_invertible_msg p)

    not_invertible_msg p
      =   text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
      $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
                <+> text "pattern synonym, e.g.")
             2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
                      <+> ppr pat <+> text "where")
                   2 (pp_name <+> pp_args <+> equals <+> text "..."))
      where
        pp_name = ppr name
        pp_args = hsep (map ppr args)

    -- We should really be able to invert list patterns, even when
    -- rebindable syntax is on, but doing so involves a bit of
    -- refactoring; see Trac #14380.  Until then we reject with a
    -- helpful error message.
    notInvertibleListPat p
      = Left (vcat [ not_invertible_msg p
                   , text "Reason: rebindable syntax is on."
                   , text "This is fixable: add use-case to Trac #14380" ])

{- Note [Builder for a bidirectional pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For a bidirectional pattern synonym we need to produce an /expression/
that matches the supplied /pattern/, given values for the arguments
of the pattern synonym.  For example
  pattern F x y = (Just x, [y])
The 'builder' for F looks like
  $builderF x y = (Just x, [y])

We can't always do this:
 * Some patterns aren't invertible; e.g. view patterns
      pattern F x = (reverse -> x:_)

 * The RHS pattern might bind more variables than the pattern
   synonym, so again we can't invert it
      pattern F x = (x,y)

 * Ditto wildcards
      pattern F x = (x,_)

Note [Redundant constraints for builder]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The builder can have redundant constraints, which are awkard to eliminate.
Consider
   pattern P = Just 34
To match against this pattern we need (Eq a, Num a).  But to build
(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
sig_warn_redundant to False.

************************************************************************
*                                                                      *
         Helper functions
*                                                                      *
************************************************************************

Note [As-patterns in pattern synonym definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The rationale for rejecting as-patterns in pattern synonym definitions
is that an as-pattern would introduce nonindependent pattern synonym
arguments, e.g. given a pattern synonym like:

        pattern K x y = x@(Just y)

one could write a nonsensical function like

        f (K Nothing x) = ...

or
        g (K (Just True) False) = ...

Note [Type signatures and the builder expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   pattern L x = Left x :: Either [a] [b]

In tc{Infer/Check}PatSynDecl we will check that the pattern has the
specified type.  We check the pattern *as a pattern*, so the type
signature is a pattern signature, and so brings 'a' and 'b' into
scope.  But we don't have a way to bind 'a, b' in the LHS, as we do
'x', say.  Nevertheless, the sigature may be useful to constrain
the type.

When making the binding for the *builder*, though, we don't want
  $buildL x = Left x :: Either [a] [b]
because that wil either mean (forall a b. Either [a] [b]), or we'll
get a complaint that 'a' and 'b' are out of scope. (Actually the
latter; Trac #9867.)  No, the job of the signature is done, so when
converting the pattern to an expression (for the builder RHS) we
simply discard the signature.

Note [Record PatSyn Desugaring]
-------------------------------
It is important that prov_theta comes before req_theta as this ordering is used
when desugaring record pattern synonym updates.

Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
want to avoid difficult to decipher core lint errors!
 -}

nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
    text "non-bidirectional pattern synonym"
    <+> quotes (ppr name) <+> text "used in an expression"

-- Walk the whole pattern and for all ConPatOuts, collect the
-- existentially-bound type variables and evidence binding variables.
--
-- These are used in computing the type of a pattern synonym and also
-- in generating matcher functions, since success continuations need
-- to be passed these pattern-bound evidences.
tcCollectEx
  :: LPat GhcTc
  -> ( [TyVar]        -- Existentially-bound type variables
                      -- in correctly-scoped order; e.g. [ k:*, x:k ]
     , [EvVar] )      -- and evidence variables

tcCollectEx pat = go pat
  where
    go :: LPat GhcTc -> ([TyVar], [EvVar])
    go = go1 . unLoc

    go1 :: Pat GhcTc -> ([TyVar], [EvVar])
    go1 (LazyPat _ p)      = go p
    go1 (AsPat _ _ p)      = go p
    go1 (ParPat _ p)       = go p
    go1 (BangPat _ p)      = go p
    go1 (ListPat _ ps)     = mergeMany . map go $ ps
    go1 (TuplePat _ ps _)  = mergeMany . map go $ ps
    go1 (SumPat _ p _ _)   = go p
    go1 (ViewPat _ _ p)    = go p
    go1 con@ConPatOut{}    = merge (pat_tvs con, pat_dicts con) $
                              goConDetails $ pat_args con
    go1 (SigPat _ p _)     = go p
    go1 (CoPat _ _ p _)    = go1 p
    go1 (NPlusKPat _ n k _ geq subtract)
      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
    go1 _                   = empty

    goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
    goConDetails (PrefixCon ps) = mergeMany . map go $ ps
    goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
    goConDetails (RecCon HsRecFields{ rec_flds = flds })
      = mergeMany . map goRecFd $ flds

    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
    goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p

    merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)
    mergeMany = foldr merge empty
    empty     = ([], [])