{-
(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 :: PatSynBind GhcRn GhcRn
-> Maybe TcSigInfo -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl psb :: PatSynBind GhcRn GhcRn
psb mb_sig :: Maybe TcSigInfo
mb_sig
  = TcM (LHsBinds GhcTc, TcGblEnv)
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
recoverPSB PatSynBind GhcRn GhcRn
psb) (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    case Maybe TcSigInfo
mb_sig of
      Nothing                 -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl PatSynBind GhcRn GhcRn
psb
      Just (TcPatSynSig tpsi :: TcPatSynInfo
tpsi) -> PatSynBind GhcRn GhcRn
-> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl PatSynBind GhcRn GhcRn
psb TcPatSynInfo
tpsi
      _                       -> String -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. String -> a
panic "tcPatSynDecl"

recoverPSB :: PatSynBind GhcRn GhcRn
           -> TcM (LHsBinds GhcTc, TcGblEnv)
-- See Note [Pattern synonym error recovery]
recoverPSB :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
recoverPSB (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> Located (IdP idL)
psb_id = (Located (IdP GhcRn) -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ name :: SrcSpanLess (Located Name)
name)
                , psb_args :: forall idL idR.
PatSynBind idL idR -> HsPatSynDetails (Located (IdP idR))
psb_args = HsPatSynDetails (Located (IdP GhcRn))
details })
 = do { Name
matcher_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
SrcSpanLess (Located Name)
name OccName -> OccName
mkMatcherOcc
      ; let placeholder :: TyThing
placeholder = ConLike -> TyThing
AConLike (ConLike -> TyThing) -> ConLike -> TyThing
forall a b. (a -> b) -> a -> b
$ PatSyn -> ConLike
PatSynCon (PatSyn -> ConLike) -> PatSyn -> ConLike
forall a b. (a -> b) -> a -> b
$
                          Name -> PatSyn
mk_placeholder Name
matcher_name
      ; TcGblEnv
gbl_env <- [TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
placeholder] TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcTc
forall a. Bag a
emptyBag, TcGblEnv
gbl_env) }
  where
    (_arg_names :: [Name]
_arg_names, _rec_fields :: [Name]
_rec_fields, is_infix :: Bool
is_infix) = HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
collectPatSynArgInfo HsPatSynDetails (Located Name)
HsPatSynDetails (Located (IdP GhcRn))
details
    mk_placeholder :: Name -> PatSyn
mk_placeholder matcher_name :: Name
matcher_name
      = Name
-> Bool
-> ([TyVarBinder], ThetaType)
-> ([TyVarBinder], ThetaType)
-> ThetaType
-> Type
-> (Id, Bool)
-> Maybe (Id, Bool)
-> [FieldLabel]
-> PatSyn
mkPatSyn Name
SrcSpanLess (Located Name)
name Bool
is_infix
                        ([ArgFlag -> Id -> TyVarBinder
mkTyVarBinder ArgFlag
Specified Id
alphaTyVar], []) ([], [])
                        [] -- Arg tys
                        Type
alphaTy
                        (Id
matcher_id, Bool
True) Maybe (Id, Bool)
forall a. Maybe a
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 :: Id
matcher_id = Name -> Type -> Id
mkLocalId Name
matcher_name (Type -> Id) -> Type -> Id
forall a b. (a -> b) -> a -> b
$
                      [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] Type
alphaTy

recoverPSB (XPatSynBind {}) = String -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. String -> a
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 :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> Located (IdP idL)
psb_id = lname :: Located (IdP GhcRn)
lname@(Located (IdP GhcRn) -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ name :: SrcSpanLess (Located Name)
name), psb_args :: forall idL idR.
PatSynBind idL idR -> HsPatSynDetails (Located (IdP idR))
psb_args = HsPatSynDetails (Located (IdP GhcRn))
details
                       , psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir })
  = Located Name
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. Located Name -> TcM a -> TcM a
addPatSynCtxt Located Name
Located (IdP GhcRn)
lname (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRn ()
traceTc "tcInferPatSynDecl {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
SrcSpanLess (Located Name)
name

       ; let (arg_names :: [Name]
arg_names, rec_fields :: [Name]
rec_fields, is_infix :: Bool
is_infix) = HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
collectPatSynArgInfo HsPatSynDetails (Located Name)
HsPatSynDetails (Located (IdP GhcRn))
details
       ; (tclvl :: TcLevel
tclvl, wanted :: WantedConstraints
wanted, ((lpat' :: LPat GhcTc
lpat', args :: [Id]
args), pat_ty :: Type
pat_ty))
            <- TcM ((LPat GhcTc, [Id]), Type)
-> TcM (TcLevel, WantedConstraints, ((LPat GhcTc, [Id]), Type))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints  (TcM ((LPat GhcTc, [Id]), Type)
 -> TcM (TcLevel, WantedConstraints, ((LPat GhcTc, [Id]), Type)))
-> TcM ((LPat GhcTc, [Id]), Type)
-> TcM (TcLevel, WantedConstraints, ((LPat GhcTc, [Id]), Type))
forall a b. (a -> b) -> a -> b
$
               (ExpSigmaType -> TcM (LPat GhcTc, [Id]))
-> TcM ((LPat GhcTc, [Id]), Type)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, Type)
tcInferNoInst                   ((ExpSigmaType -> TcM (LPat GhcTc, [Id]))
 -> TcM ((LPat GhcTc, [Id]), Type))
-> (ExpSigmaType -> TcM (LPat GhcTc, [Id]))
-> TcM ((LPat GhcTc, [Id]), Type)
forall a b. (a -> b) -> a -> b
$ \ exp_ty :: ExpSigmaType
exp_ty ->
               HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcM [Id] -> TcM (LPat GhcTc, [Id])
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcM a -> TcM (LPat GhcTc, a)
tcPat HsMatchContext Name
forall id. HsMatchContext id
PatSyn LPat GhcRn
lpat ExpSigmaType
exp_ty        (TcM [Id] -> TcM (LPat GhcTc, [Id]))
-> TcM [Id] -> TcM (LPat GhcTc, [Id])
forall a b. (a -> b) -> a -> b
$
               (Name -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Name] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId [Name]
arg_names

       ; let (ex_tvs :: [Id]
ex_tvs, prov_dicts :: [Id]
prov_dicts) = LPat GhcTc -> ([Id], [Id])
tcCollectEx LPat GhcTc
lpat'

             named_taus :: [(Name, Type)]
named_taus = (Name
SrcSpanLess (Located Name)
name, Type
pat_ty) (Name, Type) -> [(Name, Type)] -> [(Name, Type)]
forall a. a -> [a] -> [a]
: (Id -> (Name, Type)) -> [Id] -> [(Name, Type)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> (Name, Type)
mk_named_tau [Id]
args
             mk_named_tau :: Id -> (Name, Type)
mk_named_tau arg :: Id
arg
               = (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
arg, [Id] -> Type -> Type
mkSpecForAllTys [Id]
ex_tvs (Id -> Type
varType Id
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 :: [Id]
univ_tvs, req_dicts :: [Id]
req_dicts, ev_binds :: TcEvBinds
ev_binds, residual :: WantedConstraints
residual, _)
               <- TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Type)]
-> WantedConstraints
-> TcM ([Id], [Id], TcEvBinds, WantedConstraints, Bool)
simplifyInfer TcLevel
tclvl InferMode
NoRestrictions [] [(Name, Type)]
named_taus WantedConstraints
wanted
       ; Bag EvBind
top_ev_binds <- TcM (Bag EvBind) -> TcM (Bag EvBind)
forall r. TcM r -> TcM r
checkNoErrs (WantedConstraints -> TcM (Bag EvBind)
simplifyTop WantedConstraints
residual)
       ; Bag EvBind
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
top_ev_binds (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$

    do { [Id]
prov_dicts <- (Id -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Id] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
zonkId [Id]
prov_dicts
       ; let filtered_prov_dicts :: [Id]
filtered_prov_dicts = (Id -> Type) -> [Id] -> [Id]
forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs Id -> Type
evVarPred [Id]
prov_dicts
             -- Filtering: see Note [Remove redundant provided dicts]
             (prov_theta :: ThetaType
prov_theta, prov_evs :: [EvTerm]
prov_evs)
                 = [(Type, EvTerm)] -> (ThetaType, [EvTerm])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Id -> Maybe (Type, EvTerm)) -> [Id] -> [(Type, EvTerm)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Id -> Maybe (Type, EvTerm)
mkProvEvidence [Id]
filtered_prov_dicts)
             req_theta :: ThetaType
req_theta = (Id -> Type) -> [Id] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
evVarPred [Id]
req_dicts

       -- Report coercions that esacpe
       -- See Note [Coercions that escape]
       ; [Id]
args <- (Id -> IOEnv (Env TcGblEnv TcLclEnv) Id) -> [Id] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
zonkId [Id]
args
       ; let bad_args :: [(Id, DVarSet)]
bad_args = [ (Id
arg, DVarSet
bad_cos) | Id
arg <- [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
prov_dicts
                              , let bad_cos :: DVarSet
bad_cos = (Id -> Bool) -> DVarSet -> DVarSet
filterDVarSet Id -> Bool
isId (DVarSet -> DVarSet) -> DVarSet -> DVarSet
forall a b. (a -> b) -> a -> b
$
                                              (Type -> DVarSet
tyCoVarsOfTypeDSet (Id -> Type
idType Id
arg))
                              , Bool -> Bool
not (DVarSet -> Bool
isEmptyDVarSet DVarSet
bad_cos) ]
       ; ((Id, DVarSet) -> TcRn ()) -> [(Id, DVarSet)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Id, DVarSet) -> TcRn ()
dependentArgErr [(Id, DVarSet)]
bad_args

       ; String -> SDoc -> TcRn ()
traceTc "tcInferPatSynDecl }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
SrcSpanLess (Located Name)
name SDoc -> SDoc -> SDoc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
ex_tvs)
       ; Located Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> ([TyVarBinder], ThetaType, TcEvBinds, [Id])
-> ([TyVarBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [Name]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish Located Name
Located (IdP GhcRn)
lname HsPatSynDir GhcRn
dir Bool
is_infix LPat GhcTc
lpat'
                          (ArgFlag -> [Id] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Inferred [Id]
univ_tvs
                            , ThetaType
req_theta,  TcEvBinds
ev_binds, [Id]
req_dicts)
                          (ArgFlag -> [Id] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Inferred [Id]
ex_tvs
                            , [Id] -> ThetaType
mkTyVarTys [Id]
ex_tvs, ThetaType
prov_theta, [EvTerm]
prov_evs)
                          ((Id -> LHsExpr GhcTc) -> [Id] -> [LHsExpr GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [Id]
args, (Id -> Type) -> [Id] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
args)
                          Type
pat_ty [Name]
rec_fields } }
tcInferPatSynDecl (XPatSynBind _) = String -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. String -> a
panic "tcInferPatSynDecl"

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

  | Bool
otherwise
  = (Type, EvTerm) -> Maybe (Type, EvTerm)
forall a. a -> Maybe a
Just (Type
pred, EvExpr -> EvTerm
EvExpr (Id -> EvExpr
evId Id
ev_id))
  where
    pred :: Type
pred = Id -> Type
evVarPred Id
ev_id
    eq_con_args :: [EvExpr]
eq_con_args = [Id -> EvExpr
evId Id
ev_id]

dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
-- See Note [Coercions that escape]
dependentArgErr :: (Id, DVarSet) -> TcRn ()
dependentArgErr (arg :: Id
arg, bad_cos :: DVarSet
bad_cos)
  = SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
vcat [ String -> SDoc
text "Iceland Jack!  Iceland Jack! Stop torturing me!"
         , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Pattern-bound variable")
              2 (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
arg SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
arg))
         , Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "has a type that mentions pattern-bound coercion"
                 SDoc -> SDoc -> SDoc
<> [Id] -> SDoc
forall a. [a] -> SDoc
plural [Id]
bad_co_list SDoc -> SDoc -> SDoc
<> SDoc
colon)
              2 ((Id -> SDoc) -> [Id] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bad_co_list)
         , String -> SDoc
text "Hint: use -fprint-explicit-coercions to see the coercions"
         , String -> SDoc
text "Probable fix: add a pattern signature" ]
  where
    bad_co_list :: [Id]
bad_co_list = DVarSet -> [Id]
dVarSetElems DVarSet
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 :: PatSynBind GhcRn GhcRn
-> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl psb :: PatSynBind GhcRn GhcRn
psb@PSB{ psb_id :: forall idL idR. PatSynBind idL idR -> Located (IdP idL)
psb_id = lname :: Located (IdP GhcRn)
lname@(Located (IdP GhcRn) -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ name :: SrcSpanLess (Located Name)
name), psb_args :: forall idL idR.
PatSynBind idL idR -> HsPatSynDetails (Located (IdP idR))
psb_args = HsPatSynDetails (Located (IdP GhcRn))
details
                         , psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat, psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir }
                  TPSI{ patsig_implicit_bndrs :: TcPatSynInfo -> [TyVarBinder]
patsig_implicit_bndrs = [TyVarBinder]
implicit_tvs
                      , patsig_univ_bndrs :: TcPatSynInfo -> [Id]
patsig_univ_bndrs = [Id]
explicit_univ_tvs, patsig_prov :: TcPatSynInfo -> ThetaType
patsig_prov = ThetaType
prov_theta
                      , patsig_ex_bndrs :: TcPatSynInfo -> [Id]
patsig_ex_bndrs   = [Id]
explicit_ex_tvs,   patsig_req :: TcPatSynInfo -> ThetaType
patsig_req  = ThetaType
req_theta
                      , patsig_body_ty :: TcPatSynInfo -> Type
patsig_body_ty    = Type
sig_body_ty }
  = Located Name
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. Located Name -> TcM a -> TcM a
addPatSynCtxt Located Name
Located (IdP GhcRn)
lname (TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv))
-> TcM (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a b. (a -> b) -> a -> b
$
    do { let decl_arity :: Int
decl_arity = [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
arg_names
             (arg_names :: [Name]
arg_names, rec_fields :: [Name]
rec_fields, is_infix :: Bool
is_infix) = HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
collectPatSynArgInfo HsPatSynDetails (Located Name)
HsPatSynDetails (Located (IdP GhcRn))
details

       ; String -> SDoc -> TcRn ()
traceTc "tcCheckPatSynDecl" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ [TyVarBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVarBinder]
implicit_tvs, [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
explicit_univ_tvs, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
req_theta
              , [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
explicit_ex_tvs, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
prov_theta, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sig_body_ty ]

       ; (arg_tys :: ThetaType
arg_tys, pat_ty :: Type
pat_ty) <- case Int -> Type -> Either Int (ThetaType, Type)
tcSplitFunTysN Int
decl_arity Type
sig_body_ty of
                                 Right stuff :: (ThetaType, Type)
stuff  -> (ThetaType, Type)
-> IOEnv (Env TcGblEnv TcLclEnv) (ThetaType, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (ThetaType, Type)
stuff
                                 Left missing :: Int
missing -> Name
-> Int -> Int -> IOEnv (Env TcGblEnv TcLclEnv) (ThetaType, Type)
forall a. Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr Name
SrcSpanLess (Located Name)
name Int
decl_arity Int
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 :: [Id]
bad_tvs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
pat_ty) [Id]
explicit_ex_tvs
       ; Bool -> SDoc -> TcRn ()
checkTc ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bad_tvs) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
sep [ String -> SDoc
text "The result type of the signature for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
SrcSpanLess (Located Name)
name) SDoc -> SDoc -> SDoc
<> SDoc
comma
                   , String -> SDoc
text "namely" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pat_ty) ])
            2 (String -> SDoc
text "mentions existential type variable" SDoc -> SDoc -> SDoc
<> [Id] -> SDoc
forall a. [a] -> SDoc
plural [Id]
bad_tvs
               SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Id]
bad_tvs)

         -- See Note [The pattern-synonym signature splitting rule] in TcSigs
       ; let univ_fvs :: VarSet
univ_fvs = VarSet -> VarSet
closeOverKinds (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
                        (ThetaType -> VarSet
tyCoVarsOfTypes (Type
pat_ty Type -> ThetaType -> ThetaType
forall a. a -> [a] -> [a]
: ThetaType
req_theta) VarSet -> [Id] -> VarSet
`extendVarSetList` [Id]
explicit_univ_tvs)
             (extra_univ :: [TyVarBinder]
extra_univ, extra_ex :: [TyVarBinder]
extra_ex) = (TyVarBinder -> Bool)
-> [TyVarBinder] -> ([TyVarBinder], [TyVarBinder])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Id -> VarSet -> Bool
`elemVarSet` VarSet
univ_fvs) (Id -> Bool) -> (TyVarBinder -> Id) -> TyVarBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar) [TyVarBinder]
implicit_tvs
             univ_bndrs :: [TyVarBinder]
univ_bndrs = [TyVarBinder]
extra_univ [TyVarBinder] -> [TyVarBinder] -> [TyVarBinder]
forall a. [a] -> [a] -> [a]
++ ArgFlag -> [Id] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Specified [Id]
explicit_univ_tvs
             ex_bndrs :: [TyVarBinder]
ex_bndrs   = [TyVarBinder]
extra_ex   [TyVarBinder] -> [TyVarBinder] -> [TyVarBinder]
forall a. [a] -> [a] -> [a]
++ ArgFlag -> [Id] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Specified [Id]
explicit_ex_tvs
             univ_tvs :: [Id]
univ_tvs   = [TyVarBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
univ_bndrs
             ex_tvs :: [Id]
ex_tvs     = [TyVarBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
ex_bndrs

       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
       ; [Id]
req_dicts <- ThetaType -> TcM [Id]
newEvVars ThetaType
req_theta
       ; (tclvl :: TcLevel
tclvl, wanted :: WantedConstraints
wanted, (lpat' :: LPat GhcTc
lpat', (ex_tvs' :: [Id]
ex_tvs', prov_dicts :: [EvTerm]
prov_dicts, args' :: [LHsExpr GhcTc]
args'))) <-
           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
           TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcLevel, WantedConstraints,
      (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc])))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints            (TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (TcLevel, WantedConstraints,
       (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))))
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcLevel, WantedConstraints,
      (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc])))
forall a b. (a -> b) -> a -> b
$
           [Id]
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
forall r. [Id] -> TcM r -> TcM r
tcExtendTyVarEnv [Id]
univ_tvs                 (TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
 -> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc])))
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
forall a b. (a -> b) -> a -> b
$
           [(Name, TcTyThing)]
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [(Id -> Name
forall a. NamedThing a => a -> Name
getName (TyVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
ex_tv), PromotionErr -> TcTyThing
APromotionErr PromotionErr
PatSynExPE)
                               | TyVarBinder
ex_tv <- [TyVarBinder]
extra_ex] (TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
 -> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc])))
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
forall a b. (a -> b) -> a -> b
$
               -- See Note [Pattern synonym existentials do not scope]
           HsMatchContext Name
-> LPat GhcRn
-> ExpSigmaType
-> TcM ([Id], [EvTerm], [LHsExpr GhcTc])
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
forall a.
HsMatchContext Name
-> LPat GhcRn -> ExpSigmaType -> TcM a -> TcM (LPat GhcTc, a)
tcPat HsMatchContext Name
forall id. HsMatchContext id
PatSyn LPat GhcRn
lpat (Type -> ExpSigmaType
mkCheckExpType Type
pat_ty) (TcM ([Id], [EvTerm], [LHsExpr GhcTc])
 -> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc])))
-> TcM ([Id], [EvTerm], [LHsExpr GhcTc])
-> TcM (LPat GhcTc, ([Id], [EvTerm], [LHsExpr GhcTc]))
forall a b. (a -> b) -> a -> b
$
           do { let in_scope :: InScopeSet
in_scope    = VarSet -> InScopeSet
mkInScopeSet ([Id] -> VarSet
mkVarSet [Id]
univ_tvs)
                    empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
              ; (subst :: TCvSubst
subst, ex_tvs' :: [Id]
ex_tvs') <- (TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id))
-> TCvSubst
-> [Id]
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, [Id])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
newMetaTyVarX TCvSubst
empty_subst [Id]
ex_tvs
                    -- newMetaTyVarX: see the "Existential type variables"
                    -- part of Note [Checking against a pattern signature]
              ; String -> SDoc -> TcRn ()
traceTc "tcpatsyn1" ([SDoc] -> SDoc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs])
              ; String -> SDoc -> TcRn ()
traceTc "tcpatsyn2" ([SDoc] -> SDoc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
tyVarKind Id
v) | Id
v <- [Id]
ex_tvs'])
              ; let prov_theta' :: ThetaType
prov_theta' = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta TCvSubst
subst ThetaType
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.
              ; [EvTerm]
prov_dicts <- (Type -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm)
-> ThetaType -> IOEnv (Env TcGblEnv TcLclEnv) [EvTerm]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CtOrigin -> Type -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm
emitWanted (PatSynBind GhcRn GhcRn -> CtOrigin
ProvCtxtOrigin PatSynBind GhcRn GhcRn
psb)) ThetaType
prov_theta'
              ; [LHsExpr GhcTc]
args'      <- (Name -> Type -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc))
-> [Name]
-> ThetaType
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTc]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TCvSubst
-> Name -> Type -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc)
tc_arg TCvSubst
subst) [Name]
arg_names ThetaType
arg_tys
              ; ([Id], [EvTerm], [LHsExpr GhcTc])
-> TcM ([Id], [EvTerm], [LHsExpr GhcTc])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ex_tvs', [EvTerm]
prov_dicts, [LHsExpr GhcTc]
args') }

       ; let skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> Type -> [(Name, Id)] -> SkolemInfo
SigSkol (Name -> UserTypeCtxt
PatSynCtxt Name
SrcSpanLess (Located Name)
name) Type
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 :: Bag Implication
implics, ev_binds :: TcEvBinds
ev_binds) <- TcLevel
-> SkolemInfo
-> [Id]
-> [Id]
-> WantedConstraints
-> TcM (Bag Implication, TcEvBinds)
buildImplicationFor TcLevel
tclvl SkolemInfo
skol_info [Id]
univ_tvs [Id]
req_dicts WantedConstraints
wanted

       -- Solve the constraints now, because we are about to make a PatSyn,
       -- which should not contain unification variables and the like (Trac #10997)
       ; Bag Implication -> TcRn ()
simplifyTopImplic Bag Implication
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

       ; String -> SDoc -> TcRn ()
traceTc "tcCheckPatSynDecl }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
SrcSpanLess (Located Name)
name
       ; Located Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> ([TyVarBinder], ThetaType, TcEvBinds, [Id])
-> ([TyVarBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [Name]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish Located Name
Located (IdP GhcRn)
lname HsPatSynDir GhcRn
dir Bool
is_infix LPat GhcTc
lpat'
                          ([TyVarBinder]
univ_bndrs, ThetaType
req_theta, TcEvBinds
ev_binds, [Id]
req_dicts)
                          ([TyVarBinder]
ex_bndrs, [Id] -> ThetaType
mkTyVarTys [Id]
ex_tvs', ThetaType
prov_theta, [EvTerm]
prov_dicts)
                          ([LHsExpr GhcTc]
args', ThetaType
arg_tys)
                          Type
pat_ty [Name]
rec_fields }
  where
    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)
    tc_arg :: TCvSubst
-> Name -> Type -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc)
tc_arg subst :: TCvSubst
subst arg_name :: Name
arg_name arg_ty :: Type
arg_ty
      = do {   -- Look up the variable actually bound by lpat
               -- and check that it has the expected type
             Id
arg_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId Name
arg_name
           ; HsWrapper
wrap <- UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubType_NC UserTypeCtxt
GenSigCtxt
                                 (Id -> Type
idType Id
arg_id)
                                 (TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst Type
arg_ty)
                -- Why do we need tcSubType here?
                -- See Note [Pattern synonyms and higher rank types]
           ; LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
arg_id) }
tcCheckPatSynDecl (XPatSynBind _) _ = String -> TcM (LHsBinds GhcTc, TcGblEnv)
forall a. String -> a
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 [Pattern synonym existentials do not scope]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (Trac #14498):
  pattern SS :: forall (t :: k). () =>
                => forall (a :: kk -> k) (n :: kk).
                => TypeRep n -> TypeRep t
  pattern SS n <- (App (Typeable :: TypeRep (a::kk -> k)) n)

Here 'k' is implicitly bound in the signature, but (with
-XScopedTypeVariables) it does still scope over the pattern-synonym
definition.  But what about 'kk', which is oexistential?  It too is
implicitly bound in the signature; should it too scope?  And if so,
what type variable is it bound to?

The trouble is that the type variable to which it is bound is itself
only brought into scope in part the pattern, so it makes no sense for
'kk' to scope over the whole pattern.  See the discussion on
Trac #14498, esp comment:16ff. Here is a simpler example:
  data T where { MkT :: x -> (x->Int) -> T }
  pattern P :: () => forall x. x -> (x->Int) -> T
  pattern P a b = (MkT a b, True)

Here it would make no sense to mention 'x' in the True pattern,
like this:
  pattern P a b = (MkT a b, True :: x)

The 'x' only makes sense "under" the MkT pattern. Conclusion: the
existential type variables of a pattern-synonym signature should not
scope.

But it's not that easy to implement, because we don't know
exactly what the existentials /are/ until we get to type checking.
(See Note [The pattern-synonym signature splitting rule], and
the partition of implicit_tvs in tcCheckPatSynDecl.)

So we do this:

- The reaner brings all the implicitly-bound kind variables into
  scope, without trying to distinguish universal from existential

- tcCheckPatSynDecl uses tcExtendKindEnvList to bind the
  implicitly-bound existentials to
      APromotionErr PatSynExPE
  It's not really a promotion error, but it's a way to bind the Name
  (which the renamer has not complained about) to something that, when
  looked up, will cause a complaint (in this case
  TcHsType.promotionErr)


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 :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
collectPatSynArgInfo details :: HsPatSynDetails (Located Name)
details =
  case HsPatSynDetails (Located Name)
details of
    PrefixCon names :: [Located Name]
names      -> ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located Name]
names, [], Bool
False)
    InfixCon name1 :: Located Name
name1 name2 :: Located Name
name2 -> ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located Name
name1, Located Name
name2], [], Bool
True)
    RecCon names :: [RecordPatSynField (Located Name)]
names         -> ([Name]
vars, [Name]
sels, Bool
False)
                         where
                            (vars :: [Name]
vars, sels :: [Name]
sels) = [(Name, Name)] -> ([Name], [Name])
forall a b. [(a, b)] -> ([a], [b])
unzip ((RecordPatSynField (Located Name) -> (Name, Name))
-> [RecordPatSynField (Located Name)] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField (Located Name) -> (Name, Name)
splitRecordPatSyn [RecordPatSynField (Located Name)]
names)
  where
    splitRecordPatSyn :: RecordPatSynField (Located Name)
                      -> (Name, Name)
    splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
splitRecordPatSyn (RecordPatSynField
                       { recordPatSynPatVar :: forall a. RecordPatSynField a -> a
recordPatSynPatVar     = (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ patVar :: SrcSpanLess (Located Name)
patVar)
                       , recordPatSynSelectorId :: forall a. RecordPatSynField a -> a
recordPatSynSelectorId = (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ selId :: SrcSpanLess (Located Name)
selId) })
      = (Name
SrcSpanLess (Located Name)
patVar, Name
SrcSpanLess (Located Name)
selId)

addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc name :: SrcSpanLess (Located Name)
name) thing_inside :: TcM a
thing_inside
  = SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text "In the declaration for pattern synonym"
                SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
SrcSpanLess (Located Name)
name)) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    TcM a
thing_inside

wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr :: Name -> Int -> Int -> TcM a
wrongNumberOfParmsErr name :: Name
name decl_arity :: Int
decl_arity missing :: Int
missing
  = SDoc -> TcM a
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM a) -> SDoc -> TcM a
forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Pattern synonym" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "has")
          SDoc -> SDoc -> SDoc
