Commit ac2796e6 authored by cactus's avatar cactus

Store IfExtNames for PatSyn matchers and wrappers in interface file.

This way, the Ids for the matchers/wrappers are reused by importing
modules, and thus unfoldings are kept.

Also updates haddock submodule to accomodate tweaks in PatSyn representation
parent 6ed54303
......@@ -13,7 +13,7 @@ module PatSyn (
-- ** Type deconstruction
patSynId, patSynType, patSynArity, patSynIsInfix,
patSynArgs, patSynArgTys, patSynTyDetails,
patSynArgs, patSynTyDetails,
patSynWrapper, patSynMatcher,
patSynExTyVars, patSynSig, patSynInstArgTys
) where
......@@ -38,8 +38,8 @@ import Data.Function
\end{code}
Pattern synonym representation
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Pattern synonym representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym declaration
pattern P x = MkT [x] (Just 42)
......@@ -59,15 +59,49 @@ with the following typeclass constraints:
In this case, the fields of MkPatSyn will be set as follows:
psArgs = [x :: b]
psArgs = [b]
psArity = 1
psInfix = False
psUnivTyVars = [t]
psExTyVars = [b]
psTheta = ((Show (Maybe t), Ord b), (Eq t, Num t))
psProvTheta = (Show (Maybe t), Ord b)
psReqTheta = (Eq t, Num t)
psOrigResTy = T (Maybe t)
Note [Matchers and wrappers for pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For each pattern synonym, we generate a single matcher function which
implements the actual matching. For the above example, the matcher
will have type:
$mP :: forall r t. (Eq t, Num t)
=> T (Maybe t)
-> (forall b. (Show (Maybe t), Ord b) => b -> r)
-> r
-> r
with the following implementation:
$mP @r @t $dEq $dNum scrut cont fail = case scrut of
MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
_ -> fail
For *bidirectional* pattern synonyms, we also generate a single wrapper
function which implements the pattern synonym in an expression
context. For our running example, it will be:
$WP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t)
=> b -> T (Maybe t)
$WP x = MkT [x] (Just 42)
NB: the existential/universal and required/provided split does not
apply to the wrapper since you are only putting stuff in, not getting
stuff out.
Injectivity of bidirectional pattern synonyms is checked in
tcPatToExpr which walks the pattern and returns its corresponding
expression when available.
%************************************************************************
%* *
......@@ -77,21 +111,36 @@ In this case, the fields of MkPatSyn will be set as follows:
\begin{code}
-- | A pattern synonym
-- See Note [Pattern synonym representation]
data PatSyn
= MkPatSyn {
psId :: Id,
psUnique :: Unique, -- Cached from Name
psMatcher :: Id,
psWrapper :: Maybe Id,
psUnique :: Unique, -- Cached from Name
psArgs :: [Type],
psArity :: Arity, -- == length psArgs
psInfix :: Bool, -- True <=> declared infix
psArgs :: [Var],
psArity :: Arity, -- == length psArgs
psInfix :: Bool, -- True <=> declared infix
psUnivTyVars :: [TyVar], -- Universially-quantified type variables
psExTyVars :: [TyVar], -- Existentially-quantified type vars
psProvTheta :: ThetaType, -- Provided dictionaries
psReqTheta :: ThetaType, -- Required dictionaries
psOrigResTy :: Type,
psUnivTyVars :: [TyVar], -- Universially-quantified type variables
psExTyVars :: [TyVar], -- Existentially-quantified type vars
psTheta :: (ThetaType, ThetaType), -- Provided and required dictionaries
psOrigResTy :: Type
-- See Note [Matchers and wrappers for pattern synonyms]
psMatcher :: Id,
-- Matcher function, of type
-- forall r univ_tvs. req_theta
-- => res_ty
-- -> (forall ex_tvs. prov_theta -> arg_tys -> r)
-- -> r -> r
psWrapper :: Maybe Id
-- Nothing => uni-directional pattern synonym
-- Just wid => bi-direcitonal
-- Wrapper function, of type
-- forall univ_tvs, ex_tvs. (prov_theta, req_theta)
-- => arg_tys -> res_ty
}
deriving Data.Typeable.Typeable
\end{code}
......@@ -145,7 +194,7 @@ instance Data.Data PatSyn where
-- | Build a new pattern synonym
mkPatSyn :: Name
-> Bool -- ^ Is the pattern synonym declared infix?
-> [Var] -- ^ Original arguments
-> [Type] -- ^ Original arguments
-> [TyVar] -- ^ Universially-quantified type variables
-> [TyVar] -- ^ Existentially-quantified type variables
-> ThetaType -- ^ Wanted dicts
......@@ -161,7 +210,7 @@ mkPatSyn name declared_infix orig_args
matcher wrapper
= MkPatSyn {psId = id, psUnique = getUnique name,
psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
psTheta = (prov_theta, req_theta),
psProvTheta = prov_theta, psReqTheta = req_theta,
psInfix = declared_infix,
psArgs = orig_args,
psArity = length orig_args,
......@@ -171,7 +220,7 @@ mkPatSyn name declared_infix orig_args
where
pat_ty = mkSigmaTy univ_tvs req_theta $
mkSigmaTy ex_tvs prov_theta $
mkFunTys (map varType orig_args) orig_res_ty
mkFunTys orig_args orig_res_ty
id = mkLocalId name pat_ty
\end{code}
......@@ -191,22 +240,21 @@ patSynIsInfix = psInfix
patSynArity :: PatSyn -> Arity
patSynArity = psArity
patSynArgs :: PatSyn -> [Var]
patSynArgs :: PatSyn -> [Type]
patSynArgs = psArgs
patSynArgTys :: PatSyn -> [Type]
patSynArgTys = map varType . patSynArgs
patSynTyDetails :: PatSyn -> HsPatSynDetails Type
patSynTyDetails ps = case (patSynIsInfix ps, patSynArgTys ps) of
patSynTyDetails ps = case (patSynIsInfix ps, patSynArgs ps) of
(True, [left, right]) -> InfixPatSyn left right
(_, tys) -> PrefixPatSyn tys
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars
patSynSig :: PatSyn -> ([TyVar], [TyVar], (ThetaType, ThetaType))
patSynSig ps = (psUnivTyVars ps, psExTyVars ps, psTheta ps)
patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
, psProvTheta = prov, psReqTheta = req })
= (univ_tvs, ex_tvs, prov, req)
patSynWrapper :: PatSyn -> Maybe Id
patSynWrapper = psWrapper
......@@ -218,9 +266,8 @@ patSynInstArgTys :: PatSyn -> [Type] -> [Type]
patSynInstArgTys ps inst_tys
= ASSERT2( length tyvars == length inst_tys
, ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
map (substTyWith tyvars inst_tys) (psArgs ps)
where
(univ_tvs, ex_tvs, _) = patSynSig ps
arg_tys = map varType (psArgs ps)
(univ_tvs, ex_tvs, _, _) = patSynSig ps
tyvars = univ_tvs ++ ex_tvs
\end{code}
......@@ -196,6 +196,7 @@ corePrepTopBinds initialCorePrepEnv binds
mkDataConWorkers :: [TyCon] -> [CoreBind]
-- See Note [Data constructor workers]
-- c.f. Note [Injecting implicit bindings] in TidyPgm
mkDataConWorkers data_tycons
= [ NonRec id (Var id) -- The ice is thin here, but it works
| tycon <- data_tycons, -- CorePrep will eta-expand it
......
......@@ -16,7 +16,7 @@ module BuildTyCl (
buildSynTyCon,
buildAlgTyCon,
buildDataCon,
buildPatSyn, mkPatSynMatcherId, mkPatSynWrapperId,
buildPatSyn,
TcMethInfo, buildClass,
distinctAbstractTyConRhs, totallyAbstractTyConRhs,
mkNewTyConRhs, mkDataTyConRhs,
......@@ -37,10 +37,9 @@ import MkId
import Class
import TyCon
import Type
import TypeRep
import TcType
import Id
import Coercion
import TcType
import DynFlags
import TcRnMonad
......@@ -185,66 +184,28 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
buildPatSyn :: Name -> Bool -> Bool
-> [Var]
buildPatSyn :: Name -> Bool
-> Id -> Maybe Id
-> [Type]
-> [TyVar] -> [TyVar] -- Univ and ext
-> ThetaType -> ThetaType -- Prov and req
-> Type -- Result type
-> TyVar
-> TcRnIf m n PatSyn
buildPatSyn src_name declared_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
= do { (matcher, _, _) <- mkPatSynMatcherId src_name args
univ_tvs ex_tvs
prov_theta req_theta
pat_ty tv
; wrapper <- case has_wrapper of
False -> return Nothing
True -> fmap Just $
mkPatSynWrapperId src_name args
(univ_tvs ++ ex_tvs) (prov_theta ++ req_theta)
pat_ty
; return $ mkPatSyn src_name declared_infix
args
univ_tvs ex_tvs
prov_theta req_theta
pat_ty
matcher
wrapper }
mkPatSynMatcherId :: Name
-> [Var]
-> [TyVar]
-> [TyVar]
-> ThetaType -> ThetaType
-> Type
-> TyVar
-> TcRnIf n m (Id, Type, Type)
mkPatSynMatcherId name args univ_tvs ex_tvs prov_theta req_theta pat_ty res_tv
= do { matcher_name <- newImplicitBinder name mkMatcherOcc
; let res_ty = TyVarTy res_tv
cont_ty = mkSigmaTy ex_tvs prov_theta $
mkFunTys (map varType args) res_ty
; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
matcher_id = mkVanillaGlobal matcher_name matcher_sigma
; return (matcher_id, res_ty, cont_ty) }
mkPatSynWrapperId :: Name
-> [Var]
-> [TyVar]
-> ThetaType
-> Type
-> TcRnIf n m Id
mkPatSynWrapperId name args qtvs theta pat_ty
= do { wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
; let wrapper_tau = mkFunTys (map varType args) pat_ty
wrapper_sigma = mkSigmaTy qtvs theta wrapper_tau
; let wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
; return wrapper_id }
-> PatSyn
buildPatSyn src_name declared_infix matcher wrapper
args univ_tvs ex_tvs prov_theta req_theta pat_ty
= mkPatSyn src_name declared_infix
args
univ_tvs ex_tvs
prov_theta req_theta
pat_ty
matcher
wrapper
where
-- TODO: assert that these match the ones in the parameters
((_:_univ_tvs'), _req_theta', tau) = tcSplitSigmaTy $ idType matcher
([_pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
(_ex_tvs', _prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
(_args', _) = tcSplitFunTys cont_tau
\end{code}
......
......@@ -60,6 +60,7 @@ import HsBinds
import Control.Monad
import System.IO.Unsafe
import Data.Maybe (isJust)
infixl 3 &&&
\end{code}
......@@ -121,13 +122,16 @@ data IfaceDecl
ifExtName :: Maybe FastString }
| IfacePatSyn { ifName :: OccName, -- Name of the pattern synonym
ifPatHasWrapper :: Bool,
ifPatIsInfix :: Bool,
ifPatMatcher :: IfExtName,
ifPatWrapper :: Maybe IfExtName,
-- Everything below is redundant,
-- but needed to implement pprIfaceDecl
ifPatUnivTvs :: [IfaceTvBndr],
ifPatExTvs :: [IfaceTvBndr],
ifPatProvCtxt :: IfaceContext,
ifPatReqCtxt :: IfaceContext,
ifPatArgs :: [IfaceIdBndr],
ifPatArgs :: [IfaceType],
ifPatTy :: IfaceType }
-- A bit of magic going on here: there's no need to store the OccName
......@@ -187,7 +191,7 @@ instance Binary IfaceDecl where
put_ bh a3
put_ bh a4
put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9) = do
put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
putByte bh 6
put_ bh (occNameFS name)
put_ bh a2
......@@ -198,6 +202,7 @@ instance Binary IfaceDecl where
put_ bh a7
put_ bh a8
put_ bh a9
put_ bh a10
get bh = do
h <- getByte bh
......@@ -254,8 +259,9 @@ instance Binary IfaceDecl where
a7 <- get bh
a8 <- get bh
a9 <- get bh
a10 <- get bh
occ <- return $! mkOccNameFS dataName a1
return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9)
return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10)
_ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
data IfaceSynTyConRhs
......@@ -1016,11 +1022,6 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
dc_occ = mkClassDataConOcc cls_tc_occ
is_newtype = n_sigs + n_ctxt == 1 -- Sigh
ifaceDeclImplicitBndrs (IfacePatSyn{ ifName = ps_occ, ifPatHasWrapper = has_wrapper })
= [wrap_occ | has_wrapper]
where
wrap_occ = mkDataConWrapperOcc ps_occ -- Id namespace
ifaceDeclImplicitBndrs _ = []
-- -----------------------------------------------------------------------------
......@@ -1104,7 +1105,7 @@ pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branche
= hang (ptext (sLit "axiom") <+> ppr name <> dcolon)
2 (vcat $ map (pprAxBranch $ Just tycon) branches)
pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap,
pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
ifPatIsInfix = is_infix,
ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
......@@ -1112,7 +1113,8 @@ pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap,
ifPatTy = ty })
= pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
where
args' = case (is_infix, map snd args) of
has_wrap = isJust wrapper
args' = case (is_infix, args) of
(True, [left_ty, right_ty]) ->
InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty)
(_, tys) ->
......@@ -1393,11 +1395,13 @@ freeNamesIfDecl d@IfaceAxiom{} =
freeNamesIfTc (ifTyCon d) &&&
fnList freeNamesIfAxBranch (ifAxBranches d)
freeNamesIfDecl d@IfacePatSyn{} =
unitNameSet (ifPatMatcher d) &&&
maybe emptyNameSet unitNameSet (ifPatWrapper d) &&&
freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
freeNamesIfTvBndrs (ifPatExTvs d) &&&
freeNamesIfContext (ifPatProvCtxt d) &&&
freeNamesIfContext (ifPatReqCtxt d) &&&
fnList freeNamesIfType (map snd (ifPatArgs d)) &&&
fnList freeNamesIfType (ifPatArgs d) &&&
freeNamesIfType (ifPatTy d)
freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
......
......@@ -417,7 +417,6 @@ loadDecl ignore_prags mod (_version, decl)
= do { -- Populate the name cache with final versions of all
-- the names associated with the decl
main_name <- lookupOrig mod (ifName decl)
-- ; traceIf (text "Loading decl for " <> ppr main_name)
-- Typecheck the thing, lazily
-- NB. Firstly, the laziness is there in case we never need the
......@@ -491,6 +490,8 @@ loadDecl ignore_prags mod (_version, decl)
pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
-- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)
; return $ (main_name, thing) :
-- uses the invariant that implicit_names and
-- implictTyThings are bijective
......
......@@ -1490,25 +1490,26 @@ dataConToIfaceDecl dataCon
patSynToIfaceDecl :: PatSyn -> IfaceDecl
patSynToIfaceDecl ps
= IfacePatSyn { ifName = getOccName . getName $ ps
, ifPatHasWrapper = isJust $ patSynWrapper ps
, ifPatMatcher = matcher
, ifPatWrapper = wrapper
, ifPatIsInfix = patSynIsInfix ps
, ifPatUnivTvs = toIfaceTvBndrs univ_tvs'
, ifPatExTvs = toIfaceTvBndrs ex_tvs'
, ifPatProvCtxt = tidyToIfaceContext env2 prov_theta
, ifPatReqCtxt = tidyToIfaceContext env2 req_theta
, ifPatArgs = map toIfaceArg args
, ifPatArgs = map (tidyToIfaceType env2) args
, ifPatTy = tidyToIfaceType env2 rhs_ty
}
where
toIfaceArg var = (occNameFS (getOccName var),
tidyToIfaceType env2 (varType var))
(univ_tvs, ex_tvs, (prov_theta, req_theta)) = patSynSig ps
(univ_tvs, ex_tvs, prov_theta, req_theta) = patSynSig ps
args = patSynArgs ps
rhs_ty = patSynType ps
(env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
(env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
matcher = idName (patSynMatcher ps)
wrapper = fmap idName (patSynWrapper ps)
--------------------------
coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
......
......@@ -584,7 +584,8 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
; return (ACoAxiom axiom) }
tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
, ifPatHasWrapper = has_wrapper
, ifPatMatcher = matcher_name
, ifPatWrapper = wrapper_name
, ifPatIsInfix = is_infix
, ifPatUnivTvs = univ_tvs
, ifPatExTvs = ex_tvs
......@@ -594,20 +595,24 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
, ifPatTy = pat_ty })
= do { name <- lookupIfaceTop occ_name
; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
; matcher <- tcExt "Matcher" matcher_name
; wrapper <- case wrapper_name of
Nothing -> return Nothing
Just wn -> do { wid <- tcExt "Wrapper" wn
; return (Just wid) }
; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
{ bindIfaceTyVars ex_tvs $ \ex_tvs -> do
{ bindIfaceIdVars args $ \args -> do
{ ~(prov_theta, req_theta, pat_ty) <- forkM (mk_doc name) $
{ patsyn <- forkM (mk_doc name) $
do { prov_theta <- tcIfaceCtxt prov_ctxt
; req_theta <- tcIfaceCtxt req_ctxt
; pat_ty <- tcIfaceType pat_ty
; return (prov_theta, req_theta, pat_ty) }
; bindIfaceTyVar (fsLit "r", toIfaceKind liftedTypeKind) $ \tv -> do
{ patsyn <- buildPatSyn name is_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
; return (AConLike (PatSynCon patsyn)) }}}}}
; arg_tys <- mapM tcIfaceType args
; return $ buildPatSyn name is_infix matcher wrapper
arg_tys univ_tvs ex_tvs prov_theta req_theta pat_ty }
; return $ AConLike . PatSynCon $ patsyn }}}
where
mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
tcExt s name = forkM (ptext (sLit s) <+> ppr name) $ tcIfaceExtId name
tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches
......@@ -1516,20 +1521,6 @@ bindIfaceTyVars bndrs thing_inside
where
(occs,kinds) = unzip bndrs
bindIfaceIdVar :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
bindIfaceIdVar (occ, ty) thing_inside
= do { name <- newIfaceName (mkVarOccFS occ)
; ty' <- tcIfaceType ty
; let id = mkLocalId name ty'
; extendIfaceIdEnv [id] (thing_inside id) }
bindIfaceIdVars :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
bindIfaceIdVars [] thing_inside = thing_inside []
bindIfaceIdVars (v:vs) thing_inside
= bindIfaceIdVar v $ \ v' ->
bindIfaceIdVars vs $ \ vs' ->
thing_inside (v':vs')
isSuperIfaceKind :: IfaceKind -> Bool
isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName
isSuperIfaceKind _ = False
......
......@@ -1505,15 +1505,17 @@ implicitTyThings :: TyThing -> [TyThing]
implicitTyThings (AnId _) = []
implicitTyThings (ACoAxiom _cc) = []
implicitTyThings (ATyCon tc) = implicitTyConThings tc
implicitTyThings (AConLike cl) = case cl of
RealDataCon dc ->
-- For data cons add the worker and (possibly) wrapper
map AnId (dataConImplicitIds dc)
PatSynCon ps ->
-- For bidirectional pattern synonyms, add the wrapper
case patSynWrapper ps of
Nothing -> []
Just id -> [AnId id]
implicitTyThings (AConLike cl) = implicitConLikeThings cl
implicitConLikeThings :: ConLike -> [TyThing]
implicitConLikeThings (RealDataCon dc)
= map AnId (dataConImplicitIds dc)
-- For data cons add the worker and (possibly) wrapper
implicitConLikeThings (PatSynCon {})
= [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher
-- are not "implicit"; they are simply new top-level bindings,
-- and they have their own declaration in an interface fiel
implicitClassThings :: Class -> [TyThing]
implicitClassThings cl
......
......@@ -562,7 +562,7 @@ Oh: two other reasons for injecting them late:
There is one sort of implicit binding that is injected still later,
namely those for data constructor workers. Reason (I think): it's
really just a code generation trick.... binding itself makes no sense.
See CorePrep Note [Data constructor workers].
See Note [Data constructor workers] in CorePrep.
\begin{code}
getTyConImplicitBinds :: TyCon -> [CoreBind]
......
......@@ -791,8 +791,8 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn
-> HsConPatDetails Name -> TcM a
-> TcM (Pat TcId, a)
tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
= do { let (univ_tvs, ex_tvs, (prov_theta, req_theta)) = patSynSig pat_syn
arg_tys = patSynArgTys pat_syn
= do { let (univ_tvs, ex_tvs, prov_theta, req_theta) = patSynSig pat_syn
arg_tys = patSynArgs pat_syn
ty = patSynType pat_syn
; (_univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs
......
......@@ -33,31 +33,11 @@ import Data.Monoid
import Bag
import TcEvidence
import BuildTyCl
import TypeRep
#include "HsVersions.h"
\end{code}
Note [Pattern synonym typechecking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym declaration
pattern P x = MkT [x] (Just 42)
where
data T a where
MkT :: (Show a, Ord b) => [b] -> a -> T a
The pattern synonym's type is described with five axes, given here for
the above example:
Pattern type: T (Maybe t)
Arguments: [x :: b]
Universal type variables: [t]
Required theta: (Eq t, Num t)
Existential type variables: [b]
Provided theta: (Show (Maybe t), Ord b)
\begin{code}
tcPatSynDecl :: Located Name
-> HsPatSynDetails (Located Name)
......@@ -120,7 +100,7 @@ tcPatSynDecl lname@(L _ name) details lpat dir
; traceTc "tcPatSynDecl }" $ ppr name
; let patSyn = mkPatSyn name is_infix
args
(map varType args)
univ_tvs ex_tvs
prov_theta req_theta
pat_ty
......@@ -129,40 +109,6 @@ tcPatSynDecl lname@(L _ name) details lpat dir
\end{code}
Note [Matchers and wrappers for pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For each pattern synonym, we generate a single matcher function which
implements the actual matching. For the above example, the matcher
will have type:
$mP :: forall r t. (Eq t, Num t)
=> T (Maybe t)
-> (forall b. (Show (Maybe t), Ord b) => b -> r)
-> r
-> r
with the following implementation:
$mP @r @t $dEq $dNum scrut cont fail = case scrut of
MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
_ -> fail
For bidirectional pattern synonyms, we also generate a single wrapper
function which implements the pattern synonym in an expression
context. For our running example, it will be:
$WP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t)
=> b -> T (Maybe t)
$WP x = MkT [x] (Just 42)
N.b. the existential/universal and required/provided split does not
apply to the wrapper since you are only putting stuff in, not getting
stuff out.
Injectivity of bidirectional pattern synonyms is checked in
tcPatToExpr which walks the pattern and returns its corresponding
expression when available.
\begin{code}
tcPatSynMatcher :: Located Name
......@@ -174,12 +120,18 @@ tcPatSynMatcher :: Located Name
-> ThetaType -> ThetaType
-> TcType
-> TcM (Id, LHsBinds Id)
-- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
= do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind
; (matcher_id, res_ty, cont_ty) <- mkPatSynMatcherId name args
univ_tvs ex_tvs
prov_theta req_theta
pat_ty res_tv
; matcher_name <- newImplicitBinder name mkMatcherOcc
; let res_ty = TyVarTy res_tv
cont_ty = mkSigmaTy ex_tvs prov_theta $
mkFunTys (map varType args) res_ty
; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
matcher_id = mkVanillaGlobal matcher_name matcher_sigma
; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
; let matcher_lid = L loc matcher_id
......@@ -243,6 +195,7 @@ tcPatSynWrapper :: Located Name
-> ThetaType
-> TcType
-> TcM (Maybe (Id, LHsBinds Id))
-- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty
= do { let argNames = mkNameSet (map Var.varName args)
; case (dir, tcPatToExpr argNames lpat) of
......@@ -262,18 +215,16 @@ tc_pat_syn_wrapper_from_expr :: Located Name
-> TcM (Id, LHsBinds Id)
tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_ty
= do { let qtvs = univ_tvs ++ ex_tvs
; (subst, qtvs') <- tcInstSkolTyVars qtvs