Commit cce6318e authored by Gergő Érdi's avatar Gergő Érdi
Browse files

Add support for pattern synonym type signatures.

Syntax is of the form

    pattern P :: (Prov b) => (Req a) => a -> b -> Int -> T a

which declares a pattern synonym called `P`, with argument types `a`, `b`,
and `Int`, and result type `T a`, with provided context `(Prov b)` and required
context `(Req a)`.

The Haddock submodule is also updated to use this new syntax in generated docs.
parent 3b81309c
......@@ -569,12 +569,12 @@ data Sig name
TypeSig [Located name] (LHsType name)
-- | A pattern synonym type signature
-- @pattern (Eq b) => P a b :: (Num a) => T a
-- @pattern type forall b. (Eq b) => P a b :: forall a. (Num a) => T a
| PatSynSig (Located name)
(HsPatSynDetails (LHsType name))
(LHsType name) -- Type
(HsExplicitFlag, LHsTyVarBndrs name)
(LHsContext name) -- Provided context
(LHsContext name) -- Required contex
(LHsContext name) -- Required context
(LHsType name)
-- | A type signature for a default method inside a class
--
......@@ -731,34 +731,23 @@ ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (ppr ty) i
ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
ppr_sig (MinimalSig bf) = pragBrackets (pprMinimalSig bf)
ppr_sig (PatSynSig name arg_tys ty prov req)
= pprPatSynSig (unLoc name) False args (ppr ty) (pprCtx prov) (pprCtx req)
ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty)
= pprPatSynSig (unLoc name) False -- TODO: is_bindir
(pprHsForAll flag qtvs (noLoc []))
(pprHsContextMaybe prov) (pprHsContextMaybe req)
(ppr ty)
pprPatSynSig :: (OutputableBndr name)
=> name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
pprPatSynSig ident _is_bidir tvs prov req ty
= ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+>
tvs <+> context <+> ty
where
args = fmap ppr arg_tys
pprCtx lctx = case unLoc lctx of
[] -> Nothing
ctx -> Just (pprHsContextNoArrow ctx)
pprPatSynSig :: (OutputableBndr a)
=> a -> Bool -> HsPatSynDetails SDoc -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc
pprPatSynSig ident is_bidir args rhs_ty prov_theta req_theta
= sep [ ptext (sLit "pattern")
, thetaOpt prov_theta, name_and_args
, colon
, thetaOpt req_theta, rhs_ty
]
where
name_and_args = case args of
PrefixPatSyn arg_tys ->
pprPrefixOcc ident <+> sep arg_tys
InfixPatSyn left_ty right_ty ->
left_ty <+> pprInfixOcc ident <+> right_ty
-- TODO: support explicit foralls
thetaOpt = maybe empty (<+> darrow)
colon = if is_bidir then dcolon else dcolon -- TODO
context = case (prov, req) of
(Nothing, Nothing) -> empty
(Nothing, Just req) -> parens empty <+> darrow <+> req <+> darrow
(Just prov, Nothing) -> prov <+> darrow
(Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)]
......
......@@ -43,7 +43,8 @@ module HsTypes (
splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
-- Printing
pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow,
pprParendHsType, pprHsForAll,
pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
) where
import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
......@@ -63,6 +64,7 @@ import Outputable
import FastString
import Data.Data hiding ( Fixity )
import Data.Maybe ( fromMaybe )
\end{code}
......@@ -604,13 +606,15 @@ pprHsForAll exp qtvs cxt
forall_part = forAllLit <+> ppr qtvs <> dot
pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContext [] = empty
pprHsContext cxt = pprHsContextNoArrow cxt <+> darrow
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContextNoArrow [] = empty
pprHsContextNoArrow [L _ pred] = ppr_mono_ty FunPrec pred
pprHsContextNoArrow cxt = parens (interpp'SP cxt)
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
pprHsContextMaybe :: (OutputableBndr name) => HsContext name -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
......
......@@ -760,24 +760,19 @@ pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars
pp_branches _ = Outputable.empty
pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker,
ifPatIsInfix = is_infix,
ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
ifPatArgs = args,
ifPatTy = ty })
= pprPatSynSig name is_bidirectional args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
ifPatArgs = arg_tys,
ifPatTy = pat_ty} )
= pprPatSynSig name is_bidirectional
(pprUserIfaceForAll tvs)
(pprIfaceContextMaybe prov_ctxt)
(pprIfaceContextMaybe req_ctxt)
(pprIfaceType ty)
where
is_bidirectional = isJust worker
args' = case (is_infix, args) of
(True, [left_ty, right_ty]) ->
InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty)
(_, tys) ->
PrefixPatSyn (map pprParendIfaceType tys)
ty' = pprParendIfaceType ty
pprCtxt [] = Nothing
pprCtxt ctxt = Just $ pprIfaceContext ctxt
tvs = univ_tvs ++ ex_tvs
ty = foldr IfaceFunTy pat_ty arg_tys
pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
ifIdDetails = details, ifIdInfo = info })
......
......@@ -27,7 +27,8 @@ module IfaceType (
toIfaceCoercion,
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceContextArr,
pprIfaceType, pprParendIfaceType,
pprIfaceContext, pprIfaceContextArr, pprIfaceContextMaybe,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
......@@ -63,6 +64,7 @@ import Binary
import Outputable
import FastString
import UniqSet
import Data.Maybe( fromMaybe )
\end{code}
%************************************************************************
......@@ -703,12 +705,15 @@ instance Binary IfaceTcArgs where
-------------------
pprIfaceContextArr :: Outputable a => [a] -> SDoc
-- Prints "(C a, D b) =>", including the arrow
pprIfaceContextArr [] = empty
pprIfaceContextArr theta = pprIfaceContext theta <+> darrow
pprIfaceContextArr = maybe empty (<+> darrow) . pprIfaceContextMaybe
pprIfaceContext :: Outputable a => [a] -> SDoc
pprIfaceContext [pred] = ppr pred -- No parens
pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds)))
pprIfaceContext = fromMaybe (parens empty) . pprIfaceContextMaybe
pprIfaceContextMaybe :: Outputable a => [a] -> Maybe SDoc
pprIfaceContextMaybe [] = Nothing
pprIfaceContextMaybe [pred] = Just $ ppr pred -- No parens
pprIfaceContextMaybe preds = Just $ parens (fsep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
put_ bh (IfaceForAllTy aa ab) = do
......
......@@ -866,29 +866,47 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 }
-- Glasgow extension: pattern synonyms
pattern_synonym_decl :: { LHsDecl RdrName }
: 'pattern' pat '=' pat
{% do { (name, args) <- splitPatSyn $2
; return $ sLL $1 $> . ValD $ mkPatSynBind name args $4 ImplicitBidirectional
}}
| 'pattern' pat '<-' pat
{% do { (name, args) <- splitPatSyn $2
; return $ sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional
}}
| 'pattern' pat '<-' pat where_decls
{% do { (name, args) <- splitPatSyn $2
; mg <- toPatSynMatchGroup name $5
: 'pattern' pattern_synonym_lhs '=' pat
{ let (name, args) = $2
in sLL $1 $> . ValD $ mkPatSynBind name args $4 ImplicitBidirectional }
| 'pattern' pattern_synonym_lhs '<-' pat
{ let (name, args) = $2
in sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional }
| 'pattern' pattern_synonym_lhs '<-' pat where_decls
{% do { let (name, args) = $2
; mg <- mkPatSynMatchGroup name $5
; return $ sLL $1 $> . ValD $
mkPatSynBind name args $4 (ExplicitBidirectional mg)
}}
mkPatSynBind name args $4 (ExplicitBidirectional mg) }}
where_decls :: { Located (OrdList (LHsDecl RdrName)) }
: 'where' '{' decls '}' { $3 }
| 'where' vocurly decls close { $3 }
pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName)) }
: con vars0 { ($1, PrefixPatSyn $2) }
| varid consym varid { ($2, InfixPatSyn $1 $3) }
vars0 :: { [Located RdrName] }
: {- empty -} { [] }
| varid vars0 { $1 : $2 }
where_decls :: { Located (OrdList (LHsDecl RdrName)) }
: 'where' '{' decls '}' { $3 }
| 'where' vocurly decls close { $3 }
pattern_synonym_sig :: { LSig RdrName }
: 'pattern' con '::' ptype
{ let (flag, qtvs, prov, req, ty) = unLoc $4
in sLL $1 $> $ PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty }
ptype :: { Located (HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName, LHsContext RdrName, LHsType RdrName) }
: 'forall' tv_bndrs '.' ptype
{% do { hintExplicitForall (getLoc $1)
; let (_, qtvs', prov, req, ty) = unLoc $4
; return $ sLL $1 $> (Explicit, $2 ++ qtvs', prov, req ,ty) }}
| context '=>' context '=>' type
{ sLL $1 $> (Implicit, [], $1, $3, $5) }
| context '=>' type
{ sLL $1 $> (Implicit, [], $1, noLoc [], $3) }
| type
{ sL1 $1 (Implicit, [], noLoc [], noLoc [], $1) }
-----------------------------------------------------------------------------
-- Nested declarations
......@@ -1496,6 +1514,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
{ sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
| infix prec ops { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| n <- unLoc $3 ] }
| pattern_synonym_sig { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 }
| '{-# INLINE' activation qvar '#-}'
{ sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
......
......@@ -18,7 +18,7 @@ module RdrHsSyn (
mkTyFamInst,
mkFamDecl,
splitCon, mkInlinePragma,
splitPatSyn, toPatSynMatchGroup,
mkPatSynMatchGroup,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
mkTyClD, mkInstD,
......@@ -414,33 +414,16 @@ splitCon ty
mk_rest [L _ (HsRecTy flds)] = RecCon flds
mk_rest ts = PrefixCon ts
splitPatSyn :: LPat RdrName
-> P (Located RdrName, HsPatSynDetails (Located RdrName))
splitPatSyn (L _ (ParPat pat)) = splitPatSyn pat
splitPatSyn pat@(L loc (ConPatIn con details)) = do
details' <- case details of
PrefixCon pats -> liftM PrefixPatSyn (mapM patVar pats)
InfixCon pat1 pat2 -> liftM2 InfixPatSyn (patVar pat1) (patVar pat2)
RecCon{} -> recordPatSynErr loc pat
return (con, details')
where
patVar :: LPat RdrName -> P (Located RdrName)
patVar (L loc (VarPat v)) = return $ L loc v
patVar (L _ (ParPat pat)) = patVar pat
patVar (L loc pat) = parseErrorSDoc loc $
text "Pattern synonym arguments must be variable names:" $$
ppr pat
splitPatSyn pat@(L loc _) = parseErrorSDoc loc $
text "invalid pattern synonym declaration:" $$ ppr pat
recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
recordPatSynErr loc pat =
parseErrorSDoc loc $
text "record syntax not supported for pattern synonym declarations:" $$
ppr pat
toPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl RdrName)) -> P (MatchGroup RdrName (LHsExpr RdrName))
toPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
mkPatSynMatchGroup :: Located RdrName
-> Located (OrdList (LHsDecl RdrName))
-> P (MatchGroup RdrName (LHsExpr RdrName))
mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
do { matches <- mapM fromDecl (fromOL decls)
; return $ mkMatchGroup FromSource matches }
where
......
......@@ -30,7 +30,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import TcRnMonad
import TcEvidence ( emptyTcEvBinds )
import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch, rnContext )
import RnTypes
import RnPat
import RnNames
import RnEnv
......@@ -841,23 +841,29 @@ renameSig ctxt sig@(MinimalSig bf)
= do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
return (MinimalSig new_bf, emptyFVs)
renameSig ctxt sig@(PatSynSig v args ty prov req)
= do v' <- lookupSigOccRn ctxt sig v
let doc = quotes (ppr v)
rn_type = rnHsSigType doc
(ty', fvs1) <- rn_type ty
(args', fvs2) <- case args of
PrefixPatSyn tys ->
do (tys, fvs) <- unzip <$> mapM rn_type tys
return (PrefixPatSyn tys, plusFVs fvs)
InfixPatSyn left right ->
do (left', fvs1) <- rn_type left
(right', fvs2) <- rn_type right
return (InfixPatSyn left' right', fvs1 `plusFV` fvs2)
(prov', fvs3) <- rnContext (TypeSigCtx doc) prov
(req', fvs4) <- rnContext (TypeSigCtx doc) req
let fvs = plusFVs [fvs1, fvs2, fvs3, fvs4]
return (PatSynSig v' args' ty' prov' req', fvs)
renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty)
= do { v' <- lookupSigOccRn ctxt sig v
; let doc = TypeSigCtx $ quotes (ppr v)
; loc <- getSrcSpanM
; let (tv_kvs, mentioned) = extractHsTysRdrTyVars (ty:unLoc prov ++ unLoc req)
; tv_bndrs <- case flag of
Implicit ->
return $ mkHsQTvs . userHsTyVarBndrs loc $ mentioned
Explicit ->
do { let heading = ptext (sLit "In the pattern synonym type signature")
<+> quotes (ppr sig)
; warnUnusedForAlls (heading $$ docOfHsDocContext doc) qtvs mentioned
; return qtvs }
Qualified -> panic "renameSig: Qualified"
; bindHsTyVars doc Nothing tv_kvs tv_bndrs $ \ tyvars -> do
{ (prov', fvs1) <- rnContext doc prov
; (req', fvs2) <- rnContext doc req
; (ty', fvs3) <- rnLHsType doc ty
; let fvs = plusFVs [fvs1, fvs2, fvs3]
; return (PatSynSig v' (flag, tyvars) prov' req' ty', fvs) }}
ppr_sig_bndrs :: [Located RdrName] -> SDoc
ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
......
This diff is collapsed.
......@@ -238,7 +238,9 @@ tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
tcInstanceMethodBody skol_info tyvars dfun_ev_vars
meth_id local_meth_sig
specs (L loc bind)
= do { let local_meth_id = sig_id local_meth_sig
= do { let local_meth_id = case local_meth_sig of
TcSigInfo{ sig_id = meth_id } -> meth_id
_ -> pprPanic "tcInstanceMethodBody" (ppr local_meth_sig)
lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
......
......@@ -9,7 +9,8 @@ TcPat: Typechecking patterns
{-# LANGUAGE CPP, RankNTypes #-}
module TcPat ( tcLetPat, TcSigFun, TcPragFun
, TcSigInfo(..), findScopedTyVars
, TcSigInfo(..), TcPatSynInfo(..)
, findScopedTyVars
, LetBndrSpec(..), addInlinePrags, warnPrags
, tcPat, tcPats, newNoSigLetBndr
, addDataConStupidTheta, badFieldCon, polyPatSig ) where
......@@ -152,6 +153,17 @@ data TcSigInfo
sig_loc :: SrcSpan -- The location of the signature
}
| TcPatSynInfo TcPatSynInfo
data TcPatSynInfo
= TPSI {
patsig_name :: Name,
patsig_tau :: TcSigmaType,
patsig_ex :: [TcTyVar],
patsig_prov :: TcThetaType,
patsig_univ :: [TcTyVar],
patsig_req :: TcThetaType
}
findScopedTyVars -- See Note [Binding scoped type variables]
:: LHsType Name -- The HsType
......@@ -171,10 +183,19 @@ findScopedTyVars hs_ty sig_ty inst_tvs
scoped_names = mkNameSet (hsExplicitTvs hs_ty)
(sig_tvs,_) = tcSplitForAllTys sig_ty
instance NamedThing TcSigInfo where
getName TcSigInfo{ sig_id = id } = idName id
getName (TcPatSynInfo tpsi) = patsig_name tpsi
instance Outputable TcSigInfo where
ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
= ppr id <+> dcolon <+> vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau)
, ppr (map fst tyvars) ]
ppr (TcPatSynInfo tpsi) = text "TcPatSynInfo" <+> ppr tpsi
instance Outputable TcPatSynInfo where
ppr (TPSI{ patsig_name = name}) = ppr name
\end{code}
Note [Binding scoped type variables]
......
......@@ -7,7 +7,7 @@
\begin{code}
{-# LANGUAGE CPP #-}
module TcPatSyn (tcPatSynDecl, mkPatSynWrapperId, tcPatSynWorker) where
module TcPatSyn (tcInferPatSynDecl, tcCheckPatSynDecl, mkPatSynWrapperId, tcPatSynWorker) where
import HsSyn
import TcPat
......@@ -28,32 +28,38 @@ import Id
import TcBinds
import BasicTypes
import TcSimplify
import TcUnify
import TcType
import TcEvidence
import BuildTyCl
import VarSet
import MkId
import VarEnv
import Inst
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid
#endif
import Bag
import TcEvidence
import BuildTyCl
import Util
import Data.Maybe
import Control.Monad (forM)
#include "HsVersions.h"
\end{code}
\begin{code}
tcPatSynDecl :: PatSynBind Name Name
-> TcM (PatSyn, LHsBinds Id)
tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
psb_def = lpat, psb_dir = dir }
= do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
tcInferPatSynDecl :: PatSynBind Name Name
-> TcM (PatSyn, LHsBinds Id)
tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
psb_def = lpat, psb_dir = dir }
= setSrcSpan loc $
do { traceTc "tcInferPatSynDecl {" $ ppr name
; tcCheckPatSynPat lpat
; let (arg_names, is_infix) = case details of
PrefixPatSyn names -> (map unLoc names, False)
InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True)
; (((lpat', (args, pat_ty)), untch), wanted)
; (((lpat', (args, pat_ty)), untch), wanted)
<- captureConstraints $
captureUntouchables $
do { pat_ty <- newFlexiTyVarTy openTypeKind
......@@ -63,7 +69,6 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
; traceTc "tcPatSynDecl::wanted" (ppr named_taus $$ ppr wanted)
; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer untch False named_taus wanted
; (ex_vars, prov_dicts) <- tcCollectEx lpat'
......@@ -74,76 +79,163 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
; univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs
; ex_tvs <- mapM zonkQuantifiedTyVar ex_tvs
; prov_theta <- zonkTcThetaType prov_theta
; req_theta <- zonkTcThetaType req_theta
; pat_ty <- zonkTcType pat_ty
; args <- mapM zonkId args
; let arg_tys = map varType args
; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$
ppr prov_theta $$
ppr prov_dicts)
; traceTc "tcPatSynDecl: univ" (ppr univ_tvs $$
ppr req_theta $$
ppr req_dicts $$
ppr ev_binds)
; let qtvs = univ_tvs ++ ex_tvs
; let theta = req_theta ++ prov_theta
; traceTc "tcPatSynDecl: type" (ppr name $$
ppr univ_tvs $$
ppr (map varType args) $$
ppr pat_ty)
; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' args
univ_tvs ex_tvs
ev_binds
prov_dicts req_dicts
prov_theta req_theta
; traceTc "tcInferPatSynDecl }" $ ppr name
; tc_patsyn_finish lname dir is_infix lpat'
(univ_tvs, req_theta, ev_binds, req_dicts)
(ex_tvs, map mkTyVarTy ex_tvs, prov_theta, emptyTcEvBinds, prov_dicts)
(zip args $ repeat idHsWrapper)
pat_ty }
tcCheckPatSynDecl :: PatSynBind Name Name
-> TcPatSynInfo
-> TcM (PatSyn, LHsBinds Id)
tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
psb_def = lpat, psb_dir = dir }
TPSI{ patsig_tau = tau,
patsig_ex = ex_tvs, patsig_univ = univ_tvs,
patsig_prov = prov_theta, patsig_req = req_theta }
= setSrcSpan loc $
do { traceTc "tcCheckPatSynDecl" $
ppr (ex_tvs, prov_theta) $$
ppr (univ_tvs, req_theta) $$
ppr arg_tys $$
ppr tau
; tcCheckPatSynPat lpat
; req_dicts <- newEvVars req_theta
-- TODO: find a better SkolInfo
; let skol_info = SigSkol (FunSigCtxt name) (mkFunTys arg_tys pat_ty)
; let (arg_names, is_infix) = case details of
PrefixPatSyn names -> (map unLoc names, False)
InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True)
; let ty_arity = length arg_tys
; checkTc (length arg_names == ty_arity)
(wrongNumberOfParmsErr ty_arity)
-- Typecheck the pattern against pat_ty, then unify the type of args
-- against arg_tys, with ex_tvs changed to SigTyVars.
-- We get out of this:
-- * The evidence bindings for the requested theta: req_ev_binds
-- * The typechecked pattern: lpat'
-- * The arguments, type-coerced to the SigTyVars: wrapped_args
-- * The instantiation of ex_tvs to pass to the success continuation: ex_tys
-- * The provided theta substituted with the SigTyVars: prov_theta'
; (req_ev_binds, (lpat', (ex_tys, prov_theta', wrapped_args))) <-
checkConstraints skol_info univ_tvs req_dicts $
tcPat PatSyn lpat pat_ty $ do
{ ex_sigtvs <- mapM (\tv -> newSigTyVar (getName tv) (tyVarKind tv)) ex_tvs
; let subst = mkTvSubst (mkInScopeSet (zipVarEnv ex_sigtvs ex_sigtvs)) $
zipTyEnv ex_tvs (map mkTyVarTy ex_sigtvs)
; let ex_tys = substTys subst $ map mkTyVarTy ex_tvs
prov_theta' = substTheta subst prov_theta
; wrapped_args <- forM (zipEqual "tcCheckPatSynDecl" arg_names arg_tys) $ \(arg_name, arg_ty) -> do
{ arg <- tcLookupId arg_name
; let arg_ty' = substTy subst arg_ty
; coi <- unifyType (varType arg) arg_ty'
; return (setVarType arg arg_ty, coToHsWrapper coi) }
; return (ex_tys, prov_theta', wrapped_args) }
; (ex_vars_rhs, prov_dicts_rhs) <- tcCollectEx lpat'
; let ex_tvs_rhs = varSetElems ex_vars_rhs
-- Check that prov_theta' can be satisfied with the dicts from the pattern
; (prov_ev_binds, prov_dicts) <-
checkConstraints skol_info ex_tvs_rhs prov_dicts_rhs $ do
{ let origin = PatOrigin -- TODO
; emitWanteds origin prov_theta' }
; traceTc "tcCheckPatSynDecl }" $ ppr name
; tc_patsyn_finish lname dir is_infix lpat'
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts)
wrapped_args
pat_ty }
where
(arg_tys, pat_ty) = tcSplitFunTys tau
wrongNumberOfParmsErr :: Arity -> SDoc
wrongNumberOfParmsErr ty_arity
= ptext (sLit "Number of pattern synonym arguments doesn't match type; expected")
<+> ppr ty_arity
tc_patsyn_finish :: Located Name
-> HsPatSynDir Name
-> Bool
-> LPat Id
-> ([TcTyVar], [PredType], TcEvBinds, [EvVar])
-> ([TcTyVar], [TcType], [PredType], TcEvBinds, [EvVar])
-> [(Var, HsWrapper)]
-> TcType
-> TcM (PatSyn, LHsBinds Id)
tc_patsyn_finish lname dir is_infix lpat'
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
wrapped_args
pat_ty
= do { (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
wrapped_args
pat_ty
; wrapper_ids <- if isBidirectional dir
then fmap Just $ mkPatSynWrapperIds lname
qtvs theta
arg_tys pat_ty
then fmap Just $ mkPatSynWrapperIds lname qtvs theta arg_tys pat_ty
else return Nothing
; traceTc "tcPatSynDecl }" $ ppr name
; let patSyn = mkPatSyn name is_infix
; let patSyn = mkPatSyn (unLoc lname) is_infix
(univ_tvs, req_theta)
(ex_tvs, prov_theta)
arg_tys
pat_ty
matcher_id wrapper_ids
; return (patSyn, matcher_bind) }
where
qtvs = univ_tvs ++ ex_tvs
theta = prov_theta ++ req_theta
arg_tys = map (varType . fst) wrapped_args