<+> Int -> SDoc -> SDoc
speakNOf Int
decl_arity (String -> SDoc
text "argument"))
       2 (String -> SDoc
text "but its type signature has" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
missing SDoc -> SDoc -> SDoc
<+> String -> SDoc
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 :: Located Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> ([TyVarBinder], ThetaType, TcEvBinds, [Id])
-> ([TyVarBinder], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> [Name]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish lname :: Located Name
lname dir :: HsPatSynDir GhcRn
dir is_infix :: Bool
is_infix lpat' :: LPat GhcTc
lpat'
                 (univ_tvs :: [TyVarBinder]
univ_tvs, req_theta :: ThetaType
req_theta, req_ev_binds :: TcEvBinds
req_ev_binds, req_dicts :: [Id]
req_dicts)
                 (ex_tvs :: [TyVarBinder]
ex_tvs,   ex_tys :: ThetaType
ex_tys,    prov_theta :: ThetaType
prov_theta,   prov_dicts :: [EvTerm]
prov_dicts)
                 (args :: [LHsExpr GhcTc]
args, arg_tys :: ThetaType
arg_tys)
                 pat_ty :: Type
pat_ty field_labels :: [Name]
field_labels
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there

         (ze :: ZonkEnv
ze, univ_tvs' :: [TyVarBinder]
univ_tvs') <- [TyVarBinder] -> TcM (ZonkEnv, [TyVarBinder])
forall vis. [VarBndr Id vis] -> TcM (ZonkEnv, [VarBndr Id vis])
zonkTyVarBinders [TyVarBinder]
univ_tvs
       ; ThetaType
req_theta'      <- ZonkEnv -> ThetaType -> TcM ThetaType
zonkTcTypesToTypesX ZonkEnv
ze ThetaType
req_theta
       ; (ze :: ZonkEnv
ze, ex_tvs' :: [TyVarBinder]
ex_tvs')   <- ZonkEnv -> [TyVarBinder] -> TcM (ZonkEnv, [TyVarBinder])
forall vis.
ZonkEnv -> [VarBndr Id vis] -> TcM (ZonkEnv, [VarBndr Id vis])
zonkTyVarBindersX ZonkEnv
ze [TyVarBinder]
ex_tvs
       ; ThetaType
prov_theta'     <- ZonkEnv -> ThetaType -> TcM ThetaType
zonkTcTypesToTypesX ZonkEnv
ze ThetaType
prov_theta
       ; Type
pat_ty'         <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
pat_ty
       ; ThetaType
arg_tys'        <- ZonkEnv -> ThetaType -> TcM ThetaType
zonkTcTypesToTypesX ZonkEnv
ze ThetaType
arg_tys

       ; let (env1 :: TidyEnv
env1, univ_tvs :: [TyVarBinder]
univ_tvs) = TidyEnv -> [TyVarBinder] -> (TidyEnv, [TyVarBinder])
forall vis.
TidyEnv -> [VarBndr Id vis] -> (TidyEnv, [VarBndr Id vis])
tidyTyCoVarBinders TidyEnv
emptyTidyEnv [TyVarBinder]
univ_tvs'
             (env2 :: TidyEnv
env2, ex_tvs :: [TyVarBinder]
ex_tvs)   = TidyEnv -> [TyVarBinder] -> (TidyEnv, [TyVarBinder])
forall vis.
TidyEnv -> [VarBndr Id vis] -> (TidyEnv, [VarBndr Id vis])
tidyTyCoVarBinders TidyEnv
env1 [TyVarBinder]
ex_tvs'
             req_theta :: ThetaType
req_theta  = TidyEnv -> ThetaType -> ThetaType
tidyTypes TidyEnv
env2 ThetaType
req_theta'
             prov_theta :: ThetaType
prov_theta = TidyEnv -> ThetaType -> ThetaType
tidyTypes TidyEnv
env2 ThetaType
prov_theta'
             arg_tys :: ThetaType
arg_tys    = TidyEnv -> ThetaType -> ThetaType
tidyTypes TidyEnv
env2 ThetaType
arg_tys'
             pat_ty :: Type
pat_ty     = TidyEnv -> Type -> Type
tidyType  TidyEnv
env2 Type
pat_ty'

       ; String -> SDoc -> TcRn ()
traceTc "tc_patsyn_finish {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
lname) SDoc -> SDoc -> SDoc
$$ LPat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LPat GhcTc -> SrcSpanLess (LPat GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LPat GhcTc
lpat') SDoc -> SDoc -> SDoc
$$
           ([TyVarBinder], ThetaType, TcEvBinds, [Id]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TyVarBinder]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts) SDoc -> SDoc -> SDoc
$$
           ([TyVarBinder], ThetaType, [EvTerm]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TyVarBinder]
ex_tvs, ThetaType
prov_theta, [EvTerm]
prov_dicts) SDoc -> SDoc -> SDoc
$$
           [LHsExpr GhcTc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsExpr GhcTc]
args SDoc -> SDoc -> SDoc
$$
           ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
arg_tys SDoc -> SDoc -> SDoc
$$
           Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pat_ty

       -- Make the 'matcher'
       ; (matcher_id :: (Id, Bool)
matcher_id, matcher_bind :: LHsBinds GhcTc
matcher_bind) <- Located Name
-> LPat GhcTc
-> ([Id], ThetaType, TcEvBinds, [Id])
-> ([Id], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> TcM ((Id, Bool), LHsBinds GhcTc)
tcPatSynMatcher Located Name
lname LPat GhcTc
lpat'
                                         ([TyVarBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
univ_tvs, ThetaType
req_theta, TcEvBinds
req_ev_binds, [Id]
req_dicts)
                                         ([TyVarBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
ex_tvs, ThetaType
ex_tys, ThetaType
prov_theta, [EvTerm]
prov_dicts)
                                         ([LHsExpr GhcTc]
args, ThetaType
arg_tys)
                                         Type
pat_ty

       -- Make the 'builder'
       ; Maybe (Id, Bool)
builder_id <- HsPatSynDir GhcRn
-> Located Name
-> [TyVarBinder]
-> ThetaType
-> [TyVarBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM (Maybe (Id, Bool))
forall a.
HsPatSynDir a
-> Located Name
-> [TyVarBinder]
-> ThetaType
-> [TyVarBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM (Maybe (Id, Bool))
mkPatSynBuilderId HsPatSynDir GhcRn
dir Located Name
lname
                                         [TyVarBinder]
univ_tvs ThetaType
req_theta
                                         [TyVarBinder]
ex_tvs   ThetaType
prov_theta
                                         ThetaType
arg_tys Type
pat_ty

         -- TODO: Make this have the proper information
       ; let mkFieldLabel :: Name -> FieldLabel
mkFieldLabel name :: Name
name = FieldLabel :: forall a. FieldLabelString -> Bool -> a -> FieldLbl a
FieldLabel { flLabel :: FieldLabelString
flLabel = OccName -> FieldLabelString
occNameFS (Name -> OccName
nameOccName Name
name)
                                            , flIsOverloaded :: Bool
flIsOverloaded = Bool
False
                                            , flSelector :: Name
flSelector = Name
name }
             field_labels' :: [FieldLabel]
field_labels' = (Name -> FieldLabel) -> [Name] -> [FieldLabel]
forall a b. (a -> b) -> [a] -> [b]
map Name -> FieldLabel
mkFieldLabel [Name]
field_labels


       -- Make the PatSyn itself
       ; let patSyn :: PatSyn
patSyn = Name
-> Bool
-> ([TyVarBinder], ThetaType)
-> ([TyVarBinder], ThetaType)
-> ThetaType
-> Type
-> (Id, Bool)
-> Maybe (Id, Bool)
-> [FieldLabel]
-> PatSyn
mkPatSyn (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
lname) Bool
is_infix
                        ([TyVarBinder]
univ_tvs, ThetaType
req_theta)
                        ([TyVarBinder]
ex_tvs, ThetaType
prov_theta)
                        ThetaType
arg_tys
                        Type
pat_ty
                        (Id, Bool)
matcher_id Maybe (Id, Bool)
builder_id
                        [FieldLabel]
field_labels'

       -- Selectors
       ; let rn_rec_sel_binds :: [(Id, LHsBind GhcRn)]
rn_rec_sel_binds = PatSyn -> [FieldLabel] -> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds PatSyn
patSyn (PatSyn -> [FieldLabel]
patSynFieldLabels PatSyn
patSyn)
             tything :: TyThing
tything = ConLike -> TyThing
AConLike (PatSyn -> ConLike
PatSynCon PatSyn
patSyn)
       ; TcGblEnv
tcg_env <- [TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing
tything] (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
                    [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds [(Id, LHsBind GhcRn)]
rn_rec_sel_binds

       ; String -> SDoc -> TcRn ()
traceTc "tc_patsyn_finish }" SDoc
empty
       ; (LHsBinds GhcTc, TcGblEnv) -> TcM (LHsBinds GhcTc, TcGblEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcTc
matcher_bind, TcGblEnv
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 :: Located Name
-> LPat GhcTc
-> ([Id], ThetaType, TcEvBinds, [Id])
-> ([Id], ThetaType, ThetaType, [EvTerm])
-> ([LHsExpr GhcTc], ThetaType)
-> Type
-> TcM ((Id, Bool), LHsBinds GhcTc)
tcPatSynMatcher (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc name :: SrcSpanLess (Located Name)
name) lpat :: LPat GhcTc
lpat
                (univ_tvs :: [Id]
univ_tvs, req_theta :: ThetaType
req_theta, req_ev_binds :: TcEvBinds
req_ev_binds, req_dicts :: [Id]
req_dicts)
                (ex_tvs :: [Id]
ex_tvs, ex_tys :: ThetaType
ex_tys, prov_theta :: ThetaType
prov_theta, prov_dicts :: [EvTerm]
prov_dicts)
                (args :: [LHsExpr GhcTc]
args, arg_tys :: ThetaType
arg_tys) pat_ty :: Type
pat_ty
  = do { Name
rr_name <- OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
newNameAt (String -> OccName
mkTyVarOcc "rep") SrcSpan
loc
       ; Name
tv_name <- OccName -> SrcSpan -> TcRnIf TcGblEnv TcLclEnv Name
newNameAt (String -> OccName
mkTyVarOcc "r")   SrcSpan
loc
       ; let rr_tv :: Id
rr_tv  = Name -> Type -> Id
mkTyVar Name
rr_name Type
runtimeRepTy
             rr :: Type
rr     = Id -> Type
mkTyVarTy Id
rr_tv
             res_tv :: Id
res_tv = Name -> Type -> Id
mkTyVar Name
tv_name (Type -> Type
tYPE Type
rr)
             res_ty :: Type
res_ty = Id -> Type
mkTyVarTy Id
res_tv
             is_unlifted :: Bool
is_unlifted = [LHsExpr GhcTc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsExpr GhcTc]
args Bool -> Bool -> Bool
&& [EvTerm] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvTerm]
prov_dicts
             (cont_args :: [LHsExpr GhcTc]
cont_args, cont_arg_tys :: ThetaType
cont_arg_tys)
               | Bool
is_unlifted = ([IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
voidPrimId], [Type
voidPrimTy])
               | Bool
otherwise   = ([LHsExpr GhcTc]
args,                 ThetaType
arg_tys)
             cont_ty :: Type
cont_ty = [Id] -> ThetaType -> Type -> Type
mkInfSigmaTy [Id]
ex_tvs ThetaType
prov_theta (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                       ThetaType -> Type -> Type
mkFunTys ThetaType
cont_arg_tys Type
res_ty

             fail_ty :: Type
fail_ty  = Type -> Type -> Type
mkFunTy Type
voidPrimTy Type
res_ty

       ; Name
matcher_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
SrcSpanLess (Located Name)
name OccName -> OccName
mkMatcherOcc
       ; Id
scrutinee    <- FieldLabelString -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl. FieldLabelString -> Type -> TcRnIf gbl lcl Id
newSysLocalId (String -> FieldLabelString
fsLit "scrut") Type
pat_ty
       ; Id
cont         <- FieldLabelString -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl. FieldLabelString -> Type -> TcRnIf gbl lcl Id
newSysLocalId (String -> FieldLabelString
fsLit "cont")  Type
cont_ty
       ; Id
fail         <- FieldLabelString -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall gbl lcl. FieldLabelString -> Type -> TcRnIf gbl lcl Id
newSysLocalId (String -> FieldLabelString
fsLit "fail")  Type
fail_ty

       ; let matcher_tau :: Type
matcher_tau   = ThetaType -> Type -> Type
mkFunTys [Type
pat_ty, Type
cont_ty, Type
fail_ty] Type
res_ty
             matcher_sigma :: Type
matcher_sigma = [Id] -> ThetaType -> Type -> Type
mkInfSigmaTy (Id
rr_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:Id
res_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
univ_tvs) ThetaType
req_theta Type
matcher_tau
             matcher_id :: Id
matcher_id    = Name -> Type -> Id
mkExportedVanillaId Name
matcher_name Type
matcher_sigma
                             -- See Note [Exported LocalIds] in Id

             inst_wrap :: HsWrapper
inst_wrap = [EvTerm] -> HsWrapper
mkWpEvApps [EvTerm]
prov_dicts HsWrapper -> HsWrapper -> HsWrapper
<.> ThetaType -> HsWrapper
mkWpTyApps ThetaType
ex_tys
             cont' :: LHsExpr GhcTc
cont' = (LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc)
-> LHsExpr GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
inst_wrap (IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
cont)) [LHsExpr GhcTc]
cont_args

             fail' :: LHsExpr GhcTc
fail' = IdP GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (id :: Pass).
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps Id
IdP GhcTc
fail [IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
voidPrimId]

             args :: [LPat GhcTc]
args = (Id -> LPat GhcTc) -> [Id] -> [LPat GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> LPat GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [Id
scrutinee, Id
cont, Id
fail]
             lwpat :: LPat GhcTc
lwpat = SrcSpanLess (LPat GhcTc) -> LPat GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LPat GhcTc) -> LPat GhcTc)
-> SrcSpanLess (LPat GhcTc) -> LPat GhcTc
forall a b. (a -> b) -> a -> b
$ XWildPat GhcTc -> LPat GhcTc
forall p. XWildPat p -> Pat p
WildPat Type
XWildPat GhcTc
pat_ty
             cases :: [LMatch GhcTc (LHsExpr GhcTc)]
cases = if LPat GhcTc -> Bool
forall (p :: Pass).
OutputableBndrId (GhcPass p) =>
LPat (GhcPass p) -> Bool
isIrrefutableHsPat LPat GhcTc
lpat
                     then [LPat GhcTc -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lpat  LHsExpr GhcTc
cont']
                     else [LPat GhcTc -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lpat  LHsExpr GhcTc
cont',
                           LPat GhcTc -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcTc
lwpat LHsExpr GhcTc
fail']
             body :: LHsExpr GhcTc
body = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap (TcEvBinds -> HsWrapper
mkWpLet TcEvBinds
req_ev_binds) (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                    SrcSpan -> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (LPat GhcTc -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LPat GhcTc
lpat) (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc)
-> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                    XCase GhcTc
-> LHsExpr GhcTc
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcTc
NoExt
noExt (IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Id
IdP GhcTc
scrutinee) (MatchGroup GhcTc (LHsExpr GhcTc) -> SrcSpanLess (LHsExpr GhcTc))
-> MatchGroup GhcTc (LHsExpr GhcTc) -> SrcSpanLess (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                    MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG{ mg_alts :: Located [LMatch GhcTc (LHsExpr GhcTc)]
mg_alts = SrcSpan
-> SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
-> Located [LMatch GhcTc (LHsExpr GhcTc)]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (LPat GhcTc -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LPat GhcTc
lpat) [LMatch GhcTc (LHsExpr GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
cases
                      , mg_ext :: XMG GhcTc (LHsExpr GhcTc)
mg_ext = ThetaType -> Type -> MatchGroupTc
MatchGroupTc [Type
pat_ty] Type
res_ty
                      , mg_origin :: Origin
mg_origin = Origin
Generated
                      }
             body' :: LHsExpr GhcTc
body' = SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc)
-> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                     XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
NoExt
noExt (MatchGroup GhcTc (LHsExpr GhcTc) -> SrcSpanLess (LHsExpr GhcTc))
-> MatchGroup GhcTc (LHsExpr GhcTc) -> SrcSpanLess (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                     MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG{ mg_alts :: Located [LMatch GhcTc (LHsExpr GhcTc)]
mg_alts = SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
-> Located [LMatch GhcTc (LHsExpr GhcTc)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [HsMatchContext (NameOrRdrName (IdP GhcTc))
-> [LPat GhcTc] -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NameOrRdrName (IdP GhcTc))
forall id. HsMatchContext id
LambdaExpr
                                                        [LPat GhcTc]
args LHsExpr GhcTc
body]
                       , mg_ext :: XMG GhcTc (LHsExpr GhcTc)
mg_ext = ThetaType -> Type -> MatchGroupTc
MatchGroupTc [Type
pat_ty, Type
cont_ty, Type
fail_ty] Type
res_ty
                       , mg_origin :: Origin
mg_origin = Origin
Generated
                       }
             match :: LMatch GhcTc (LHsExpr GhcTc)
match = HsMatchContext (NameOrRdrName (IdP GhcTc))
-> [LPat GhcTc]
-> LHsExpr GhcTc
-> Located (HsLocalBinds GhcTc)
-> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (Located Name -> HsMatchContext Name
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located Name)
name)) []
                             ([Id] -> [Id] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams (Id
rr_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:Id
res_tvId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
univ_tvs)
                                       [Id]
req_dicts LHsExpr GhcTc
body')
                             (SrcSpanLess (Located (HsLocalBinds GhcTc))
-> Located (HsLocalBinds GhcTc)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XEmptyLocalBinds GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
NoExt
noExt))
             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg = MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG{ mg_alts :: Located [LMatch GhcTc (LHsExpr GhcTc)]
mg_alts = SrcSpan
-> SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
-> Located [LMatch GhcTc (LHsExpr GhcTc)]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (LMatch GhcTc (LHsExpr GhcTc) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LMatch GhcTc (LHsExpr GhcTc)
match) [LMatch GhcTc (LHsExpr GhcTc)
match]
                    , mg_ext :: XMG GhcTc (LHsExpr GhcTc)
mg_ext = ThetaType -> Type -> MatchGroupTc
MatchGroupTc [] Type
res_ty
                    , mg_origin :: Origin
mg_origin = Origin
Generated
                    }

       ; let bind :: HsBindLR GhcTc GhcTc
bind = FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind{ fun_ext :: XFunBind GhcTc GhcTc
fun_ext = NameSet
XFunBind GhcTc GhcTc
emptyNameSet
                           , fun_id :: Located (IdP GhcTc)
fun_id = SrcSpan -> SrcSpanLess (Located Id) -> Located Id
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located Id)
Id
matcher_id
                           , fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
mg
                           , fun_co_fn :: HsWrapper
fun_co_fn = HsWrapper
idHsWrapper
                           , fun_tick :: [Tickish Id]
fun_tick = [] }
             matcher_bind :: LHsBinds GhcTc
matcher_bind = LHsBindLR GhcTc GhcTc -> LHsBinds GhcTc
forall a. a -> Bag a
unitBag (SrcSpanLess (LHsBindLR GhcTc GhcTc) -> LHsBindLR GhcTc GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBindLR GhcTc GhcTc
bind)

       ; String -> SDoc -> TcRn ()
traceTc "tcPatSynMatcher" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
SrcSpanLess (Located Name)
name SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
matcher_id))
       ; String -> SDoc -> TcRn ()
traceTc "tcPatSynMatcher" (LHsBinds GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBinds GhcTc
matcher_bind)

       ; ((Id, Bool), LHsBinds GhcTc) -> TcM ((Id, Bool), LHsBinds GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id
matcher_id, Bool
is_unlifted), LHsBinds GhcTc
matcher_bind) }

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

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

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

mkPatSynBuilderId :: HsPatSynDir a -> Located Name
                  -> [TyVarBinder] -> ThetaType
                  -> [TyVarBinder] -> ThetaType
                  -> [Type] -> Type
                  -> TcM (Maybe (Id, Bool))
mkPatSynBuilderId :: HsPatSynDir a
-> Located Name
-> [TyVarBinder]
-> ThetaType
-> [TyVarBinder]
-> ThetaType
-> ThetaType
-> Type
-> TcM (Maybe (Id, Bool))
mkPatSynBuilderId dir :: HsPatSynDir a
dir (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ name :: SrcSpanLess (Located Name)
name)
                  univ_bndrs :: [TyVarBinder]
univ_bndrs req_theta :: ThetaType
req_theta ex_bndrs :: [TyVarBinder]
ex_bndrs prov_theta :: ThetaType
prov_theta
                  arg_tys :: ThetaType
arg_tys pat_ty :: Type
pat_ty
  | HsPatSynDir a -> Bool
forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir a
dir
  = Maybe (Id, Bool) -> TcM (Maybe (Id, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Id, Bool)
forall a. Maybe a
Nothing
  | Bool
otherwise
  = do { Name
builder_name <- Name -> (OccName -> OccName) -> TcRnIf TcGblEnv TcLclEnv Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
SrcSpanLess (Located Name)
name OccName -> OccName
mkBuilderOcc
       ; let theta :: ThetaType
theta          = ThetaType
req_theta ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
prov_theta
             need_dummy_arg :: Bool
need_dummy_arg = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
pat_ty Bool -> Bool -> Bool
&& ThetaType -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
arg_tys Bool -> Bool -> Bool
&& ThetaType -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta
             builder_sigma :: Type
builder_sigma  = Bool -> Type -> Type
add_void Bool
need_dummy_arg (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                              [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
univ_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                              [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
ex_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                              ThetaType -> Type -> Type
mkFunTys ThetaType
theta (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                              ThetaType -> Type -> Type
mkFunTys ThetaType
arg_tys (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                              Type
pat_ty
             builder_id :: Id
builder_id     = Name -> Type -> Id
mkExportedVanillaId Name
builder_name Type
builder_sigma
              -- See Note [Exported LocalIds] in Id

             builder_id' :: Id
builder_id'    = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo (IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
pat_ty) Id
builder_id

       ; Maybe (Id, Bool) -> TcM (Maybe (Id, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id, Bool) -> Maybe (Id, Bool)
forall a. a -> Maybe a
Just (Id
builder_id', Bool
need_dummy_arg)) }
  where

tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
                    -> TcM (LHsBinds GhcTc)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind (PSB { psb_id :: forall idL idR. PatSynBind idL idR -> Located (IdP idL)
psb_id = (Located (IdP GhcRn) -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc name :: SrcSpanLess (Located Name)
name)
                         , psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = LPat GhcRn
lpat
                         , psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_dir = HsPatSynDir GhcRn
dir
                         , psb_args :: forall idL idR.
PatSynBind idL idR -> HsPatSynDetails (Located (IdP idR))
psb_args = HsPatSynDetails (Located (IdP GhcRn))
details })
  | HsPatSynDir GhcRn -> Bool
forall a. HsPatSynDir a -> Bool
isUnidirectional HsPatSynDir GhcRn
dir
  = LHsBinds GhcTc -> TcM (LHsBinds GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBinds GhcTc
forall a. Bag a
emptyBag

  | Left why :: SDoc
why <- Either SDoc (MatchGroup GhcRn (LHsExpr GhcRn))
mb_match_group       -- Can't invert the pattern
  = SrcSpan -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LPat GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LPat GhcRn
lpat) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$ SDoc -> TcM (LHsBinds GhcTc)
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM (LHsBinds GhcTc)) -> SDoc -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Invalid right-hand side of bidirectional pattern synonym"
                 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
SrcSpanLess (Located Name)
name) SDoc -> SDoc -> SDoc
<> SDoc
colon)
              2 SDoc
why
         , String -> SDoc
text "RHS pattern:" SDoc -> SDoc -> SDoc
<+> LPat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
lpat ]

  | Right match_group :: MatchGroup GhcRn (LHsExpr GhcRn)
match_group <- Either SDoc (MatchGroup GhcRn (LHsExpr GhcRn))
mb_match_group  -- Bidirectional
  = do { PatSyn
patsyn <- Name -> TcM PatSyn
tcLookupPatSyn Name
SrcSpanLess (Located Name)
name
       ; case PatSyn -> Maybe (Id, Bool)
patSynBuilder PatSyn
patsyn of {
           Nothing -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBinds GhcTc
forall a. Bag a
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 :: Id
builder_id, need_dummy_arg :: Bool
need_dummy_arg) ->  -- Normal case
    do { -- Bidirectional, so patSynBuilder returns Just
         let match_group' :: MatchGroup GhcRn (LHsExpr GhcRn)
match_group' | Bool
need_dummy_arg = MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg MatchGroup GhcRn (LHsExpr GhcRn)
match_group
                          | Bool
otherwise      = MatchGroup GhcRn (LHsExpr GhcRn)
match_group

             bind :: HsBindLR GhcRn GhcRn
bind = FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind { fun_ext :: XFunBind GhcRn GhcRn
fun_ext = NameSet
XFunBind GhcRn GhcRn
placeHolderNamesTc
                            , fun_id :: Located (IdP GhcRn)
fun_id      = SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (Id -> Name
idName Id
builder_id)
                            , fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
match_group'
                            , fun_co_fn :: HsWrapper
fun_co_fn   = HsWrapper
idHsWrapper
                            , fun_tick :: [Tickish Id]
fun_tick    = [] }

             sig :: TcIdSigInfo
sig = UserTypeCtxt -> Id -> TcIdSigInfo
completeSigFromId (Name -> UserTypeCtxt
PatSynCtxt Name
SrcSpanLess (Located Name)
name) Id
builder_id

       ; String -> SDoc -> TcRn ()
traceTc "tcPatSynBuilderBind {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
patsyn SDoc -> SDoc -> SDoc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
builder_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
builder_id)
       ; (builder_binds :: LHsBinds GhcTc
builder_binds, _) <- TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [Id])
tcPolyCheck TcPragEnv
emptyPragEnv TcIdSigInfo
sig (SrcSpanLess (LHsBind GhcRn) -> LHsBind GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsBind GhcRn)
HsBindLR GhcRn GhcRn
bind)
       ; String -> SDoc -> TcRn ()
traceTc "tcPatSynBuilderBind }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ LHsBinds GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBinds GhcTc
builder_binds
       ; LHsBinds GhcTc -> TcM (LHsBinds GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBinds GhcTc
builder_binds } } }

  | Bool
otherwise = String -> TcM (LHsBinds GhcTc)
forall a. String -> a
panic "tcPatSynBuilderBind"  -- Both cases dealt with
  where
    mb_match_group :: Either SDoc (MatchGroup GhcRn (LHsExpr GhcRn))
mb_match_group
       = case HsPatSynDir GhcRn
dir of
           ExplicitBidirectional explicit_mg :: MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg -> MatchGroup GhcRn (LHsExpr GhcRn)
-> Either SDoc (MatchGroup GhcRn (LHsExpr GhcRn))
forall a b. b -> Either a b
Right MatchGroup GhcRn (LHsExpr GhcRn)
explicit_mg
           ImplicitBidirectional -> (LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn))
-> Either SDoc (LHsExpr GhcRn)
-> Either SDoc (MatchGroup GhcRn (LHsExpr GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg (Name -> [Located Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr Name
SrcSpanLess (Located Name)
name [Located Name]
args LPat GhcRn
lpat)
           Unidirectional -> String -> Either SDoc (MatchGroup GhcRn (LHsExpr GhcRn))
forall a. String -> a
panic "tcPatSynBuilderBind"

    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg body :: LHsExpr GhcRn
body = Origin
-> [LMatch GhcRn (LHsExpr GhcRn)]
-> MatchGroup GhcRn (LHsExpr GhcRn)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExt) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
Generated [LMatch GhcRn (LHsExpr GhcRn)
builder_match]
          where
            builder_args :: [LPat GhcRn]
builder_args  = [SrcSpan -> SrcSpanLess (LPat GhcRn) -> LPat GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XVarPat GhcRn -> Located (IdP GhcRn) -> LPat GhcRn
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat XVarPat GhcRn
NoExt
noExt (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located Name)
n))
                            | (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc n :: SrcSpanLess (Located Name)
n) <- [Located Name]
args]
            builder_match :: LMatch GhcRn (LHsExpr GhcRn)
builder_match = HsMatchContext (NameOrRdrName (IdP GhcRn))
-> [LPat GhcRn]
-> LHsExpr GhcRn
-> Located (HsLocalBinds GhcRn)
-> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (Located Name -> HsMatchContext Name
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located Name)
name))
                                    [LPat GhcRn]
builder_args LHsExpr GhcRn
body
                                    (SrcSpanLess (Located (HsLocalBinds GhcRn))
-> Located (HsLocalBinds GhcRn)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XEmptyLocalBinds GhcRn GhcRn -> HsLocalBinds GhcRn
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
NoExt
noExt))

    args :: [Located Name]
args = case HsPatSynDetails (Located (IdP GhcRn))
details of
              PrefixCon args :: [Located (IdP GhcRn)]
args     -> [Located Name]
[Located (IdP GhcRn)]
args
              InfixCon arg1 :: Located (IdP GhcRn)
arg1 arg2 :: Located (IdP GhcRn)
arg2 -> [Located Name
Located (IdP GhcRn)
arg1, Located Name
Located (IdP GhcRn)
arg2]
              RecCon args :: [RecordPatSynField (Located (IdP GhcRn))]
args        -> (RecordPatSynField (Located Name) -> Located Name)
-> [RecordPatSynField (Located Name)] -> [Located Name]
forall a b. (a -> b) -> [a] -> [b]
map RecordPatSynField (Located Name) -> Located Name
forall a. RecordPatSynField a -> a
recordPatSynPatVar [RecordPatSynField (Located Name)]
[RecordPatSynField (Located (IdP GhcRn))]
args

    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
                  -> MatchGroup GhcRn (LHsExpr GhcRn)
    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg mg :: MatchGroup GhcRn (LHsExpr GhcRn)
mg@(MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts =
                           (Located [LMatch GhcRn (LHsExpr GhcRn)]
-> Located (SrcSpanLess (Located [LMatch GhcRn (LHsExpr GhcRn)]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l [dL->L loc
                                           match@(Match { m_pats = pats })]) })
      = MatchGroup GhcRn (LHsExpr GhcRn)
mg { mg_alts :: Located [LMatch GhcRn (LHsExpr GhcRn)]
mg_alts = SrcSpan
-> SrcSpanLess (Located [LMatch GhcRn (LHsExpr GhcRn)])
-> Located [LMatch GhcRn (LHsExpr GhcRn)]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l [SrcSpan
-> SrcSpanLess (LMatch GhcRn (LHsExpr GhcRn))
-> LMatch GhcRn (LHsExpr GhcRn)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (LMatch GhcRn (LHsExpr GhcRn))
Match GhcRn (LHsExpr GhcRn)
match { m_pats :: [LPat GhcRn]
m_pats = LPat GhcRn
nlWildPatName LPat GhcRn -> [LPat GhcRn] -> [LPat GhcRn]
forall a. a -> [a] -> [a]
: [LPat GhcRn]
pats })] }
    add_dummy_arg other_mg :: MatchGroup GhcRn (LHsExpr GhcRn)
other_mg = String -> SDoc -> MatchGroup GhcRn (LHsExpr GhcRn)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "add_dummy_arg" (SDoc -> MatchGroup GhcRn (LHsExpr GhcRn))
-> SDoc -> MatchGroup GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$
                             MatchGroup GhcRn (LHsExpr GhcRn) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId (GhcPass idR), Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
other_mg
tcPatSynBuilderBind (XPatSynBind _) = String -> TcM (LHsBinds GhcTc)
forall a. String -> a
panic "tcPatSynBuilderBind"

tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
-- monadic only for failure
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTc, Type)
tcPatSynBuilderOcc ps :: PatSyn
ps
  | Just (builder_id :: Id
builder_id, add_void_arg :: Bool
add_void_arg) <- Maybe (Id, Bool)
builder
  , let builder_expr :: HsExpr GhcTc
builder_expr = XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut XConLikeOut GhcTc
NoExt
noExt (PatSyn -> ConLike
PatSynCon PatSyn
ps)
        builder_ty :: Type
builder_ty   = Id -> Type
idType Id
builder_id
  = (HsExpr GhcTc, Type) -> TcM (HsExpr GhcTc, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((HsExpr GhcTc, Type) -> TcM (HsExpr GhcTc, Type))
-> (HsExpr GhcTc, Type) -> TcM (HsExpr GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
    if Bool
add_void_arg
    then ( HsExpr GhcTc
builder_expr   -- still just return builder_expr; the void# arg is added
                          -- by dsConLike in the desugarer
         , Type -> Type
tcFunResultTy Type
builder_ty )
    else (HsExpr GhcTc
builder_expr, Type
builder_ty)

  | Bool
otherwise  -- Unidirectional
  = Name -> TcM (HsExpr GhcTc, Type)
forall name a. Outputable name => name -> TcM a
nonBidirectionalErr Name
name
  where
    name :: Name
name    = PatSyn -> Name
patSynName PatSyn
ps
    builder :: Maybe (Id, Bool)
builder = PatSyn -> Maybe (Id, Bool)
patSynBuilder PatSyn
ps

add_void :: Bool -> Type -> Type
add_void :: Bool -> Type -> Type
add_void need_dummy_arg :: Bool
need_dummy_arg ty :: Type
ty
  | Bool
need_dummy_arg = Type -> Type -> Type
mkFunTy Type
voidPrimTy Type
ty
  | Bool
otherwise      = Type
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 -> [Located Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
tcPatToExpr name :: Name
name args :: [Located Name]
args pat :: LPat GhcRn
pat = LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go LPat GhcRn
pat
  where
    lhsVars :: NameSet
lhsVars = [Name] -> NameSet
mkNameSet ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located Name]
args)

    -- Make a prefix con for prefix and infix patterns for simplicity
    mkPrefixConExpr :: Located Name -> [LPat GhcRn]
                    -> Either MsgDoc (HsExpr GhcRn)
    mkPrefixConExpr :: Located Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn)
mkPrefixConExpr lcon :: Located Name
lcon@(Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc _) pats :: [LPat GhcRn]
pats
      = do { [LHsExpr GhcRn]
exprs <- (LPat GhcRn -> Either SDoc (LHsExpr GhcRn))
-> [LPat GhcRn] -> Either SDoc [LHsExpr GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [LPat GhcRn]
pats
           ; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return ((HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn)
-> HsExpr GhcRn -> [LHsExpr GhcRn] -> HsExpr GhcRn
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\x :: HsExpr GhcRn
x y :: LHsExpr GhcRn
y -> XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExt
noExt (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
x) LHsExpr GhcRn
y)
                            (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExt
noExt Located Name
Located (IdP GhcRn)
lcon) [LHsExpr GhcRn]
exprs) }

    mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
                    -> Either MsgDoc (HsExpr GhcRn)
    mkRecordConExpr :: Located Name
-> HsRecFields GhcRn (LPat GhcRn) -> Either SDoc (HsExpr GhcRn)
mkRecordConExpr con :: Located Name
con fields :: HsRecFields GhcRn (LPat GhcRn)
fields
      = do { HsRecFields GhcRn (LHsExpr GhcRn)
exprFields <- (LPat GhcRn -> Either SDoc (LHsExpr GhcRn))
-> HsRecFields GhcRn (LPat GhcRn)
-> Either SDoc (HsRecFields GhcRn (LHsExpr GhcRn))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go HsRecFields GhcRn (LPat GhcRn)
fields
           ; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRecordCon GhcRn
-> Located (IdP GhcRn)
-> HsRecFields GhcRn (LHsExpr GhcRn)
-> HsExpr GhcRn
forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon XRecordCon GhcRn
NoExt
noExt Located Name
Located (IdP GhcRn)
con HsRecFields GhcRn (LHsExpr GhcRn)
exprFields) }

    go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
    go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go (LPat GhcRn -> Located (SrcSpanLess (LPat GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc p :: SrcSpanLess (LPat GhcRn)
p) = SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (HsExpr GhcRn -> LHsExpr GhcRn)
-> Either SDoc (HsExpr GhcRn) -> Either SDoc (LHsExpr GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LPat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 SrcSpanLess (LPat GhcRn)
LPat GhcRn
p

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

    go1 (SigPat _ pat :: LPat GhcRn
pat _) = LPat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 (LPat GhcRn -> SrcSpanLess (LPat GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LPat GhcRn
pat)
        -- See Note [Type signatures and the builder expression]

    go1 (VarPat _ (Located (IdP GhcRn) -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l var :: SrcSpanLess (Located Name)
var))
        | Name
SrcSpanLess (Located Name)
var Name -> NameSet -> Bool
`elemNameSet` NameSet
lhsVars
        = HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExt
noExt (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located Name)
var)
        | Bool
otherwise
        = SDoc -> Either SDoc (HsExpr GhcRn)
forall a b. a -> Either a b
Left (SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
SrcSpanLess (Located Name)
var) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not bound by the LHS of the pattern synonym")
    go1 (ParPat _ pat :: LPat GhcRn
pat)          = (LHsExpr GhcRn -> HsExpr GhcRn)
-> Either SDoc (LHsExpr GhcRn) -> Either SDoc (HsExpr GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XPar GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
NoExt
noExt) (Either SDoc (LHsExpr GhcRn) -> Either SDoc (HsExpr GhcRn))
-> Either SDoc (LHsExpr GhcRn) -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go LPat GhcRn
pat
    go1 p :: LPat GhcRn
p@(ListPat reb :: XListPat GhcRn
reb pats :: [LPat GhcRn]
pats)
      | XListPat GhcRn
Nothing <- XListPat GhcRn
reb = do { [LHsExpr GhcRn]
exprs <- (LPat GhcRn -> Either SDoc (LHsExpr GhcRn))
-> [LPat GhcRn] -> Either SDoc [LHsExpr GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [LPat GhcRn]
pats
                            ; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcRn
-> Maybe (SyntaxExpr GhcRn) -> [LHsExpr GhcRn] -> HsExpr GhcRn
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcRn
NoExt
noExt Maybe (SyntaxExpr GhcRn)
forall a. Maybe a
Nothing [LHsExpr GhcRn]
exprs }
      | Bool
otherwise                   = LPat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertibleListPat LPat GhcRn
p
    go1 (TuplePat _ pats :: [LPat GhcRn]
pats box :: Boxity
box)       = do { [LHsExpr GhcRn]
exprs <- (LPat GhcRn -> Either SDoc (LHsExpr GhcRn))
-> [LPat GhcRn] -> Either SDoc [LHsExpr GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
go [LPat GhcRn]
pats
                                         ; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcRn -> [LHsTupArg GhcRn] -> Boxity -> HsExpr GhcRn
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
NoExt
noExt
                                           ((LHsExpr GhcRn -> LHsTupArg GhcRn)
-> [LHsExpr GhcRn] -> [LHsTupArg GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (HsTupArg GhcRn -> LHsTupArg GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsTupArg GhcRn -> LHsTupArg GhcRn)
-> (LHsExpr GhcRn -> HsTupArg GhcRn)
-> LHsExpr GhcRn
-> LHsTupArg GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XPresent GhcRn -> LHsExpr GhcRn -> HsTupArg GhcRn
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
NoExt
noExt)) [LHsExpr GhcRn]
exprs)
                                                                           Boxity
box }
    go1 (SumPat _ pat :: LPat GhcRn
pat alt :: Int
alt arity :: Int
arity)    = do { HsExpr GhcRn
expr <- LPat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 (LPat GhcRn -> SrcSpanLess (LPat GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LPat GhcRn
pat)
                                         ; HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XExplicitSum GhcRn -> Int -> Int -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum XExplicitSum GhcRn
NoExt
noExt Int
alt Int
arity
                                                                   (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
expr)
                                         }
    go1 (LitPat _ lit :: HsLit GhcRn
lit)              = HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
NoExt
noExt HsLit GhcRn
lit
    go1 (NPat _ (Located (HsOverLit GhcRn)
-> Located (SrcSpanLess (Located (HsOverLit GhcRn)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ n :: SrcSpanLess (Located (HsOverLit GhcRn))
n) mb_neg :: Maybe (SyntaxExpr GhcRn)
mb_neg _)
        | Just neg :: SyntaxExpr GhcRn
neg <- Maybe (SyntaxExpr GhcRn)
mb_neg        = HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> HsExpr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcRn -> HsExpr GhcRn) -> LHsExpr GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SyntaxExpr GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn
forall (id :: Pass).
SyntaxExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsSyntaxApps SyntaxExpr GhcRn
neg
                                                     [SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
NoExt
noExt SrcSpanLess (Located (HsOverLit GhcRn))
HsOverLit GhcRn
n)]
        | Bool
otherwise                 = HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> Either SDoc (HsExpr GhcRn))
-> HsExpr GhcRn -> Either SDoc (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
NoExt
noExt SrcSpanLess (Located (HsOverLit GhcRn))
HsOverLit GhcRn
n
    go1 (ConPatOut{})               = String -> Either SDoc (HsExpr GhcRn)
forall a. String -> a
panic "ConPatOut in output of renamer"
    go1 (CoPat{})                   = String -> Either SDoc (HsExpr GhcRn)
forall a. String -> a
panic "CoPat in output of renamer"
    go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat :: LPat GhcRn
pat)))
                                    = LPat GhcRn -> Either SDoc (HsExpr GhcRn)
go1 LPat GhcRn
pat
    go1 (SplicePat _ (HsSpliced{})) = String -> Either SDoc (HsExpr GhcRn)
forall a. String -> a
panic "Invalid splice variety"
    go1 (SplicePat _ (HsSplicedT{})) = String -> Either SDoc (HsExpr GhcRn)
forall a. String -> a
panic "Invalid splice variety"

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

    notInvertible :: LPat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertible p :: LPat GhcRn
p = SDoc -> Either SDoc (HsExpr GhcRn)
forall a b. a -> Either a b
Left (LPat GhcRn -> SDoc
not_invertible_msg LPat GhcRn
p)

    not_invertible_msg :: LPat GhcRn -> SDoc
not_invertible_msg p :: LPat GhcRn
p
      =   String -> SDoc
text "Pattern" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LPat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
p) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not invertible"
      SDoc -> SDoc -> SDoc
$+$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Suggestion: instead use an explicitly bidirectional"
                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "pattern synonym, e.g.")
             2 (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "pattern" SDoc -> SDoc -> SDoc
<+> SDoc
pp_name SDoc -> SDoc -> SDoc
<+> SDoc
pp_args SDoc -> SDoc -> SDoc
<+> SDoc
larrow
                      SDoc -> SDoc -> SDoc
<+> LPat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcRn
pat SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "where")
                   2 (SDoc
pp_name SDoc -> SDoc -> SDoc
<+> SDoc
pp_args SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "..."))
      where
        pp_name :: SDoc
pp_name = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
        pp_args :: SDoc
pp_args = [SDoc] -> SDoc
hsep ((Located Name -> SDoc) -> [Located Name] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located Name]
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 :: LPat GhcRn -> Either SDoc (HsExpr GhcRn)
notInvertibleListPat p :: LPat GhcRn
p
      = SDoc -> Either SDoc (HsExpr GhcRn)
forall a b. a -> Either a b
Left ([SDoc] -> SDoc
vcat [ LPat GhcRn -> SDoc
not_invertible_msg LPat GhcRn
p
                   , String -> SDoc
text "Reason: rebindable syntax is on."
                   , String -> SDoc
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 -> TcM a
nonBidirectionalErr name :: name
name = SDoc -> TcM a
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM a) -> SDoc -> TcM a
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text "non-bidirectional pattern synonym"
    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (name -> SDoc
forall a. Outputable a => a -> SDoc
ppr name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
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 :: LPat GhcTc -> ([Id], [Id])
tcCollectEx pat :: LPat GhcTc
pat = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
pat
  where
    go :: LPat GhcTc -> ([TyVar], [EvVar])
    go :: LPat GhcTc -> ([Id], [Id])
go = LPat GhcTc -> ([Id], [Id])
go1 (LPat GhcTc -> ([Id], [Id]))
-> (LPat GhcTc -> LPat GhcTc) -> LPat GhcTc -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcTc -> LPat GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

    go1 :: Pat GhcTc -> ([TyVar], [EvVar])
    go1 :: LPat GhcTc -> ([Id], [Id])
go1 (LazyPat _ p :: LPat GhcTc
p)      = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (AsPat _ _ p :: LPat GhcTc
p)      = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (ParPat _ p :: LPat GhcTc
p)       = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (BangPat _ p :: LPat GhcTc
p)      = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (ListPat _ ps :: [LPat GhcTc]
ps)     = [([Id], [Id])] -> ([Id], [Id])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LPat GhcTc -> ([Id], [Id])) -> [LPat GhcTc] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
    go1 (TuplePat _ ps :: [LPat GhcTc]
ps _)  = [([Id], [Id])] -> ([Id], [Id])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LPat GhcTc -> ([Id], [Id])) -> [LPat GhcTc] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
    go1 (SumPat _ p :: LPat GhcTc
p _ _)   = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (ViewPat _ _ p :: LPat GhcTc
p)    = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 con :: LPat GhcTc
con@ConPatOut{}    = ([Id], [Id]) -> ([Id], [Id]) -> ([Id], [Id])
forall a a. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge (LPat GhcTc -> [Id]
forall p. Pat p -> [Id]
pat_tvs LPat GhcTc
con, LPat GhcTc -> [Id]
forall p. Pat p -> [Id]
pat_dicts LPat GhcTc
con) (([Id], [Id]) -> ([Id], [Id])) -> ([Id], [Id]) -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$
                              HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (HsConPatDetails GhcTc -> ([Id], [Id]))
