Commit e8762081 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Rejig builders for pattern synonyms, especially unlifted ones

When a pattern synonym is for an unlifted pattern, its "builder" would
naturally be a top-level unlifted binding, which isn't allowed.  So we
give it an extra Void# argument.

Our Plan A involved then making *two* Ids for these builders, with
some consequential fuss in the desugarer.  This was more pain than I
liked, so I've re-jigged it.

 * There is just one builder for a pattern synonym.

 * It may have an extra Void# arg, but this decision is signalled
   by the Bool in the psBuilder field.

   I did the same for the psMatcher field.

   Both Bools are serialised into interface files, so there is
   absolutely no doubt whether that extra Void# argument is required.

 * I renamed "wrapper" to "builder".  We have too may "wrappers"

 * In order to deal with typecchecking occurrences of P in expressions,
   I refactored the tcInferId code in TcExpr.

All of this allowed me to revert 5fe872
   "Apply compulsory unfoldings during desugaring, except for `seq` which is special."
which turned out to be a rather messy hack in DsBinds
parent eac9bbec
......@@ -14,8 +14,7 @@ module PatSyn (
-- ** Type deconstruction
patSynName, patSynArity, patSynIsInfix,
patSynArgs, patSynTyDetails, patSynType,
patSynMatcher,
patSynWrapper, patSynWorker,
patSynMatcher, patSynBuilder,
patSynExTyVars, patSynSig,
patSynInstArgTys, patSynInstResTy,
tidyPatSynIds
......@@ -37,10 +36,62 @@ import HsBinds( HsPatSynDetails(..) )
import qualified Data.Data as Data
import qualified Data.Typeable
import Data.Function
import Control.Arrow (second)
\end{code}
%************************************************************************
%* *
\subsection{Pattern synonyms}
%* *
%************************************************************************
\begin{code}
-- | A pattern synonym
-- See Note [Pattern synonym representation]
data PatSyn
= MkPatSyn {
psName :: Name,
psUnique :: Unique, -- Cached from Name
psArgs :: [Type],
psArity :: Arity, -- == length psArgs
psInfix :: Bool, -- True <=> declared infix
psUnivTyVars :: [TyVar], -- Universially-quantified type variables
psReqTheta :: ThetaType, -- Required dictionaries
psExTyVars :: [TyVar], -- Existentially-quantified type vars
psProvTheta :: ThetaType, -- Provided dictionaries
psOrigResTy :: Type, -- Mentions only psUnivTyVars
-- See Note [Matchers and builders for pattern synonyms]
psMatcher :: (Id, Bool),
-- Matcher function.
-- If Bool is True then prov_theta and arg_tys are empty
-- and type is
-- forall (r :: ?) univ_tvs. req_theta
-- => res_ty
-- -> (forall ex_tvs. Void# -> r)
-- -> (Void# -> r)
-- -> r
--
-- Otherwise type is
-- forall (r :: ?) univ_tvs. req_theta
-- => res_ty
-- -> (forall ex_tvs. prov_theta => arg_tys -> r)
-- -> (Void# -> r)
-- -> r
psBuilder :: Maybe (Id, Bool)
-- Nothing => uni-directional pattern synonym
-- Just (builder, is_unlifted) => bi-directional
-- Wrapper function, of type
-- forall univ_tvs, ex_tvs. (prov_theta, req_theta)
-- => arg_tys -> res_ty
-- See Note [Builder for pattern synonyms with unboxed type]
}
deriving Data.Typeable.Typeable
\end{code}
Note [Pattern synonym representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym declaration
......@@ -72,11 +123,17 @@ In this case, the fields of MkPatSyn will be set as follows:
psReqTheta = (Eq t, Num t)
psOrigResTy = T (Maybe t)
Note [Matchers and wrappers for pattern synonyms]
Note [Matchers and builders 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:
For each pattern synonym P, we generate
* a "matcher" function, used to desugar uses of P in patterns,
which implements pattern matching
* A "builder" function (for bidirectional pattern synonyms only),
used to desugar uses of P in expressions, which constructs P-values.
For the above example, the matcher function has type:
$mP :: forall (r :: ?) t. (Eq t, Num t)
=> T (Maybe t)
......@@ -86,16 +143,22 @@ will have type:
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 Void#
$mP @r @t $dEq $dNum scrut cont fail
= case scrut of
MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
_ -> fail Void#
Notice that the return type 'r' has an open kind, so that it can
be instantiated by an unboxed type; for example where we see
f (P x) = 3#
The extra Void# argument for the failure continuation is needed so that
it is lazy even when the result type is unboxed. For the same reason,
if the pattern has no arguments, an extra Void# argument is added
to the success continuation as well.
it is lazy even when the result type is unboxed.
For *bidirectional* pattern synonyms, we also generate a single wrapper
For the same reason, if the pattern has no arguments, an extra Void#
argument is added to the success continuation as well.
For *bidirectional* pattern synonyms, we also generate a "builder"
function which implements the pattern synonym in an expression
context. For our running example, it will be:
......@@ -111,88 +174,21 @@ Injectivity of bidirectional pattern synonyms is checked in
tcPatToExpr which walks the pattern and returns its corresponding
expression when available.
Note [Wrapper/worker for pattern synonyms with unboxed type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For bidirectional pattern synonyms that have no arguments and have
an unboxed type, we add an extra level of indirection, since $WP would
otherwise be a top-level declaration with an unboxed type. In this case,
a separate worker function is generated that has an extra Void# argument,
and the wrapper redirects to it via a compulsory unfolding (that just
applies it on Void#). Example:
Note [Builder for pattern synonyms with unboxed type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For bidirectional pattern synonyms that have no arguments and have an
unboxed type, we add an extra Void# argument to the builder, else it
would be a top-level declaration with an unboxed type.
pattern P = 0#
$WP :: Int#
$WP unfolded to ($wP Void#)
$wP :: Void# -> Int#
$wP _ = 0#
$WP :: Void# -> Int#
$WP _ = 0#
To make things more uniform, we always store two `Id`s in `PatSyn` for
the wrapper and the worker, with the following behaviour:
This means that when typechecking an occurrence of P in an expression,
we must remember that the builder has this void argument. This is
done by TcPatSyn.patSynBuilderOcc.
if `psWrapper` == Just (`wrapper`, `worker`), then
* `wrapper` should always be used when compiling the pattern synonym
in an expression context (and its type is as prescribed)
* `worker` is always an `Id` with a binding that needs to be exported
as part of the definition of the pattern synonym
If a separate worker is not needed (because the pattern synonym has arguments
or has a non-unboxed type), the two `Id`s are the same.
%************************************************************************
%* *
\subsection{Pattern synonyms}
%* *
%************************************************************************
\begin{code}
-- | A pattern synonym
-- See Note [Pattern synonym representation]
data PatSyn
= MkPatSyn {
psName :: Name,
psUnique :: Unique, -- Cached from Name
psArgs :: [Type],
psArity :: Arity, -- == length psArgs
psInfix :: Bool, -- True <=> declared infix
psUnivTyVars :: [TyVar], -- Universially-quantified type variables
psReqTheta :: ThetaType, -- Required dictionaries
psExTyVars :: [TyVar], -- Existentially-quantified type vars
psProvTheta :: ThetaType, -- Provided dictionaries
psOrigResTy :: Type, -- Mentions only psUnivTyVars
-- See Note [Matchers and wrappers for pattern synonyms]
psMatcher :: Id,
-- Matcher function. If psArgs is empty, then it has type
-- forall (r :: ?) univ_tvs. req_theta
-- => res_ty
-- -> (forall ex_tvs. prov_theta -> Void# -> r)
-- -> (Void# -> r)
-- -> r
--
-- Otherwise:
-- forall (r :: ?) univ_tvs. req_theta
-- => res_ty
-- -> (forall ex_tvs. prov_theta -> arg_tys -> r)
-- -> (Void# -> r)
-- -> r
psWrapper :: Maybe (Id, Id)
-- Nothing => uni-directional pattern synonym
-- Just (wrapper, worker) => bi-direcitonal
-- Wrapper function, of type
-- forall univ_tvs, ex_tvs. (prov_theta, req_theta)
-- => arg_tys -> res_ty
--
-- See Note [Wrapper/worker for pattern synonyms with unboxed type]
}
deriving Data.Typeable.Typeable
\end{code}
%************************************************************************
%* *
......@@ -244,20 +240,20 @@ instance Data.Data PatSyn where
mkPatSyn :: Name
-> Bool -- ^ Is the pattern synonym declared infix?
-> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
-- and required dicts
-- and required dicts
-> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
-- and provided dicts
-- and provided dicts
-> [Type] -- ^ Original arguments
-> Type -- ^ Original result type
-> Id -- ^ Name of matcher
-> Maybe (Id, Id) -- ^ Name of wrapper/worker
-> (Id, Bool) -- ^ Name of matcher
-> Maybe (Id, Bool) -- ^ Name of builder
-> PatSyn
mkPatSyn name declared_infix
(univ_tvs, req_theta)
(ex_tvs, prov_theta)
orig_args
orig_res_ty
matcher wrapper
matcher builder
= MkPatSyn {psName = name, psUnique = getUnique name,
psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
psProvTheta = prov_theta, psReqTheta = req_theta,
......@@ -266,7 +262,7 @@ mkPatSyn name declared_infix
psArity = length orig_args,
psOrigResTy = orig_res_ty,
psMatcher = matcher,
psWrapper = wrapper }
psBuilder = builder }
\end{code}
\begin{code}
......@@ -310,18 +306,17 @@ patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
, psArgs = arg_tys, psOrigResTy = res_ty })
= (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
patSynWrapper :: PatSyn -> Maybe Id
patSynWrapper = fmap fst . psWrapper
patSynWorker :: PatSyn -> Maybe Id
patSynWorker = fmap snd . psWrapper
patSynMatcher :: PatSyn -> Id
patSynMatcher :: PatSyn -> (Id,Bool)
patSynMatcher = psMatcher
patSynBuilder :: PatSyn -> Maybe (Id, Bool)
patSynBuilder = psBuilder
tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
= ps { psMatcher = tidy_fn match_id, psWrapper = fmap (second tidy_fn) mb_wrap_id }
tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
= ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
where
tidy_pr (id, dummy) = (tidy_fn id, dummy)
patSynInstArgTys :: PatSyn -> [Type] -> [Type]
-- Return the types of the argument patterns
......
......@@ -46,14 +46,12 @@ import MkCore
import DynFlags
import CostCentre
import Id
import Unique
import Module
import VarSet
import VarEnv
import ConLike
import DataCon
import TysWiredIn
import PrelNames ( seqIdKey )
import BasicTypes
import Maybes
import SrcLoc
......@@ -193,12 +191,7 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
dsExpr :: HsExpr Id -> DsM CoreExpr
dsExpr (HsPar e) = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) -- See Note [Unfolding while desugaring]
| unfold_var = return $ unfoldingTemplate unfolding
| otherwise = return (varToCoreExpr var) -- See Note [Desugaring vars]
where
unfold_var = isCompulsoryUnfolding unfolding && not (var `hasKey` seqIdKey)
unfolding = idUnfolding var
dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars]
dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
......@@ -227,19 +220,6 @@ dsExpr (HsApp fun arg)
dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
\end{code}
Note [Unfolding while desugaring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Variables with compulsory unfolding must be substituted at desugaring
time. This is needed to preserve the let/app invariant in cases where
the unfolding changes whether wrapping in a case is needed.
Suppose we have a call like this:
I# x
where 'x' has an unfolding like this:
f void#
In this case, 'mkCoreAppDs' needs to see 'f void#', not 'x', to be
able to do the right thing.
Note [Desugaring vars]
~~~~~~~~~~~~~~~~~~~~~~
In one situation we can get a *coercion* variable in a HsVar, namely
......
......@@ -348,18 +348,18 @@ mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
let MatchResult _ mkCont = match_result
cont <- mkCoreLams bndrs <$> mkCont fail
return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, make_unstrict fail]
return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
where
MkCaseAlt{ alt_pat = psyn,
alt_bndrs = bndrs,
alt_wrapper = wrapper,
alt_result = match_result} = alt
matcher = patSynMatcher psyn
(matcher, needs_void_lam) = patSynMatcher psyn
-- See Note [Matchers and wrappers for pattern synonyms] in PatSyns
-- See Note [Matchers and builders for pattern synonyms] in PatSyns
-- on these extra Void# arguments
ensure_unstrict = if null (patSynArgs psyn) then make_unstrict else id
make_unstrict = Lam voidArgId
ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
| otherwise = cont
mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives"
......
......@@ -189,13 +189,13 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
buildPatSyn :: Name -> Bool
-> Id -> Maybe (Id, Id)
-> (Id,Bool) -> Maybe (Id, Bool)
-> ([TyVar], ThetaType) -- ^ Univ and req
-> ([TyVar], ThetaType) -- ^ Ex and prov
-> [Type] -- ^ Argument types
-> Type -- ^ Result type
-> PatSyn
buildPatSyn src_name declared_infix matcher wrapper
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty
= ASSERT((and [ univ_tvs == univ_tvs'
, ex_tvs == ex_tvs'
......@@ -207,9 +207,9 @@ buildPatSyn src_name declared_infix matcher wrapper
mkPatSyn src_name declared_infix
(univ_tvs, req_theta) (ex_tvs, prov_theta)
arg_tys pat_ty
matcher wrapper
matcher builder
where
((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher
((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id
([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
(ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
(arg_tys', _) = tcSplitFunTys cont_tau
......
......@@ -134,8 +134,8 @@ data IfaceDecl
| IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym
ifPatIsInfix :: Bool,
ifPatMatcher :: IfExtName,
ifPatWorker :: Maybe IfExtName,
ifPatMatcher :: (IfExtName, Bool),
ifPatBuilder :: Maybe (IfExtName, Bool),
-- Everything below is redundant,
-- but needed to implement pprIfaceDecl
ifPatUnivTvs :: [IfaceTvBndr],
......@@ -765,7 +765,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
$$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
pp_branches _ = Outputable.empty
pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker,
pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
ifPatArgs = arg_tys,
......@@ -776,7 +776,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker,
(pprIfaceContextMaybe req_ctxt)
(pprIfaceType ty)
where
is_bidirectional = isJust worker
is_bidirectional = isJust builder
tvs = univ_tvs ++ ex_tvs
ty = foldr IfaceFunTy pat_ty arg_tys
......@@ -1136,8 +1136,8 @@ freeNamesIfDecl d@IfaceAxiom{} =
freeNamesIfTc (ifTyCon d) &&&
fnList freeNamesIfAxBranch (ifAxBranches d)
freeNamesIfDecl d@IfacePatSyn{} =
unitNameSet (ifPatMatcher d) &&&
maybe emptyNameSet unitNameSet (ifPatWorker d) &&&
unitNameSet (fst (ifPatMatcher d)) &&&
maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
freeNamesIfTvBndrs (ifPatExTvs d) &&&
freeNamesIfContext (ifPatProvCtxt d) &&&
......
......@@ -1542,8 +1542,8 @@ dataConToIfaceDecl dataCon
patSynToIfaceDecl :: PatSyn -> IfaceDecl
patSynToIfaceDecl ps
= IfacePatSyn { ifName = getOccName . getName $ ps
, ifPatMatcher = matcher
, ifPatWorker = worker
, ifPatMatcher = to_if_pr (patSynMatcher ps)
, ifPatBuilder = fmap to_if_pr (patSynBuilder ps)
, ifPatIsInfix = patSynIsInfix ps
, ifPatUnivTvs = toIfaceTvBndrs univ_tvs'
, ifPatExTvs = toIfaceTvBndrs ex_tvs'
......@@ -1556,10 +1556,7 @@ patSynToIfaceDecl ps
(univ_tvs, ex_tvs, prov_theta, req_theta, args, rhs_ty) = patSynSig ps
(env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
(env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
matcher = idName (patSynMatcher ps)
worker = fmap idName (patSynWorker ps)
to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
--------------------------
coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
......
......@@ -14,8 +14,7 @@ module TcIface (
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceVectInfo, tcIfaceAnnotations,
tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
tcIfaceGlobal,
mkPatSynWrapperId, mkPatSynWorkerId -- Have to be here to avoid circular import
tcIfaceGlobal
) where
#include "HsVersions.h"
......@@ -28,7 +27,6 @@ import BuildTyCl
import TcRnMonad
import TcType
import Type
import TcMType
import Coercion hiding (substTy)
import TypeRep
import HscTypes
......@@ -77,7 +75,6 @@ import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable ( traverse )
#endif
import Data.Traversable ( for )
\end{code}
This module takes
......@@ -597,8 +594,8 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
; return (ACoAxiom axiom) }
tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
, ifPatMatcher = matcher_name
, ifPatWorker = worker_name
, ifPatMatcher = if_matcher
, ifPatBuilder = if_builder
, ifPatIsInfix = is_infix
, ifPatUnivTvs = univ_tvs
, ifPatExTvs = ex_tvs
......@@ -608,8 +605,8 @@ 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
; worker <- traverse (tcExt "Worker") worker_name
; matcher <- tc_pr if_matcher
; builder <- fmapMaybeM tc_pr if_builder
; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
{ bindIfaceTyVars ex_tvs $ \ex_tvs -> do
{ patsyn <- forkM (mk_doc name) $
......@@ -617,21 +614,15 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
; req_theta <- tcIfaceCtxt req_ctxt
; pat_ty <- tcIfaceType pat_ty
; arg_tys <- mapM tcIfaceType args
; wrapper <- for worker $ \worker_id -> do
{ wrapper_id <- mkPatSynWrapperId (noLoc name)
(univ_tvs ++ ex_tvs)
(req_theta ++ prov_theta)
arg_tys pat_ty
worker_id
; return (wrapper_id, worker_id)
}
; return $ buildPatSyn name is_infix matcher wrapper
; return $ buildPatSyn name is_infix matcher builder
(univ_tvs, req_theta) (ex_tvs, prov_theta)
arg_tys 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_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
; return (id, b) }
tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
......@@ -1541,41 +1532,3 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
bindIfaceTyVars_AT bs $ \bs' ->
thing_inside (b':bs') }
\end{code}
%************************************************************************
%* *
PatSyn wrapper/worker helpers
%* *
%************************************************************************
\begin{code}
-- These are here (and not in TcPatSyn) just to avoid circular imports.
mkPatSynWrapperId :: Located Name
-> [TyVar] -> ThetaType -> [Type] -> Type
-> Id
-> TcRnIf gbl lcl Id
mkPatSynWrapperId name qtvs theta arg_tys pat_ty worker_id
| need_dummy_arg = do
{ wrapper_id <- mkPatSynWorkerId name mkDataConWrapperOcc qtvs theta arg_tys pat_ty
; let unfolding = mkCoreApp (Var worker_id) (Var voidPrimId)
wrapper_id' = setIdUnfolding wrapper_id $ mkCompulsoryUnfolding unfolding
; return wrapper_id' }
| otherwise = return worker_id -- No indirection needed
where
need_dummy_arg = null arg_tys && isUnLiftedType pat_ty
mkPatSynWorkerId :: Located Name -> (OccName -> OccName)
-> [TyVar] -> ThetaType -> [Type] -> Type
-> TcRnIf gbl loc Id
mkPatSynWorkerId (L loc name) mk_occ_name qtvs theta arg_tys pat_ty
= do { worker_name <- newImplicitBinder name mk_occ_name
; (subst, worker_tvs) <- tcInstSigTyVarsLoc loc qtvs
; let worker_theta = substTheta subst theta
pat_ty' = substTy subst pat_ty
arg_tys' = map (substTy subst) arg_tys
worker_tau = mkFunTys arg_tys' pat_ty'
-- TODO: just substitute worker_sigma...
worker_sigma = mkSigmaTy worker_tvs worker_theta worker_tau
; return $ mkVanillaGlobal worker_name worker_sigma }
\end{code}
......@@ -16,8 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynWorker )
import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynBuilderBind )
import DynFlags
import HsSyn
import HscTypes( isHsBootOrSig )
......@@ -29,11 +28,9 @@ import TcEvidence
import TcHsType
import TcPat
import TcMType
import PatSyn
import ConLike
import FamInstEnv( normaliseType )
import FamInst( tcGetFamInstEnvs )
import Type( tidyOpenType, splitFunTys )
import TyCon
import TcType
import TysPrim
......@@ -321,7 +318,7 @@ tcValBinds top_lvl binds sigs thing_inside
{ (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
{ thing <- thing_inside
-- See Note [Pattern synonym wrappers don't yield dependencies]
; patsyn_workers <- mapM tcPatSynWorker patsyns
; patsyn_workers <- mapM tcPatSynBuilderBind patsyns
; let extra_binds = [ (NonRecursive, worker) | worker <- patsyn_workers ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
......@@ -423,11 +420,12 @@ tc_single :: forall thing.
tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
= do { (pat_syn, aux_binds) <- tc_pat_syn_decl
; let tything = AConLike (PatSynCon pat_syn)
implicit_ids = (patSynMatcher pat_syn) :
(maybeToList (patSynWorker pat_syn))
-- SLPJ: Why is this necessary?
-- implicit_ids = patSynMatcher pat_syn :
-- maybeToList (patSynWorker pat_syn)
; thing <- tcExtendGlobalEnv [tything] $
tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
-- tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
thing_inside
; return (aux_binds, thing)
}
......
......@@ -31,6 +31,7 @@ import TcEnv
import TcArrows
import TcMatches
import TcHsType
import TcPatSyn( tcPatSynBuilderOcc )
import TcPat
import TcMType
import TcType
......@@ -38,7 +39,6 @@ import DsMonad hiding (Splice)
import Id
import ConLike
import DataCon
import PatSyn
import RdrName
import Name
import TyCon
......@@ -1028,6 +1028,7 @@ in the other order, the extra signature in f2 is reqd.
tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
tcCheckId name res_ty
= do { (expr, actual_res_ty) <- tcInferId name
; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
tcWrapResult expr actual_res_ty res_ty }
......@@ -1041,57 +1042,75 @@ tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
-- Look up an occurrence of an Id, and instantiate it (deeply)
tcInferIdWithOrig orig id_name
| id_name `hasKey` tagToEnumKey
= failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
-- tcApp catches the case (tagToEnum# arg)
| id_name `hasKey` assertIdKey
= do { dflags <- getDynFlags
; if gopt Opt_IgnoreAsserts dflags
then normal_case
else assert_case dflags }
then tc_infer_id orig id_name
else tc_infer_assert dflags orig }
| otherwise
= normal_case
where
normal_case
= do { id <- lookup_id id_name
; (id_expr, id_rho) <- instantiateOuter orig id
; (wrap, rho) <- deeplyInstantiate orig id_rho
; return (mkHsWrap wrap id_expr, rho) }
assert_case dflags -- See Note [Adding the implicit parameter to 'assert']
= do { sloc <- getSrcSpanM
; assert_error_id <- lookup_id assertErrorName
; (id_expr, id_rho) <- instantiateOuter orig assert_error_id
; case tcSplitFunTy_maybe id_rho of {
Nothing -> pprPanic "assert type" (ppr id_rho) ;
Just (arg_ty, res_ty) -> ASSERT( arg_ty `tcEqType` addrPrimTy )
do { return (HsApp (L sloc id_expr)
(L sloc (srcSpanPrimLit dflags sloc)), res_ty) } } }
lookup_id :: Name -> TcM TcId
lookup_id id_name
= tc_infer_id orig id_name
tc_infer_assert :: DynFlags -> CtOrigin -> TcM (HsExpr TcId, TcRhoType)
-- Deal with an occurrence of 'assert'
-- See Note [Adding the implicit parameter to 'assert']