module TcPatSyn ( tcPatSynSig, tcInferPatSynDecl, tcCheckPatSynDecl
, tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
) where
import HsSyn
import TcPat
import TcHsType( tcImplicitTKBndrs, tcExplicitTKBndrs
, tcHsContext, tcHsLiftedType, tcHsOpenType )
import TcRnMonad
import TcEnv
import TcMType
import TysPrim
import TysWiredIn ( runtimeRepTy )
import Name
import SrcLoc
import PatSyn
import NameSet
import Panic
import Outputable
import FastString
import Var
import VarEnv( emptyTidyEnv )
import Type( tidyTyCoVarBndrs, tidyTypes, tidyType )
import Id
import IdInfo( RecSelParent(..))
import TcBinds
import BasicTypes
import TcSimplify
import TcUnify
import TcType
import Type
import TcEvidence
import BuildTyCl
import VarSet
import MkId
import TcTyDecls
import ConLike
import FieldLabel
import Bag
import Util
import ErrUtils
import Control.Monad ( unless, zipWithM )
import Data.List( partition )
import Pair( Pair(..) )
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid( mconcat, mappend, mempty )
import Data.Traversable( mapM )
import Prelude hiding ( mapM )
#endif
#include "HsVersions.h"
tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo
tcPatSynSig name sig_ty
| HsIB { hsib_vars = implicit_hs_tvs
, hsib_body = hs_ty } <- sig_ty
, (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTy hs_ty
, (ex_hs_tvs, hs_prov, hs_ty2) <- splitLHsSigmaTy hs_ty1
, (hs_arg_tys, hs_body_ty) <- splitHsFunType hs_ty2
= do { (implicit_tvs, (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty))
<- solveEqualities $
tcImplicitTKBndrs implicit_hs_tvs $
tcExplicitTKBndrs univ_hs_tvs $ \ univ_tvs ->
tcExplicitTKBndrs ex_hs_tvs $ \ ex_tvs ->
do { req <- tcHsContext hs_req
; prov <- tcHsContext hs_prov
; arg_tys <- mapM tcHsOpenType (hs_arg_tys :: [LHsType Name])
; body_ty <- tcHsLiftedType hs_body_ty
; let bound_tvs
= unionVarSets [ allBoundVariabless req
, allBoundVariabless prov
, allBoundVariabless (body_ty : arg_tys)
]
; return ( (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty)
, bound_tvs) }
; free_kvs <- zonkTcTypeAndFV $
mkSpecForAllTys (implicit_tvs ++ univ_tvs) $
mkFunTys req $
mkSpecForAllTys ex_tvs $
mkFunTys prov $
mkFunTys arg_tys $
body_ty
; kvs <- quantifyZonkedTyVars emptyVarSet (Pair free_kvs emptyVarSet)
; traceTc "about zonk" empty
; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs
; univ_tvs <- mapM zonkTcTyCoVarBndr univ_tvs
; ex_tvs <- mapM zonkTcTyCoVarBndr ex_tvs
; req <- zonkTcTypes req
; prov <- zonkTcTypes prov
; arg_tys <- zonkTcTypes arg_tys
; body_ty <- zonkTcType body_ty
; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType body_ty) ex_tvs
; unless (null bad_tvs) $ addErr $
hang (text "The result type" <+> quotes (ppr body_ty))
2 (text "mentions existential type variable" <> plural bad_tvs
<+> pprQuotedList bad_tvs)
; let univ_fvs = closeOverKinds $
(tyCoVarsOfTypes (body_ty : req) `extendVarSetList` univ_tvs)
(extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) .
binderVar "tcPatSynSig") $
mkNamedBinders Invisible kvs ++
mkNamedBinders Specified implicit_tvs
; traceTc "tcTySig }" $
vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
, text "kvs" <+> ppr_tvs kvs
, text "extra_univ" <+> ppr extra_univ
, text "univ_tvs" <+> ppr_tvs univ_tvs
, text "req" <+> ppr req
, text "extra_ex" <+> ppr extra_ex
, text "ex_tvs" <+> ppr_tvs ex_tvs
, text "prov" <+> ppr prov
, text "arg_tys" <+> ppr arg_tys
, text "body_ty" <+> ppr body_ty ]
; return (TPSI { patsig_name = name
, patsig_univ_bndrs = extra_univ ++
mkNamedBinders Specified univ_tvs
, patsig_req = req
, patsig_ex_bndrs = extra_ex ++
mkNamedBinders Specified ex_tvs
, patsig_prov = prov
, patsig_arg_tys = arg_tys
, patsig_body_ty = body_ty }) }
where
ppr_tvs :: [TyVar] -> SDoc
ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
| tv <- tvs])
tcInferPatSynDecl :: PatSynBind Name Name
-> TcM (LHsBinds Id, TcGblEnv)
tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
psb_def = lpat, psb_dir = dir }
= addPatSynCtxt lname $
do { traceTc "tcInferPatSynDecl {" $ ppr name
; tcCheckPatSynPat lpat
; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
; (tclvl, wanted, ((lpat', args), pat_ty))
<- pushLevelAndCaptureConstraints $
do { pat_ty <- newOpenInferExpType
; stuff <- tcPat PatSyn lpat pat_ty $
mapM tcLookupId arg_names
; pat_ty <- readExpType pat_ty
; return (stuff, pat_ty) }
; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
; let (ex_vars, prov_dicts) = tcCollectEx lpat'
univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs
ex_tvs = varSetElems ex_vars
prov_theta = map evVarPred prov_dicts
req_theta = map evVarPred req_dicts
; traceTc "tcInferPatSynDecl }" $ ppr name
; tc_patsyn_finish lname dir is_infix lpat'
(univ_tvs, mkNamedBinders Invisible univ_tvs
, req_theta, ev_binds, req_dicts)
(ex_tvs, mkNamedBinders Invisible ex_tvs
, mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
(map nlHsVar args, map idType args)
pat_ty rec_fields }
tcCheckPatSynDecl :: PatSynBind Name Name
-> TcPatSynInfo
-> TcM (LHsBinds Id, TcGblEnv)
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
, psb_def = lpat, psb_dir = dir }
TPSI{ patsig_univ_bndrs = univ_bndrs, patsig_prov = prov_theta
, patsig_ex_bndrs = ex_bndrs, patsig_req = req_theta
, patsig_arg_tys = arg_tys, patsig_body_ty = pat_ty }
= addPatSynCtxt lname $
do { let origin = ProvCtxtOrigin psb
skol_info = PatSynSigSkol name
decl_arity = length arg_names
ty_arity = length arg_tys
(arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
univ_tvs = map (binderVar "tcCheckPatSynDecl 1") univ_bndrs
ex_tvs = map (binderVar "tcCheckPatSynDecl 2") ex_bndrs
; traceTc "tcCheckPatSynDecl" $
vcat [ ppr univ_bndrs, ppr req_theta, ppr ex_bndrs
, ppr prov_theta, ppr arg_tys, ppr pat_ty ]
; checkTc (decl_arity == ty_arity)
(wrongNumberOfParmsErr name decl_arity ty_arity)
; tcCheckPatSynPat lpat
; 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 { (subst, ex_tvs') <- if isUnidirectional dir
then newMetaTyVars ex_tvs
else newMetaSigTyVars 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'])
; prov_dicts <- mapM (emitWanted origin)
(substTheta (extendTCvInScopeList subst univ_tvs) prov_theta)
; args' <- zipWithM (tc_arg subst) arg_names arg_tys
; return (ex_tvs', prov_dicts, args') }
; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
; _ <- simplifyTop (mkImplicWC implics)
; traceTc "tcCheckPatSynDecl }" $ ppr name
; tc_patsyn_finish lname dir is_infix lpat'
(univ_tvs, univ_bndrs, req_theta, ev_binds, req_dicts)
(ex_tvs, ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
(args', arg_tys)
pat_ty rec_fields }
where
tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId)
tc_arg subst arg_name arg_ty
= do {
arg_id <- tcLookupId arg_name
; coi <- unifyType (Just arg_id)
(idType arg_id)
(substTyUnchecked subst arg_ty)
; return (mkLHsWrapCo coi $ nlHsVar arg_id) }
collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
collectPatSynArgInfo details =
case details of
PrefixPatSyn names -> (map unLoc names, [], False)
InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
RecordPatSyn names ->
let (vars, sels) = unzip (map splitRecordPatSyn names)
in (vars, sels, False)
where
splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
, recordPatSynSelectorId = L _ selId })
= (patVar, selId)
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (L loc name) thing_inside
= setSrcSpan loc $
addErrCtxt (text "In the declaration for pattern synonym"
<+> quotes (ppr name)) $
thing_inside
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> SDoc
wrongNumberOfParmsErr name decl_arity ty_arity
= hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
<+> speakNOf decl_arity (text "argument"))
2 (text "but its type signature has" <+> speakN ty_arity)
tc_patsyn_finish :: Located Name
-> HsPatSynDir Name
-> Bool
-> LPat Id
-> ([TcTyVar], [TcTyBinder], [PredType], TcEvBinds, [EvVar])
-> ([TcTyVar], [TcTyBinder], [TcType], [PredType], [EvTerm])
-> ([LHsExpr TcId], [TcType])
-> TcType
-> [Name]
-> TcM (LHsBinds Id, TcGblEnv)
tc_patsyn_finish lname dir is_infix lpat'
(univ_tvs, univ_bndrs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_bndrs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys)
pat_ty field_labels
= do {
univ_tvs' <- mapMaybeM zonkQuantifiedTyVar univ_tvs
; ex_tvs' <- mapMaybeM zonkQuantifiedTyVar ex_tvs
; prov_theta' <- zonkTcTypes prov_theta
; req_theta' <- zonkTcTypes req_theta
; pat_ty' <- zonkTcType pat_ty
; arg_tys' <- zonkTcTypes arg_tys
; let (env1, univ_tvs) = tidyTyCoVarBndrs emptyTidyEnv univ_tvs'
(env2, ex_tvs) = tidyTyCoVarBndrs 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'
; let update_binders :: [TyVar] -> [TcTyBinder] -> [TyBinder]
update_binders [] _ = []
update_binders all_tvs@(tv:tvs) (bndr:bndrs)
| tv == bndr_var
= mkNamedBinder (binderVisibility bndr) tv : update_binders tvs bndrs
| otherwise
= update_binders all_tvs bndrs
where
bndr_var = binderVar "tc_patsyn_finish" bndr
update_binders tvs _ = pprPanic "tc_patsyn_finish" (ppr lname $$ ppr tvs)
univ_bndrs' = update_binders univ_tvs univ_bndrs
ex_bndrs' = update_binders ex_tvs ex_bndrs
; traceTc "tc_patsyn_finish {" $
ppr (unLoc lname) $$ ppr (unLoc lpat') $$
ppr (univ_tvs, univ_bndrs', req_theta, req_ev_binds, req_dicts) $$
ppr (ex_tvs, ex_bndrs', prov_theta, prov_dicts) $$
ppr args $$
ppr arg_tys $$
ppr pat_ty
; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys)
pat_ty
; builder_id <- mkPatSynBuilderId dir lname
univ_bndrs' req_theta
ex_bndrs' prov_theta
arg_tys pat_ty
; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name
field_labels' = (map mkFieldLabel field_labels)
; let patSyn = mkPatSyn (unLoc lname) is_infix
(univ_tvs, univ_bndrs', req_theta)
(ex_tvs, ex_bndrs', prov_theta)
arg_tys
pat_ty
matcher_id builder_id
field_labels'
; let (sigs, selector_binds) =
unzip (mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn))
; let tything = AConLike (PatSynCon patSyn)
; tcg_env <-
tcExtendGlobalEnv [tything] $
tcRecSelBinds
(ValBindsOut (zip (repeat NonRecursive) selector_binds) sigs)
; traceTc "tc_patsyn_finish }" empty
; return (matcher_bind, tcg_env) }
tcPatSynMatcher :: Located Name
-> LPat Id
-> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
-> ([TcTyVar], [TcType], ThetaType, [EvTerm])
-> ([LHsExpr TcId], [TcType])
-> TcType
-> TcM ((Id, Bool), LHsBinds Id)
tcPatSynMatcher (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_uniq <- newUnique
; tv_uniq <- newUnique
; let rr_name = mkInternalName rr_uniq (mkTyVarOcc "rep") loc
tv_name = mkInternalName tv_uniq (mkTyVarOcc "r") loc
rr_tv = mkTcTyVar rr_name runtimeRepTy (SkolemTv False)
rr = mkTyVarTy rr_tv
res_tv = mkTcTyVar tv_name (tYPE rr) (SkolemTv False)
is_unlifted = null args && null prov_dicts
res_ty = mkTyVarTy res_tv
(cont_args, cont_arg_tys)
| is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
| otherwise = (args, arg_tys)
cont_ty = mkInvSigmaTy ex_tvs prov_theta $
mkFunTys cont_arg_tys res_ty
fail_ty = mkFunTy 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 = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
matcher_sigma = mkInvSigmaTy (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 [mkSimpleHsAlt lpat cont']
else [mkSimpleHsAlt lpat cont',
mkSimpleHsAlt lwpat fail']
body = mkLHsWrap (mkWpLet req_ev_binds) $
L (getLoc lpat) $
HsCase (nlHsVar scrutinee) $
MG{ mg_alts = L (getLoc lpat) cases
, mg_arg_tys = [pat_ty]
, mg_res_ty = res_ty
, mg_origin = Generated
}
body' = noLoc $
HsLam $
MG{ mg_alts = noLoc [mkSimpleMatch args body]
, mg_arg_tys = [pat_ty, cont_ty, res_ty]
, mg_res_ty = res_ty
, mg_origin = Generated
}
match = mkMatch [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body')
(noLoc EmptyLocalBinds)
mg = MG{ mg_alts = L (getLoc match) [match]
, mg_arg_tys = []
, mg_res_ty = res_ty
, mg_origin = Generated
}
; let bind = FunBind{ fun_id = L loc matcher_id
, fun_matches = mg
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet
, 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]
-> [(LSig Name, LHsBinds Name)]
mkPatSynRecSelBinds ps fields = map mkRecSel fields
where
mkRecSel fld_lbl =
case mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl of
(name, (_rec_flag, binds)) -> (name, binds)
isUnidirectional :: HsPatSynDir a -> Bool
isUnidirectional Unidirectional = True
isUnidirectional ImplicitBidirectional = False
isUnidirectional ExplicitBidirectional{} = False
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
-> [TyBinder] -> ThetaType
-> [TyBinder] -> ThetaType
-> [Type] -> Type
-> TcM (Maybe (Id, Bool))
mkPatSynBuilderId dir (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 $
mkFunTys theta $
mkFunTys arg_tys $
pat_ty
builder_id = mkExportedVanillaId builder_name builder_sigma
; return (Just (builder_id, need_dummy_arg)) }
where
tcPatSynBuilderBind :: TcSigFun
-> PatSynBind Name Name
-> TcM (LHsBinds Id)
tcPatSynBuilderBind sig_fun PSB{ psb_id = 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
; traceTc "tcPatSynBuilderBind {" $ ppr patsyn
; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
match_group' | need_dummy_arg = add_dummy_arg match_group
| otherwise = match_group
bind = FunBind { fun_id = L loc (idName builder_id)
, fun_matches = match_group'
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNamesTc
, fun_tick = [] }
; sig <- get_builder_sig sig_fun name builder_id need_dummy_arg
; (builder_binds, _) <- tcPolyCheck NonRecursive 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 args lpat)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
mk_mg body = mkMatchGroupName Generated [builder_match]
where
builder_args = [L loc (VarPat (L loc n)) | L loc n <- args]
builder_match = mkMatch builder_args body (noLoc EmptyLocalBinds)
args = case details of
PrefixPatSyn args -> args
InfixPatSyn arg1 arg2 -> [arg1, arg2]
RecordPatSyn args -> map recordPatSynPatVar args
add_dummy_arg :: MatchGroup Name (LHsExpr Name)
-> MatchGroup Name (LHsExpr Name)
add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] })
= mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
pprMatches (PatSyn :: HsMatchContext Name) other_mg
get_builder_sig :: TcSigFun -> Name -> Id -> Bool -> TcM TcIdSigInfo
get_builder_sig sig_fun name builder_id need_dummy_arg
| Just (TcPatSynSig sig) <- sig_fun name
, TPSI { patsig_univ_bndrs = univ_bndrs
, patsig_req = req
, patsig_ex_bndrs = ex_bndrs
, patsig_prov = prov
, patsig_arg_tys = arg_tys
, patsig_body_ty = body_ty } <- sig
=
return (TISI { sig_bndr = CompleteSig builder_id
, sig_skols = [ (tyVarName tv, tv)
| bndr <- univ_bndrs ++ ex_bndrs
, let tv = binderVar "get_builder_sig" bndr ]
, sig_theta = req ++ prov
, sig_tau = add_void need_dummy_arg $
mkFunTys arg_tys body_ty
, sig_ctxt = PatSynBuilderCtxt name
, sig_loc = getSrcSpan name })
| otherwise
=
instTcTySigFromId builder_id
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType)
tcPatSynBuilderOcc ps
| Just (builder_id, add_void_arg) <- builder
, let builder_expr = HsVar (noLoc builder_id)
builder_ty = idType builder_id
= return $
if add_void_arg
then ( HsApp (noLoc $ builder_expr) (nlHsVar voidPrimId)
, 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 = mkFunTy voidPrimTy ty
| otherwise = ty
tcPatToExpr :: [Located Name] -> LPat Name -> Either MsgDoc (LHsExpr Name)
tcPatToExpr args pat = go pat
where
lhsVars = mkNameSet (map unLoc args)
mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name)
mkPrefixConExpr lcon@(L loc _) pats
= do { exprs <- mapM go pats
; return (foldl (\x y -> HsApp (L loc x) y)
(HsVar lcon) exprs) }
mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name)
-> Either MsgDoc (HsExpr Name)
mkRecordConExpr con fields
= do { exprFields <- mapM go fields
; return (RecordCon con PlaceHolder noPostTcExpr exprFields) }
go :: LPat Name -> Either MsgDoc (LHsExpr Name)
go (L loc p) = L loc <$> go1 p
go1 :: Pat Name -> Either MsgDoc (HsExpr Name)
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 (SigPatIn pat _) = go1 (unLoc pat)
go1 (VarPat (L l var))
| var `elemNameSet` lhsVars
= return $ HsVar (L l var)
| otherwise
= Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
go1 (ParPat pat) = fmap HsPar $ go pat
go1 (LazyPat pat) = go1 (unLoc pat)
go1 (BangPat pat) = go1 (unLoc pat)
go1 (PArrPat pats ptt) = do { exprs <- mapM go pats
; return $ ExplicitPArr ptt exprs }
go1 (ListPat pats ptt reb) = do { exprs <- mapM go pats
; return $ ExplicitList ptt (fmap snd reb) exprs }
go1 (TuplePat pats box _) = do { exprs <- mapM go pats
; return $ ExplicitTuple
(map (noLoc . Present) exprs) box }
go1 (LitPat lit) = return $ HsLit lit
go1 (NPat (L _ n) mb_neg _ _)
| Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]
| otherwise = return $ HsOverLit n
go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
go1 (CoPat{}) = panic "CoPat in output of renamer"
go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible")
tcCheckPatSynPat :: LPat Name -> TcM ()
tcCheckPatSynPat = go
where
go :: LPat Name -> TcM ()
go = addLocM go1
go1 :: Pat Name -> TcM ()
go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
go1 VarPat{} = return ()
go1 WildPat{} = return ()
go1 p@(AsPat _ _) = asPatInPatSynErr p
go1 (LazyPat pat) = go pat
go1 (ParPat pat) = go pat
go1 (BangPat pat) = go pat
go1 (PArrPat pats _) = mapM_ go pats
go1 (ListPat pats _ _) = mapM_ go pats
go1 (TuplePat pats _ _) = mapM_ go pats
go1 LitPat{} = return ()
go1 NPat{} = return ()
go1 (SigPatIn pat _) = go pat
go1 (ViewPat _ pat _) = go pat
go1 p@SplicePat{} = thInPatSynErr p
go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
go1 ConPatOut{} = panic "ConPatOut in output of renamer"
go1 SigPatOut{} = panic "SigPatOut in output of renamer"
go1 CoPat{} = panic "CoPat in output of renamer"
asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
asPatInPatSynErr pat
= failWithTc $
hang (text "Pattern synonym definition cannot contain as-patterns (@):")
2 (ppr pat)
thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
thInPatSynErr pat
= failWithTc $
hang (text "Pattern synonym definition cannot contain Template Haskell:")
2 (ppr pat)
nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
nPlusKPatInPatSynErr pat
= failWithTc $
hang (text "Pattern synonym definition cannot contain n+k-pattern:")
2 (ppr pat)
nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
text "non-bidirectional pattern synonym"
<+> quotes (ppr name) <+> text "used in an expression"
tcCollectEx :: LPat Id -> (TyVarSet, [EvVar])
tcCollectEx pat = go pat
where
go :: LPat Id -> (TyVarSet, [EvVar])
go = go1 . unLoc
go1 :: Pat Id -> (TyVarSet, [EvVar])
go1 (LazyPat p) = go p
go1 (AsPat _ p) = go p
go1 (ParPat p) = go p
go1 (BangPat p) = go p
go1 (ListPat ps _ _) = mconcat . map go $ ps
go1 (TuplePat ps _ _) = mconcat . map go $ ps
go1 (PArrPat ps _) = mconcat . map go $ ps
go1 (ViewPat _ p _) = go p
go1 con@ConPatOut{} = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
goConDetails $ pat_args con
go1 (SigPatOut 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 _ = mempty
goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
goConDetails (PrefixCon ps) = mconcat . map go $ ps
goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
goConDetails (RecCon HsRecFields{ rec_flds = flds })
= mconcat . map goRecFd $ flds
goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p