-> HsConPatDetails GhcTc -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ LPat GhcTc -> HsConPatDetails GhcTc
forall p. Pat p -> HsConPatDetails p
pat_args LPat GhcTc
con
    go1 (SigPat _ p :: LPat GhcTc
p _)     = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p
    go1 (CoPat _ _ p :: LPat GhcTc
p _)    = LPat GhcTc -> ([Id], [Id])
go1 LPat GhcTc
p
    go1 (NPlusKPat _ n :: Located (IdP GhcTc)
n k :: Located (HsOverLit GhcTc)
k _ geq :: SyntaxExpr GhcTc
geq subtract :: SyntaxExpr GhcTc
subtract)
      = String -> SDoc -> ([Id], [Id])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "TODO: NPlusKPat" (SDoc -> ([Id], [Id])) -> SDoc -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ Located Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located Id
Located (IdP GhcTc)
n SDoc -> SDoc -> SDoc
$$ Located (HsOverLit GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (HsOverLit GhcTc)
k SDoc -> SDoc -> SDoc
$$ SyntaxExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
geq SDoc -> SDoc -> SDoc
$$ SyntaxExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcTc
subtract
    go1 _                   = ([Id], [Id])
forall a a. ([a], [a])
empty

    goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
    goConDetails :: HsConPatDetails GhcTc -> ([Id], [Id])
goConDetails (PrefixCon ps :: [LPat GhcTc]
ps) = [([Id], [Id])] -> ([Id], [Id])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LPat GhcTc] -> [([Id], [Id])]) -> [LPat GhcTc] -> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LPat GhcTc -> ([Id], [Id])) -> [LPat GhcTc] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> ([Id], [Id])
go ([LPat GhcTc] -> ([Id], [Id])) -> [LPat GhcTc] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc]
ps
    goConDetails (InfixCon p1 :: LPat GhcTc
p1 p2 :: LPat GhcTc
p2) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p1 ([Id], [Id]) -> ([Id], [Id]) -> ([Id], [Id])
forall a a. ([a], [a]) -> ([a], [a]) -> ([a], [a])
`merge` LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p2
    goConDetails (RecCon HsRecFields{ rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcTc (LPat GhcTc)]
flds })
      = [([Id], [Id])] -> ([Id], [Id])
