import ErrUtils
import Digraph
import Maybes
+import List
import Util
import BasicTypes
import Outputable
-- TYPECHECK THE BINDINGS
; ((binds', mono_bind_infos), lie_req)
<- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
+ ; traceTc (text "temp" <+> (ppr binds' $$ ppr lie_req))
-- CHECK FOR UNLIFTED BINDINGS
-- These must be non-recursive etc, and are not generalised
else do -- The normal lifted case: GENERALISE
{ dflags <- getDOpts
- ; (tyvars_to_gen, dict_binds, dict_ids)
+ ; (tyvars_to_gen, dicts, dict_binds)
<- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
- -- FINALISE THE QUANTIFIED TYPE VARIABLES
- -- The quantified type variables often include meta type variables
- -- we want to freeze them into ordinary type variables, and
- -- default their kind (e.g. from OpenTypeKind to TypeKind)
- ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
-
-- BUILD THE POLYMORPHIC RESULT IDs
- ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids))
+ ; let dict_ids = map instToId dicts
+ ; exports <- mapM (mkExport prag_fn tyvars_to_gen (map idType dict_ids))
mono_bind_infos
; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids))
- ; let abs_bind = L loc $ AbsBinds tyvars_to_gen'
+ ; let abs_bind = L loc $ AbsBinds tyvars_to_gen
dict_ids exports
(dict_binds `unionBags` binds')
--------------
mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
- -> TcM ([TyVar], Id, Id, [Prag])
+ -> TcM ([TyVar], Id, Id, [LPrag])
-- mkExport generates exports with
-- zonked type variables,
-- zonked poly_ids
env = foldl add emptyNameEnv prs
add env (n,p) = extendNameEnv_Acc (:) singleton env n p
-tcPrags :: Id -> [LSig Name] -> TcM [Prag]
-tcPrags poly_id prags = mapM tc_prag prags
+tcPrags :: Id -> [LSig Name] -> TcM [LPrag]
+tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
where
- tc_prag (L loc prag) = setSrcSpan loc $
- addErrCtxt (pragSigCtxt prag) $
- tcPrag poly_id prag
+ tc_prag prag = addErrCtxt (pragSigCtxt prag) $
+ tcPrag poly_id prag
pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
generalise :: DynFlags -> TopLevelFlag
-> [LHsBind Name] -> TcSigFun
-> [MonoBindInfo] -> [Inst]
- -> TcM ([TcTyVar], TcDictBinds, [TcId])
+ -> TcM ([TyVar], [Inst], TcDictBinds)
+-- The returned [TyVar] are all ready to quantify
+
generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
| isMonoGroup dflags bind_list
- = do { extendLIEs lie_req; return ([], emptyBag, []) }
+ = do { extendLIEs lie_req
+ ; return ([], [], emptyBag) }
| isRestrictedGroup dflags bind_list sig_fn -- RESTRICTED CASE
= -- Check signature contexts are empty
-- Check that signature type variables are OK
; final_qtvs <- checkSigsTyVars qtvs sigs
- ; return (final_qtvs, binds, []) }
+ ; return (final_qtvs, [], binds) }
| null sigs -- UNRESTRICTED CASE, NO TYPE SIGS
= tcSimplifyInfer doc tau_tvs lie_req
-- Check that the needed dicts can be
-- expressed in terms of the signature ones
- ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req
+ ; (qtvs, binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req
-- Check that signature type variables are OK
- ; final_qtvs <- checkSigsTyVars forall_tvs sigs
+ ; final_qtvs <- checkSigsTyVars qtvs sigs
- ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
+ ; returnM (final_qtvs, sig_lie, binds) }
where
bndrs = bndrNames mono_infos
sigs = [sig | (_, Just sig, _) <- mono_infos]