-tcBindWithSigs
- :: TopLevelFlag
- -> RenamedMonoBinds
- -> [TcSigInfo]
- -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
- -> RecFlag
- -> TcM (TcMonoBinds, LIE, [TcId])
-
-tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
- = recoverTc (
- -- If typechecking the binds fails, then return with each
- -- signature-less binder given type (forall a.a), to minimise subsequent
- -- error messages
- newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
- let
- forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
- binder_names = collectMonoBinders mbind
- poly_ids = map mk_dummy binder_names
- mk_dummy name = case maybeSig tc_ty_sigs name of
- Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
- Nothing -> mkVanillaId name forall_a_a -- No signature
- in
- returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
- ) $
-
- -- TYPECHECK THE BINDINGS
- tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
-
- -- CHECK THAT THE SIGNATURES MATCH
- -- (must do this before getTyVarsToGen)
- checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta ->
-
- -- IMPROVE the LIE
- -- Force any unifications dictated by functional dependencies.
- -- Because unification may happen, it's important that this step
- -- come before:
- -- - computing vars over which to quantify
- -- - zonking the generalized type vars
- let lie_avail = case maybe_sig_theta of
- Nothing -> emptyLIE
- Just (_, la) -> la
- lie_avail_req = lie_avail `plusLIE` lie_req in
- tcImprove lie_avail_req `thenTc_`
-
- -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
- -- The tyvars_not_to_gen are free in the environment, and hence
- -- candidates for generalisation, but sometimes the monomorphism
- -- restriction means we can't generalise them nevertheless
- let
- mono_id_tys = map idType mono_ids
- in
- getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-
- -- Finally, zonk the generalised type variables to real TyVars
- -- This commits any unbound kind variables to boxed kind
- -- I'm a little worried that such a kind variable might be
- -- free in the environment, but I don't think it's possible for
- -- this to happen when the type variable is not free in the envt
- -- (which it isn't). SLPJ Nov 98
- mapTc zonkTcTyVarToTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
- let
- real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list
- -- It's important that the final list
- -- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
- -- zonked, *including boxity*, because they'll be included in the forall types of
- -- the polymorphic Ids, and instances of these Ids will be generated from them.
- --
- -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
- -- real_tyvars_to_gen
- in
-
- -- SIMPLIFY THE LIE
- tcExtendGlobalTyVars tyvars_not_to_gen (
- let ips = getIPsOfLIE lie_avail_req in
- if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
- -- No polymorphism, and no IPs, so no need to simplify context
- returnTc (lie_req, EmptyMonoBinds, [])
- else
- case maybe_sig_theta of
- Nothing ->
- -- No signatures, so just simplify the lie
- -- NB: no signatures => no polymorphic recursion, so no
- -- need to use lie_avail (which will be empty anyway)
- tcSimplify (text "tcBinds1" <+> ppr binder_names)
- real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
- returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
-
- Just (sig_theta, lie_avail) ->
- -- There are signatures, and their context is sig_theta
- -- Furthermore, lie_avail is an LIE containing the 'method insts'
- -- for the things bound here
-
- zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' ->
- newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
- -- It's important that sig_theta is zonked, because
- -- dict_id is later used to form the type of the polymorphic thing,
- -- and forall-types must be zonked so far as their bound variables
- -- are concerned
-
- let
- -- The "givens" is the stuff available. We get that from
- -- the context of the type signature, BUT ALSO the lie_avail
- -- so that polymorphic recursion works right (see comments at end of fn)
- givens = dicts_sig `plusLIE` lie_avail
- in
-
- -- Check that the needed dicts can be expressed in
- -- terms of the signature ones
- tcAddErrCtxt (bindSigsCtxt tysig_names) $
- tcSimplifyAndCheck
- (ptext SLIT("type signature for") <+> pprQuotedList binder_names)
- real_tyvars_to_gen givens lie_req `thenTc` \ (lie_free, dict_binds) ->
-
- returnTc (lie_free, dict_binds, dict_ids)
-
- ) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
-
- -- GET THE FINAL MONO_ID_TYS
- zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
-
-
- -- CHECK FOR BOGUS UNPOINTED BINDINGS
- (if any isUnLiftedType zonked_mono_id_types then
- -- Unlifted bindings must be non-recursive,
- -- not top level, and non-polymorphic
- checkTc (isNotTopLevel top_lvl)
- (unliftedBindErr "Top-level" mbind) `thenTc_`
- checkTc (case is_rec of {Recursive -> False; NonRecursive -> True})
- (unliftedBindErr "Recursive" mbind) `thenTc_`
- checkTc (null real_tyvars_to_gen_list)
- (unliftedBindErr "Polymorphic" mbind)
- else
- returnTc ()
- ) `thenTc_`
-
- ASSERT( not (any ((== unboxedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
- -- The instCantBeGeneralised stuff in tcSimplify should have
- -- already raised an error if we're trying to generalise an
- -- unboxed tyvar (NB: unboxed tyvars are always introduced
- -- along with a class constraint) and it's better done there
- -- because we have more precise origin information.
- -- That's why we just use an ASSERT here.
-
-
- -- BUILD THE POLYMORPHIC RESULT IDs
- mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
- let
- exports = zipWith mk_export binder_names zonked_mono_ids
- dict_tys = map idType dicts_bound
-
- inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
- no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
- [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase])
- -- "INLINE n foo" means inline foo, but not until at least phase n
- -- "NOINLINE n foo" means don't inline foo until at least phase n, and even
- -- then only if it is small enough etc.
- -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
- -- See comments in CoreUnfold.blackListed for the Authorised Version
-
- mk_export binder_name zonked_mono_id
- = (tyvars,
- attachNoInlinePrag no_inlines poly_id,
- zonked_mono_id)
- where
- (tyvars, poly_id) =
- case maybeSig tc_ty_sigs binder_name of
- Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) ->
- (sig_tyvars, sig_poly_id)
- Nothing -> (real_tyvars_to_gen_list, new_poly_id)
-
- new_poly_id = mkVanillaId binder_name poly_ty
- poly_ty = mkForAllTys real_tyvars_to_gen_list
- $ mkFunTys dict_tys
- $ idType (zonked_mono_id)
- -- It's important to build a fully-zonked poly_ty, because
- -- we'll slurp out its free type variables when extending the
- -- local environment (tcExtendLocalValEnv); if it's not zonked
- -- it appears to have free tyvars that aren't actually free
- -- at all.
-
- pat_binders :: [Name]
- pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
- in
- -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
- mapTc (\id -> checkTc (not (idName id `elem` pat_binders
- && isUnboxedType (idType id)))
- (unboxedPatBindErr id)) zonked_mono_ids
- `thenTc_`
-
- -- BUILD RESULTS
- returnTc (
- -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
- AbsBinds real_tyvars_to_gen_list
- dicts_bound
- exports
- inlines
- (dict_binds `andMonoBinds` mbind'),
- lie_free,
- [poly_id | (_, poly_id, _) <- exports]
- )
+tcMonoBinds :: [LHsBind Name]
+ -> TcSigFun
+ -> RecFlag -- True <=> the binding is recursive for typechecking purposes
+ -- i.e. the binders are mentioned in their RHSs, and
+ -- we are not resuced by a type signature
+ -> TcM (LHsBinds TcId, [MonoBindInfo])
+
+tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)]
+ sig_fn -- Single function binding,
+ NonRecursive -- binder isn't mentioned in RHS,
+ | Nothing <- sig_fn name -- ...with no type signature
+ = -- In this very special case we infer the type of the
+ -- right hand side first (it may have a higher-rank type)
+ -- and *then* make the monomorphic Id for the LHS
+ -- e.g. f = \(x::forall a. a->a) -> <body>
+ -- We want to infer a higher-rank type for f
+ setSrcSpan b_loc $
+ do { (matches', rhs_ty) <- tcInfer (tcMatchesFun name matches)
+
+ -- Check for an unboxed tuple type
+ -- f = (# True, False #)
+ -- Zonk first just in case it's hidden inside a meta type variable
+ -- (This shows up as a (more obscure) kind error
+ -- in the 'otherwise' case of tcMonoBinds.)
+ ; zonked_rhs_ty <- zonkTcType rhs_ty
+ ; checkTc (not (isUnboxedTupleType zonked_rhs_ty))
+ (unboxedTupleErr name zonked_rhs_ty)
+
+ ; mono_name <- newLocalName name
+ ; let mono_id = mkLocalId mono_name zonked_rhs_ty
+ ; return (unitBag (L b_loc (FunBind (L nm_loc mono_id) inf matches' fvs)),
+ [(name, Nothing, mono_id)]) }
+
+tcMonoBinds binds sig_fn non_rec
+ = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds
+
+ -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs
+ -- For (a) it's ok to bring them all into scope at once, even
+ -- though each type sig should scope only over its own RHS,
+ -- because the renamer has sorted all that out.
+ ; let mono_info = getMonoBindInfo tc_binds
+ rhs_tvs = [ (name, mkTyVarTy tv)
+ | (_, Just sig, _) <- mono_info,
+ (name, tv) <- sig_scoped sig `zip` sig_tvs sig ]
+ rhs_id_env = map mk mono_info -- A binding for each term variable
+
+ ; binds' <- tcExtendTyVarEnv2 rhs_tvs $
+ tcExtendIdEnv2 rhs_id_env $
+ traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id)
+ | (n,id) <- rhs_id_env]) `thenM_`
+ mapM (wrapLocM tcRhs) tc_binds
+ ; return (listToBag binds', mono_info) }
+ where
+ mk (name, Just sig, _) = (name, sig_id sig) -- Use the type sig if there is one
+ mk (name, Nothing, mono_id) = (name, mono_id) -- otherwise use a monomorphic version
+
+------------------------
+-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
+-- we typecheck the RHSs. Basically what we are doing is this: for each binder:
+-- if there's a signature for it, use the instantiated signature type
+-- otherwise invent a type variable
+-- You see that quite directly in the FunBind case.
+--
+-- But there's a complication for pattern bindings:
+-- data T = MkT (forall a. a->a)
+-- MkT f = e
+-- Here we can guess a type variable for the entire LHS (which will be refined to T)
+-- but we want to get (f::forall a. a->a) as the RHS environment.
+-- The simplest way to do this is to typecheck the pattern, and then look up the
+-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
+-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
+
+data TcMonoBind -- Half completed; LHS done, RHS not done
+ = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
+ | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
+
+type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
+ -- Type signature (if any), and
+ -- the monomorphic bound things
+
+bndrNames :: [MonoBindInfo] -> [Name]
+bndrNames mbi = [n | (n,_,_) <- mbi]
+
+getMonoType :: MonoBindInfo -> TcTauType
+getMonoType (_,_,mono_id) = idType mono_id
+
+tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
+tcLhs sig_fn (FunBind (L nm_loc name) inf matches _)
+ = do { let mb_sig = sig_fn name
+ ; mono_name <- newLocalName name
+ ; mono_ty <- mk_mono_ty mb_sig
+ ; let mono_id = mkLocalId mono_name mono_ty
+ ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }