- tc_ip_bind (ip, expr)
- = newTyVarTy openTypeKind `thenM` \ ty ->
- getSrcLocM `thenM` \ loc ->
- newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) ->
- tcCheckRho expr ty `thenM` \ expr' ->
- returnM (ip_inst, (ip', expr'))
-
-tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
- = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
+ tc_ip_bind (IPBind ip expr)
+ = newTyVarTy openTypeKind `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)) $
+ tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
+
+ 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
+ --
+ -- Subtle (and ugly) point: furthermore at top level we
+ -- return the TcLclEnv, which contains the LIE var; we
+ -- don't want to return the wrong one!
+ -> 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. We must include
+ -- the LIE from the RHSs too -- polymorphic recursion!
+ -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) ->
+
+ -- Create specialisations of functions bound here
+ bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
+
+ -- We want to keep non-recursive things non-recursive
+ -- so that we desugar unlifted bindings correctly
+ if isRec is_rec then
+ returnM (
+ combiner (HsBindGroup
+ (poly_binds `unionBags`
+ lie_binds `unionBags`
+ prag_binds)
+ [] Recursive) thing
+ )
+ else
+ 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)
+
+{-
+ = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE