+mkEdges sig_fn binds
+ = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
+ Just key <- [lookupNameEnv key_map n], no_sig n ])
+ | (bind, key) <- keyd_binds
+ ]
+ where
+ no_sig :: Name -> Bool
+ no_sig n = isNothing (sig_fn n)
+
+ keyd_binds = bagToList binds `zip` [0::BKey ..]
+
+ key_map :: NameEnv BKey -- Which binding it comes from
+ key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
+ , bndr <- bindersOfHsBind bind ]
+
+bindersOfHsBind :: HsBind Name -> [Name]
+bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat
+bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
+
+------------------------
+tcPolyBinds :: TopLevelFlag
+ -> RecFlag -- Whether the group is really recursive
+ -> RecFlag -- Whether it's recursive for typechecking purposes
+ -> TcSigFun -> TcPragFun
+ -> LHsBinds Name
+ -> TcM thing
+ -> TcM ([LHsBinds TcId], thing)
+
+-- Typechecks a single bunch of bindings all together,
+-- and generalises them. The bunch may be only part of a recursive
+-- group, because we use type signatures to maximise polymorphism
+--
+-- Deals with the bindInstsOfLocalFuns thing too
+--
+-- Returns a list because the input may be a single non-recursive binding,
+-- in which case the dependency order of the resulting bindings is
+-- important.
+
+tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside
+ = -- NB: polymorphic recursion means that a function
+ -- may use an instance of itself, we must look at the LIE arising
+ -- from the function's own right hand side. Hence the getLIE
+ -- encloses the tc_poly_binds.
+ do { traceTc (text "tcPolyBinds" <+> ppr scc)
+ ; ((binds1, poly_ids, thing), lie) <- getLIE $
+ do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc
+ sig_fn prag_fn scc
+ ; thing <- tcExtendIdEnv poly_ids thing_inside
+ ; return (binds1, poly_ids, thing) }
+
+ ; if isTopLevel top_lvl
+ then -- For the top level don't bother will all this
+ -- bindInstsOfLocalFuns stuff. All the top level
+ -- things are rec'd together anyway, so it's fine to
+ -- leave them to the tcSimplifyTop,
+ -- and quite a bit faster too
+ do { extendLIEs lie; return (binds1, thing) }
+
+ else do -- Nested case
+ { lie_binds <- bindInstsOfLocalFuns lie poly_ids
+ ; return (binds1 ++ [lie_binds], thing) }}
+
+------------------------
+tc_poly_binds :: TopLevelFlag -- See comments on tcPolyBinds
+ -> RecFlag -> RecFlag
+ -> TcSigFun -> TcPragFun
+ -> LHsBinds Name
+ -> TcM ([LHsBinds TcId], [TcId])
+-- Typechecks the bindings themselves
+-- Knows nothing about the scope of the bindings
+
+tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds
+ = let
+ binder_names = collectHsBindBinders binds
+ bind_list = bagToList binds
+
+ loc = getLoc (head bind_list)
+ -- TODO: location a bit awkward, but the mbinds have been
+ -- dependency analysed and may no longer be adjacent
+ in
+ -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
+ setSrcSpan loc $
+ recoverM (recoveryCode binder_names) $ do
+
+ { traceTc (ptext SLIT("------------------------------------------------"))
+ ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names)
+
+ -- TYPECHECK THE BINDINGS
+ ; ((binds', mono_bind_infos), lie_req)
+ <- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
+
+ -- CHECK FOR UNLIFTED BINDINGS
+ -- These must be non-recursive etc, and are not generalised
+ -- They desugar to a case expression in the end
+ ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
+ ; is_strict <- checkStrictBinds top_lvl rec_group binds'
+ zonked_mono_tys mono_bind_infos
+ ; if is_strict then
+ do { extendLIEs lie_req
+ ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
+ mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
+ mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, [])
+ -- ToDo: prags for unlifted bindings
+
+ ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'],
+ [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
+
+ else do -- The normal lifted case: GENERALISE
+ { is_unres <- isUnRestrictedGroup bind_list sig_fn
+ ; (tyvars_to_gen, dict_binds, dict_ids)
+ <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
+ generalise top_lvl is_unres 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))
+ mono_bind_infos
+
+ -- ZONK THE poly_ids, because they are used to extend the type
+ -- environment; see the invariant on TcEnv.tcExtendIdEnv
+ ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
+ ; zonked_poly_ids <- mappM zonkId poly_ids
+
+ ; traceTc (text "binding:" <+> ppr (zonked_poly_ids `zip` map idType zonked_poly_ids))
+
+ ; let abs_bind = L loc $ AbsBinds tyvars_to_gen'
+ dict_ids exports
+ (dict_binds `unionBags` binds')
+
+ ; return ([unitBag abs_bind], zonked_poly_ids)
+ } }
+
+
+--------------
+mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
+ -> TcM ([TyVar], Id, Id, [Prag])
+mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+ = case mb_sig of
+ Nothing -> do { prags <- tcPrags poly_id (prag_fn poly_name)
+ ; return (inferred_tvs, poly_id, mono_id, prags) }
+ where
+ poly_id = mkLocalId poly_name poly_ty
+ poly_ty = mkForAllTys inferred_tvs
+ $ mkFunTys dict_tys
+ $ idType mono_id
+
+ Just sig -> do { let poly_id = sig_id sig
+ ; prags <- tcPrags poly_id (prag_fn poly_name)
+ ; sig_tys <- zonkTcTyVars (sig_tvs sig)
+ ; let sig_tvs' = map (tcGetTyVar "mkExport") sig_tys
+ ; return (sig_tvs', poly_id, mono_id, prags) }
+ -- We zonk the sig_tvs here so that the export triple
+ -- always has zonked type variables;
+ -- a convenient invariant
+
+
+------------------------
+type TcPragFun = Name -> [LSig Name]
+
+mkPragFun :: [LSig Name] -> TcPragFun
+mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
+ where
+ prs = [(expectJust "mkPragFun" (sigName sig), sig)
+ | sig <- sigs, isPragLSig sig]
+ 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
+ where
+ tc_prag (L loc prag) = setSrcSpan loc $
+ addErrCtxt (pragSigCtxt prag) $
+ tcPrag poly_id prag
projects / ghc-hetmet.git / blobdiff