+ -- If the binding binds ?x = E, we must now
+ -- discharge any ?x constraints in expr_lie
+ tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds ->
+
+ returnM (combiner (HsIPBinds binds') $
+ combiner (HsBindGroup dict_binds [] Recursive) result)
+ where
+ -- I wonder if we should do these one at at time
+ -- Consider ?x = 4
+ -- ?y = ?x + 1
+ tc_ip_bind (IPBind ip expr)
+ = newTyVarTy argTypeKind `thenM` \ ty ->
+ newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) ->
+ tcCheckRho expr ty `thenM` \ expr' ->
+ returnM (ip_inst, (IPBind ip' expr'))
+
+tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next
+ | isEmptyBag 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)
+ tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList 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
+ )
+ where
+ tc_body poly_ids -- Type check the pragmas and "thing inside"
+ = -- Extend the environment to bind the new polymorphic Ids
+ tcExtendLocalValEnv poly_ids $