-tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next
- | isEmptyLHsBinds binds
- = do_next
- | otherwise
- = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
- -- Notice that they scope over
- -- a) the type signatures in the binding group
- -- b) the bindings in the group
- -- c) the scope of the binding group (the "in" part)
- tcAddLetBoundTyVars binds $
-
- case top_lvl of
- TopLevel -- 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
- -> tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
- tc_body poly_ids `thenM` \ (prag_binds, thing) ->
- returnM (combiner (HsBindGroup
- (poly_binds `unionBags` prag_binds)
- [] -- no sigs
- Recursive)
- thing)
-
- NotTopLevel -- For nested bindings we must do the bindInstsOfLocalFuns thing.
- | not (isRec is_rec) -- Non-recursive group
- -> -- We want to keep non-recursive things non-recursive
- -- so that we desugar unlifted bindings correctly
- tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
- getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) ->
-
- -- Create specialisations of functions bound here
- bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
-
- returnM (
- combiner (HsBindGroup poly_binds [] NonRecursive) $
- combiner (HsBindGroup prag_binds [] NonRecursive) $
- combiner (HsBindGroup lie_binds [] Recursive) $
- -- NB: the binds returned by tcSimplify and
- -- bindInstsOfLocalFuns aren't guaranteed in
- -- dependency order (though we could change that);
- -- hence the Recursive marker.
- thing)
-
- | otherwise
- -> -- 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 tcBindWithSigs.
-
- getLIE (
- tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
- tc_body poly_ids `thenM` \ (prag_binds, thing) ->
- returnM (poly_ids, poly_binds `unionBags` prag_binds, thing)
- ) `thenM` \ ((poly_ids, extra_binds, thing), lie) ->
-
- bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
-
- returnM (combiner (HsBindGroup
- (extra_binds `unionBags` lie_binds)
- [] Recursive) thing
- )
+------------------------
+tcValBinds :: TopLevelFlag
+ -> HsValBinds Name -> TcM thing
+ -> TcM (HsValBinds TcId, thing)
+
+tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
+ = pprPanic "tcValBinds" (ppr binds)
+
+tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
+ = do { -- Typecheck the signature
+ ; let { prag_fn = mkPragFun sigs
+ ; ty_sigs = filter isVanillaLSig sigs
+ ; sig_fn = mkSigFun ty_sigs }
+
+ ; poly_ids <- mapM tcTySig ty_sigs
+
+ -- Extend the envt right away with all
+ -- the Ids declared with type signatures
+ ; (binds', thing) <- tcExtendIdEnv poly_ids $
+ tc_val_binds top_lvl sig_fn prag_fn
+ binds thing_inside
+
+ ; return (ValBindsOut binds' sigs, thing) }
+
+------------------------
+tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun
+ -> [(RecFlag, LHsBinds Name)] -> TcM thing
+ -> TcM ([(RecFlag, LHsBinds TcId)], thing)
+-- Typecheck a whole lot of value bindings,
+-- one strongly-connected component at a time
+
+tc_val_binds top_lvl sig_fn prag_fn [] thing_inside
+ = do { thing <- thing_inside
+ ; return ([], thing) }
+
+tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside
+ = do { (group', (groups', thing))
+ <- tc_group top_lvl sig_fn prag_fn group $
+ tc_val_binds top_lvl sig_fn prag_fn groups thing_inside
+ ; return (group' ++ groups', thing) }
+
+------------------------
+tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun
+ -> (RecFlag, LHsBinds Name) -> TcM thing
+ -> TcM ([(RecFlag, LHsBinds TcId)], thing)
+
+-- Typecheck one strongly-connected component of the original program.
+-- We get a list of groups back, because there may
+-- be specialisations etc as well
+
+tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
+ = -- A single non-recursive binding
+ -- We want to keep non-recursive things non-recursive
+ -- so that we desugar unlifted bindings correctly
+ do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive
+ sig_fn prag_fn binds thing_inside
+ ; return ([(NonRecursive, b) | b <- binds], thing) }
+
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
+ = -- A recursive strongly-connected component
+ -- To maximise polymorphism (with -fglasgow-exts), we do a new
+ -- strongly-connected-component analysis, this time omitting
+ -- any references to variables with type signatures.
+ --
+ -- Then we bring into scope all the variables with type signatures
+ do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
+ ; gla_exts <- doptM Opt_GlasgowExts
+ ; (binds,thing) <- if gla_exts
+ then go new_sccs
+ else tc_binds Recursive binds thing_inside
+ ; return ([(Recursive, unionManyBags binds)], thing) }
+ -- Rec them all together