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
This diff is collapsed.
......@@ -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']
tc_infer_assert dflags orig
= do { sloc <- getSrcSpanM
; assert_error_id <- tcLookupId assertErrorName
; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id)
; let (arg_ty, res_ty) = case tcSplitFunTy_maybe id_rho of
Nothing -> pprPanic "assert type" (ppr id_rho)
Just arg_res -> arg_res
; ASSERT( arg_ty `tcEqType` addrPrimTy )
return (HsApp (L sloc (mkHsWrap wrap (HsVar assert_error_id)))
(L sloc (srcSpanPrimLit dflags sloc))
, res_ty) }
tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
-- Return type is deeply instantiated
tc_infer_id orig id_name
= do { thing <- tcLookup id_name
; case thing of
ATcId { tct_id = id }
-> do { check_naughty id -- Note [Local record selectors]
; checkThLocalId id
; return id }
; inst_normal_id id }
AGlobal (AnId id)
-> do { check_naughty id; return id }
-> do { check_naughty id
; inst_normal_id id }
-- A global cannot possibly be ill-staged
-- nor does it need the 'lifting' treatment
-- hence no checkTh stuff here
AGlobal (AConLike cl) -> case cl of
RealDataCon con -> return (dataConWrapId con)
PatSynCon ps -> case patSynWrapper ps of
Nothing -> failWithTc (bad_patsyn ps)
Just id -> return id
other -> failWithTc (bad_lookup other) }
RealDataCon con -> inst_data_con con
PatSynCon ps -> tcPatSynBuilderOcc orig ps
_ -> failWithTc $
ppr thing <+> ptext (sLit "used where a value identifer was expected") }
where
bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected")
bad_patsyn name = ppr name <+> ptext (sLit "used in an expression, but it's a non-bidirectional pattern synonym")
inst_normal_id id
= do { (wrap, rho) <- deeplyInstantiate orig (idType id)
; return (mkHsWrap wrap (HsVar id), rho) }
inst_data_con con
-- For data constructors,
-- * Must perform the stupid-theta check
-- * No need to deeply instantiate because type has all foralls at top
= do { let wrap_id = dataConWrapId con
(tvs, theta, rho) = tcSplitSigmaTy (idType wrap_id)
; (subst, tvs') <- tcInstTyVars tvs
; let tys' = mkTyVarTys tvs'
theta' = substTheta subst theta
rho' = substTy subst rho
; wrap <- instCall orig tys' theta'
; addDataConStupidTheta con tys'
; return (mkHsWrap wrap (HsVar wrap_id), rho') }
check_naughty id
| isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
......@@ -1100,29 +1119,6 @@ lookup_id id_name
srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId
srcSpanPrimLit dflags span
= HsLit (HsStringPrim (unsafeMkByteString (showSDocOneLine dflags (ppr span))))
------------------------
instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType)
-- Do just the first level of instantiation of an Id
-- a) Deal with method sharing
-- b) Deal with stupid checks
-- Only look at the *outer level* of quantification
-- See Note [Multiple instantiation]
instantiateOuter orig id
| null tvs && null theta
= return (HsVar id, tau)
| otherwise
= do { (subst, tvs') <- tcInstTyVars tvs
; let tys' = mkTyVarTys tvs'
theta' = substTheta subst theta
; doStupidChecks id tys'
; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys' $$ ppr theta'))
; wrap <- instCall orig tys' theta'
; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) }
where
(tvs, theta, tau) = tcSplitSigmaTy (idType id)
\end{code}
Note [Adding the implicit parameter to 'assert']
......@@ -1133,58 +1129,6 @@ e1 e2). This isn't really the Right Thing because there's no way to
output. We'll have fix this in due course, when we care more about
being able to reconstruct the exact original program.
Note [Multiple instantiation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
For example, consider
f :: forall a. Eq a => forall b. Ord b => a -> b
At a call to f, at say [Int, Bool], it's tempting to translate the call to
f_m1
where
f_m1 :: forall b. Ord b => Int -> b
f_m1 = f Int dEqInt
f_m2 :: Int -> Bool
f_m2 = f_m1 Bool dOrdBool
But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
f_m1 = f_mx
But it's entirely possible that f_m2 will continue to float out, because it
mentions no type variables. Result, f_m1 isn't in scope.
Here's a concrete example that does this (test tc200):
class C a where
f :: Eq b => b -> a -> Int
baz :: Eq a => Int -> a -> Int
instance C Int where
baz = f
Current solution: only do the "method sharing" thing for the first type/dict
application, not for the iterated ones. A horribly subtle point.
\begin{code}
doStupidChecks :: TcId
-> [TcType]
-> TcM ()
-- Check two tiresome and ad-hoc cases
-- (a) the "stupid theta" for a data con; add the constraints
-- from the "stupid theta" of a data constructor (sigh)
doStupidChecks fun_id tys
| Just con <- isDataConId_maybe fun_id -- (a)
= addDataConStupidTheta con tys
| fun_id `hasKey` tagToEnumKey -- (b)
= failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
| otherwise
= return () -- The common case
\end{code}
Note [tagToEnum#]
~~~~~~~~~~~~~~~~~
Nasty check to ensure that tagToEnum# is applied to a type that is an
......
This diff is collapsed.
......@@ -15,6 +15,6 @@ tcCheckPatSynDecl :: PatSynBind Name Name
-> TcPatSynInfo
-> TcM (PatSyn, LHsBinds Id)
tcPatSynWorker :: PatSynBind Name Name
-> TcM (LHsBinds Id)
tcPatSynBuilderBind :: PatSynBind Name Name
-> TcM (LHsBinds Id)
\end{code}
......@@ -431,6 +431,11 @@ newSysName occ
= do { uniq <- newUnique
; return (mkSystemName uniq occ) }
newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId fs ty
= do { u <- newUnique
; return (mkSysLocal fs u ty) }
newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
= do { us <- newUniqueSupply
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment