module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind
, tcPatSynBuilderOcc, nonBidirectionalErr
) where
import GhcPrelude
import GHC.Hs
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 Predicate
import TysWiredIn
import TcType
import TcEvidence
import TcOrigin
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"
tcPatSynDecl :: PatSynBind GhcRn GhcRn
-> Maybe TcSigInfo
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl psb mb_sig
= recoverM (recoverPSB psb) $
case mb_sig of
Nothing -> tcInferPatSynDecl psb
Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
_ -> panic "tcPatSynDecl"
recoverPSB :: PatSynBind GhcRn GhcRn
-> TcM (LHsBinds GhcTc, TcGblEnv)
recoverPSB (PSB { psb_id = (dL->L _ name)
, psb_args = details })
= do { matcher_name <- newImplicitBinder name mkMatcherOcc
; let placeholder = AConLike $ PatSynCon $
mk_placeholder matcher_name
; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
; return (emptyBag, gbl_env) }
where
(_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
mk_placeholder matcher_name
= mkPatSyn name is_infix
([mkTyVarBinder Specified alphaTyVar], []) ([], [])
[]
alphaTy
(matcher_id, True) Nothing
[]
where
matcher_id = mkLocalId matcher_name $
mkSpecForAllTys [alphaTyVar] alphaTy
recoverPSB (XPatSynBind nec) = noExtCon nec
tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details
, psb_def = lpat, psb_dir = dir })
= addPatSynCtxt lname $
do { traceTc "tcInferPatSynDecl {" $ ppr name
; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
; (tclvl, wanted, ((lpat', args), pat_ty))
<- pushLevelAndCaptureConstraints $
tcInferNoInst $ \ exp_ty ->
tcPat PatSyn lpat exp_ty $
mapM tcLookupId arg_names
; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
named_taus = (name, pat_ty) : map mk_named_tau args
mk_named_tau arg
= (getName arg, mkSpecForAllTys ex_tvs (varType arg))
; (univ_tvs, req_dicts, ev_binds, residual, _)
<- simplifyInfer tclvl NoRestrictions [] named_taus wanted
; top_ev_binds <- checkNoErrs (simplifyTop residual)
; addTopEvBinds top_ev_binds $
do { prov_dicts <- mapM zonkId prov_dicts
; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
(prov_theta, prov_evs)
= unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
req_theta = map evVarPred req_dicts
; args <- mapM zonkId args
; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
, let bad_cos = filterDVarSet isId $
(tyCoVarsOfTypeDSet (idType arg))
, not (isEmptyDVarSet bad_cos) ]
; mapM_ dependentArgErr bad_args
; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
; tc_patsyn_finish lname dir is_infix lpat'
(mkTyVarBinders Inferred univ_tvs
, req_theta, ev_binds, req_dicts)
(mkTyVarBinders Inferred ex_tvs
, mkTyVarTys ex_tvs, prov_theta, prov_evs)
(map nlHsVar args, map idType args)
pat_ty rec_fields } }
tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec
mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
mkProvEvidence ev_id
| EqPred r ty1 ty2 <- classifyPredType pred
, let k1 = tcTypeKind ty1
k2 = tcTypeKind ty2
is_homo = k1 `tcEqType` k2
homo_tys = [k1, ty1, ty2]
hetero_tys = [k1, k2, ty1, ty2]
= case r of
ReprEq | is_homo
-> Just ( mkClassPred coercibleClass homo_tys
, evDataConApp coercibleDataCon homo_tys eq_con_args )
| otherwise -> Nothing
NomEq | is_homo
-> Just ( mkClassPred eqClass homo_tys
, evDataConApp eqDataCon homo_tys eq_con_args )
| otherwise
-> Just ( mkClassPred heqClass hetero_tys
, evDataConApp heqDataCon hetero_tys eq_con_args )
| otherwise
= Just (pred, EvExpr (evId ev_id))
where
pred = evVarPred ev_id
eq_con_args = [evId ev_id]
dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
dependentArgErr (arg, bad_cos)
= addErrTc $
vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!"
, hang (text "Pattern-bound variable")
2 (ppr arg <+> dcolon <+> ppr (idType arg))
, nest 2 $
hang (text "has a type that mentions pattern-bound coercion"
<> plural bad_co_list <> colon)
2 (pprWithCommas ppr bad_co_list)
, text "Hint: use -fprint-explicit-coercions to see the coercions"
, text "Probable fix: add a pattern signature" ]
where
bad_co_list = dVarSetElems bad_cos
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
-> TcPatSynInfo
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details
, psb_def = lpat, psb_dir = dir }
TPSI{ patsig_implicit_bndrs = implicit_tvs
, patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
, patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta
, patsig_body_ty = sig_body_ty }
= addPatSynCtxt lname $
do { let decl_arity = length arg_names
(arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
; traceTc "tcCheckPatSynDecl" $
vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
, ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
Right stuff -> return stuff
Left missing -> wrongNumberOfParmsErr name decl_arity missing
; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
; checkTc (null bad_tvs) $
hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
, text "namely" <+> quotes (ppr pat_ty) ])
2 (text "mentions existential type variable" <> plural bad_tvs
<+> pprQuotedList bad_tvs)
; let univ_fvs = closeOverKinds $
(tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
(extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs
ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs
univ_tvs = binderVars univ_bndrs
ex_tvs = binderVars ex_bndrs
; req_dicts <- newEvVars req_theta
; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
pushLevelAndCaptureConstraints $
tcExtendTyVarEnv univ_tvs $
tcPat PatSyn lpat (mkCheckExpType pat_ty) $
do { let in_scope = mkInScopeSet (mkVarSet univ_tvs)
empty_subst = mkEmptyTCvSubst in_scope
; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
; let prov_theta' = substTheta subst prov_theta
; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
; args' <- zipWithM (tc_arg subst) arg_names arg_tys
; return (ex_tvs', prov_dicts, args') }
; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
; simplifyTopImplic implics
; traceTc "tcCheckPatSynDecl }" $ ppr name
; tc_patsyn_finish lname dir is_infix lpat'
(univ_bndrs, req_theta, ev_binds, req_dicts)
(ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
(args', arg_tys)
pat_ty rec_fields }
where
tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)
tc_arg subst arg_name arg_ty
= do {
arg_id <- tcLookupId arg_name
; wrap <- tcSubType_NC GenSigCtxt
(idType arg_id)
(substTyUnchecked subst arg_ty)
; return (mkLHsWrap wrap $ nlHsVar arg_id) }
tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec
collectPatSynArgInfo :: HsPatSynDetails (Located Name)
-> ([Name], [Name], Bool)
collectPatSynArgInfo details =
case details of
PrefixCon names -> (map unLoc names, [], False)
InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
RecCon names -> (vars, sels, False)
where
(vars, sels) = unzip (map splitRecordPatSyn names)
where
splitRecordPatSyn :: RecordPatSynField (Located Name)
-> (Name, Name)
splitRecordPatSyn (RecordPatSynField
{ recordPatSynPatVar = (dL->L _ patVar)
, recordPatSynSelectorId = (dL->L _ selId) })
= (patVar, selId)
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (dL->L loc name) thing_inside
= setSrcSpan loc $
addErrCtxt (text "In the declaration for pattern synonym"
<+> quotes (ppr name)) $
thing_inside
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr name decl_arity missing
= failWithTc $
hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
<+> speakNOf decl_arity (text "argument"))
2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
tc_patsyn_finish :: Located Name
-> HsPatSynDir GhcRn
-> Bool
-> LPat GhcTc
-> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
-> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
-> ([LHsExpr GhcTcId], [TcType])
-> TcType
-> [Name]
-> TcM (LHsBinds GhcTc, TcGblEnv)
tc_patsyn_finish lname dir is_infix lpat'
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys)
pat_ty field_labels
= do {
(ze, univ_tvs') <- zonkTyVarBinders univ_tvs
; req_theta' <- zonkTcTypesToTypesX ze req_theta
; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs
; prov_theta' <- zonkTcTypesToTypesX ze prov_theta
; pat_ty' <- zonkTcTypeToTypeX ze pat_ty
; arg_tys' <- zonkTcTypesToTypesX ze arg_tys
; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'
(env2, ex_tvs) = tidyTyCoVarBinders env1 ex_tvs'
req_theta = tidyTypes env2 req_theta'
prov_theta = tidyTypes env2 prov_theta'
arg_tys = tidyTypes env2 arg_tys'
pat_ty = tidyType env2 pat_ty'
; traceTc "tc_patsyn_finish {" $
ppr (unLoc lname) $$ ppr (unLoc lpat') $$
ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
ppr (ex_tvs, prov_theta, prov_dicts) $$
ppr args $$
ppr arg_tys $$
ppr pat_ty
; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
(binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
(binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys)
pat_ty
; builder_id <- mkPatSynBuilderId dir lname
univ_tvs req_theta
ex_tvs prov_theta
arg_tys pat_ty
; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
, flIsOverloaded = False
, flSelector = name }
field_labels' = map mkFieldLabel field_labels
; let patSyn = mkPatSyn (unLoc lname) is_infix
(univ_tvs, req_theta)
(ex_tvs, prov_theta)
arg_tys
pat_ty
matcher_id builder_id
field_labels'
; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
tything = AConLike (PatSynCon patSyn)
; tcg_env <- tcExtendGlobalEnv [tything] $
tcRecSelBinds rn_rec_sel_binds
; traceTc "tc_patsyn_finish }" empty
; return (matcher_bind, tcg_env) }
tcPatSynMatcher :: Located Name
-> LPat GhcTc
-> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
-> ([TcTyVar], [TcType], ThetaType, [EvTerm])
-> ([LHsExpr GhcTcId], [TcType])
-> TcType
-> TcM ((Id, Bool), LHsBinds GhcTc)
tcPatSynMatcher (dL->L loc name) lpat
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys) pat_ty
= do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
; tv_name <- newNameAt (mkTyVarOcc "r") loc
; let rr_tv = mkTyVar rr_name runtimeRepTy
rr = mkTyVarTy rr_tv
res_tv = mkTyVar tv_name (tYPE rr)
res_ty = mkTyVarTy res_tv
is_unlifted = null args && null prov_dicts
(cont_args, cont_arg_tys)
| is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
| otherwise = (args, arg_tys)
cont_ty = mkInfSigmaTy ex_tvs prov_theta $
mkVisFunTys cont_arg_tys res_ty
fail_ty = mkVisFunTy voidPrimTy res_ty
; matcher_name <- newImplicitBinder name mkMatcherOcc
; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty
; cont <- newSysLocalId (fsLit "cont") cont_ty
; fail <- newSysLocalId (fsLit "fail") fail_ty
; let matcher_tau = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty
matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
matcher_id = mkExportedVanillaId matcher_name matcher_sigma
inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
fail' = nlHsApps fail [nlHsVar voidPrimId]
args = map nlVarPat [scrutinee, cont, fail]
lwpat = noLoc $ WildPat pat_ty
cases = if isIrrefutableHsPat lpat
then [mkHsCaseAlt lpat cont']
else [mkHsCaseAlt lpat cont',
mkHsCaseAlt lwpat fail']
body = mkLHsWrap (mkWpLet req_ev_binds) $
cL (getLoc lpat) $
HsCase noExtField (nlHsVar scrutinee) $
MG{ mg_alts = cL (getLoc lpat) cases
, mg_ext = MatchGroupTc [pat_ty] res_ty
, mg_origin = Generated
}
body' = noLoc $
HsLam noExtField $
MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
args body]
, mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty
, mg_origin = Generated
}
match = mkMatch (mkPrefixFunRhs (cL loc name)) []
(mkHsLams (rr_tv:res_tv:univ_tvs)
req_dicts body')
(noLoc (EmptyLocalBinds noExtField))
mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg = MG{ mg_alts = cL (getLoc match) [match]
, mg_ext = MatchGroupTc [] res_ty
, mg_origin = Generated
}
; let bind = FunBind{ fun_ext = emptyNameSet
, fun_id = cL loc matcher_id
, fun_matches = mg
, fun_co_fn = idHsWrapper
, fun_tick = [] }
matcher_bind = unitBag (noLoc bind)
; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
; traceTc "tcPatSynMatcher" (ppr matcher_bind)
; return ((matcher_id, is_unlifted), matcher_bind) }
mkPatSynRecSelBinds :: PatSyn
-> [FieldLabel]
-> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds ps fields
= [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
| fld_lbl <- fields ]
isUnidirectional :: HsPatSynDir a -> Bool
isUnidirectional Unidirectional = True
isUnidirectional ImplicitBidirectional = False
isUnidirectional ExplicitBidirectional{} = False
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
-> [TyVarBinder] -> ThetaType
-> [TyVarBinder] -> ThetaType
-> [Type] -> Type
-> TcM (Maybe (Id, Bool))
mkPatSynBuilderId dir (dL->L _ name)
univ_bndrs req_theta ex_bndrs prov_theta
arg_tys pat_ty
| isUnidirectional dir
= return Nothing
| otherwise
= do { builder_name <- newImplicitBinder name mkBuilderOcc
; let theta = req_theta ++ prov_theta
need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
builder_sigma = add_void need_dummy_arg $
mkForAllTys univ_bndrs $
mkForAllTys ex_bndrs $
mkPhiTy theta $
mkVisFunTys arg_tys $
pat_ty
builder_id = mkExportedVanillaId builder_name builder_sigma
builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id
; return (Just (builder_id', need_dummy_arg)) }
where
tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
-> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name)
, psb_def = lpat
, psb_dir = dir
, psb_args = details })
| isUnidirectional dir
= return emptyBag
| Left why <- mb_match_group
= setSrcSpan (getLoc lpat) $ failWithTc $
vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
<+> quotes (ppr name) <> colon)
2 why
, text "RHS pattern:" <+> ppr lpat ]
| Right match_group <- mb_match_group
= do { patsyn <- tcLookupPatSyn name
; case patSynBuilder patsyn of {
Nothing -> return emptyBag ;
Just (builder_id, need_dummy_arg) ->
do {
let match_group' | need_dummy_arg = add_dummy_arg match_group
| otherwise = match_group
bind = FunBind { fun_ext = placeHolderNamesTc
, fun_id = cL loc (idName builder_id)
, fun_matches = match_group'
, fun_co_fn = idHsWrapper
, fun_tick = [] }
sig = completeSigFromId (PatSynCtxt name) builder_id
; traceTc "tcPatSynBuilderBind {" $
ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
; return builder_binds } } }
| otherwise = panic "tcPatSynBuilderBind"
where
mb_match_group
= case dir of
ExplicitBidirectional explicit_mg -> Right explicit_mg
ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg body = mkMatchGroup Generated [builder_match]
where
builder_args = [cL loc (VarPat noExtField (cL loc n))
| (dL->L loc n) <- args]
builder_match = mkMatch (mkPrefixFunRhs (cL loc name))
builder_args body
(noLoc (EmptyLocalBinds noExtField))
args = case details of
PrefixCon args -> args
InfixCon arg1 arg2 -> [arg1, arg2]
RecCon args -> map recordPatSynPatVar args
add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
add_dummy_arg mg@(MG { mg_alts =
(dL->L l [dL->L loc
match@(Match { m_pats = pats })]) })
= mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] }
add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
pprMatches other_mg
tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcPatSynBuilderOcc ps
| Just (builder_id, add_void_arg) <- builder
, let builder_expr = HsConLikeOut noExtField (PatSynCon ps)
builder_ty = idType builder_id
= return $
if add_void_arg
then ( builder_expr
, tcFunResultTy builder_ty )
else (builder_expr, builder_ty)
| otherwise
= nonBidirectionalErr name
where
name = patSynName ps
builder = patSynBuilder ps
add_void :: Bool -> Type -> Type
add_void need_dummy_arg ty
| need_dummy_arg = mkVisFunTy voidPrimTy ty
| otherwise = ty
tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
-> Either MsgDoc (LHsExpr GhcRn)
tcPatToExpr name args pat = go pat
where
lhsVars = mkNameSet (map unLoc args)
mkPrefixConExpr :: Located Name -> [LPat GhcRn]
-> Either MsgDoc (HsExpr GhcRn)
mkPrefixConExpr lcon@(dL->L loc _) pats
= do { exprs <- mapM go pats
; return (foldl' (\x y -> HsApp noExtField (cL loc x) y)
(HsVar noExtField lcon) exprs) }
mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
-> Either MsgDoc (HsExpr GhcRn)
mkRecordConExpr con fields
= do { exprFields <- mapM go fields
; return (RecordCon noExtField con exprFields) }
go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
go (dL->L loc p) = cL loc <$> go1 p
go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
go1 (ConPatIn con info)
= case info of
PrefixCon ps -> mkPrefixConExpr con ps
InfixCon l r -> mkPrefixConExpr con [l,r]
RecCon fields -> mkRecordConExpr con fields
go1 (SigPat _ pat _) = go1 (unLoc pat)
go1 (VarPat _ (dL->L l var))
| var `elemNameSet` lhsVars
= return $ HsVar noExtField (cL l var)
| otherwise
= Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat
go1 p@(ListPat reb pats)
| Nothing <- reb = do { exprs <- mapM go pats
; return $ ExplicitList noExtField Nothing exprs }
| otherwise = notInvertibleListPat p
go1 (TuplePat _ pats box) = do { exprs <- mapM go pats
; return $ ExplicitTuple noExtField
(map (noLoc . (Present noExtField)) exprs)
box }
go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat)
; return $ ExplicitSum noExtField alt arity
(noLoc expr)
}
go1 (LitPat _ lit) = return $ HsLit noExtField lit
go1 (NPat _ (dL->L _ n) mb_neg _)
| Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg
[noLoc (HsOverLit noExtField n)]
| otherwise = return $ HsOverLit noExtField n
go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
go1 (CoPat{}) = panic "CoPat in output of renamer"
go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go1 pat
go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety"
go1 p@(BangPat {}) = notInvertible p
go1 p@(LazyPat {}) = notInvertible p
go1 p@(WildPat {}) = notInvertible p
go1 p@(AsPat {}) = notInvertible p
go1 p@(ViewPat {}) = notInvertible p
go1 p@(NPlusKPat {}) = notInvertible p
go1 p@(XPat {}) = notInvertible p
go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p
go1 p@(SplicePat _ (XSplice {})) = notInvertible p
notInvertible p = Left (not_invertible_msg p)
not_invertible_msg p
= text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
$+$ hang (text "Suggestion: instead use an explicitly bidirectional"
<+> text "pattern synonym, e.g.")
2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
<+> ppr pat <+> text "where")
2 (pp_name <+> pp_args <+> equals <+> text "..."))
where
pp_name = ppr name
pp_args = hsep (map ppr args)
notInvertibleListPat p
= Left (vcat [ not_invertible_msg p
, text "Reason: rebindable syntax is on."
, text "This is fixable: add use-case to #14380" ])
nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
text "non-bidirectional pattern synonym"
<+> quotes (ppr name) <+> text "used in an expression"
tcCollectEx
:: LPat GhcTc
-> ( [TyVar]
, [EvVar] )
tcCollectEx pat = go pat
where
go :: LPat GhcTc -> ([TyVar], [EvVar])
go = go1 . unLoc
go1 :: Pat GhcTc -> ([TyVar], [EvVar])
go1 (LazyPat _ p) = go p
go1 (AsPat _ _ p) = go p
go1 (ParPat _ p) = go p
go1 (BangPat _ p) = go p
go1 (ListPat _ ps) = mergeMany . map go $ ps
go1 (TuplePat _ ps _) = mergeMany . map go $ ps
go1 (SumPat _ p _ _) = go p
go1 (ViewPat _ _ p) = go p
go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $
goConDetails $ pat_args con
go1 (SigPat _ p _) = go p
go1 (CoPat _ _ p _) = go1 p
go1 (NPlusKPat _ n k _ geq subtract)
= pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
go1 _ = empty
goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
goConDetails (PrefixCon ps) = mergeMany . map go $ ps
goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
goConDetails (RecCon HsRecFields{ rec_flds = flds })
= mergeMany . map goRecFd $ flds
goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p
merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)
mergeMany = foldr merge empty
empty = ([], [])