forall a a. [([a], [a])] -> ([a], [a])
mergeMany ([([Id], [Id])] -> ([Id], [Id]))
-> ([LHsRecField GhcTc (LPat GhcTc)] -> [([Id], [Id])])
-> [LHsRecField GhcTc (LPat GhcTc)]
-> ([Id], [Id])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id]))
-> [LHsRecField GhcTc (LPat GhcTc)] -> [([Id], [Id])]
forall a b. (a -> b) -> [a] -> [b]
map LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
goRecFd ([LHsRecField GhcTc (LPat GhcTc)] -> ([Id], [Id]))
-> [LHsRecField GhcTc (LPat GhcTc)] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$ [LHsRecField GhcTc (LPat GhcTc)]
flds

    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([Id], [Id])
goRecFd (LHsRecField GhcTc (LPat GhcTc)
-> Located (SrcSpanLess (LHsRecField GhcTc (LPat GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ HsRecField{ hsRecFieldArg = p }) = LPat GhcTc -> ([Id], [Id])
go LPat GhcTc
p

    merge :: ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge (vs1 :: [a]
vs1, evs1 :: [a]
evs1) (vs2 :: [a]
vs2, evs2 :: [a]
evs2) = ([a]
vs1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
vs2, [a]
evs1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
evs2)
    mergeMany :: [([a], [a])] -> ([a], [a])
mergeMany = (([a], [a]) -> ([a], [a]) -> ([a], [a]))
-> ([a], [a]) -> [([a], [a])] -> ([a], [a])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([a], [a]) -> ([a], [a]) -> ([a], [a])
forall a a. ([a], [a]) -> ([a], [a]) -> ([a], [a])
merge ([a], [a])
forall a a. ([a], [a])
empty
    empty :: ([a], [a])
empty     = ([], [])