\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds,
- tcSpecSigs, tcBindWithSigs ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
#include "HsVersions.h"
import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
-import {-# SOURCE #-} TcExpr ( tcExpr )
+import {-# SOURCE #-} TcExpr ( tcExpr, tcMonoExpr )
import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
- Match(..), HsMatchContext(..),
+ Match(..), HsMatchContext(..), mkMonoBind,
collectMonoBinders, andMonoBinds,
collectSigTysFromMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
-import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
+import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
import TcRnMonad
-import Inst ( InstOrigin(..), newDicts, instToId )
+import Inst ( InstOrigin(..), newDicts, newIPDict, instToId )
import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
-import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
+import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
+ tcSimplifyToDicts, tcSimplifyIPs )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..),
tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars
)
getLclEnv `thenM` \ env ->
returnM (EmptyMonoBinds, env)
where
- glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing)
+ -- The top level bindings are flattened into a giant
+ -- implicitly-mutually-recursive MonoBinds
+ glue binds1 (binds2, env) = (flatten binds1 `AndMonoBinds` binds2, env)
+ flatten EmptyBinds = EmptyMonoBinds
+ flatten (b1 `ThenBinds` b2) = flatten b1 `AndMonoBinds` flatten b2
+ flatten (MonoBind b _ _) = b
+ -- Can't have a IPBinds at top level
tcBindsAndThen
- :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
+ :: (TcHsBinds -> thing -> thing) -- Combinator
-> RenamedHsBinds
-> TcM thing
-> TcM thing
tc_binds_and_then top_lvl combiner b2 $
do_next
+tc_binds_and_then top_lvl combiner (IPBinds binds is_with) do_next
+ = getLIE do_next `thenM` \ (result, expr_lie) ->
+ mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') ->
+
+ -- 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 (IPBinds binds' is_with) $
+ combiner (mkMonoBind Recursive dict_binds) result)
+ where
+ -- I wonder if we should do these one at at time
+ -- Consider ?x = 4
+ -- ?y = ?x + 1
+ tc_ip_bind (ip, expr)
+ = newTyVarTy openTypeKind `thenM` \ ty ->
+ getSrcLocM `thenM` \ loc ->
+ newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) ->
+ tcMonoExpr 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
-- Notice that they scope over
-- c) the scope of the binding group (the "in" part)
tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $
- -- TYPECHECK THE SIGNATURES
- mappM tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenM` \ tc_ty_sigs ->
+ tcBindWithSigs top_lvl bind sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
-
getLIE (
- tcBindWithSigs top_lvl bind tc_ty_sigs
- sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
-
-- Extend the environment to bind the new polymorphic Ids
tcExtendLocalValEnv poly_ids $
-- Now do whatever happens next, in the augmented envt
do_next `thenM` \ thing ->
- returnM (poly_ids, poly_binds, prag_binds, thing)
- ) `thenM` \ ((poly_ids, poly_binds, prag_binds, thing), lie) ->
+ returnM (prag_binds, thing)
+ ) `thenM` \ ((prag_binds, thing), lie) ->
case top_lvl of
-- leave them to the tcSimplifyTop, and quite a bit faster too
TopLevel
-> extendLIEs lie `thenM_`
- returnM (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing)
+ returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds))
+ thing)
NotTopLevel
-> bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
-- so that we desugar unlifted bindings correctly
if isRec is_rec then
returnM (
- combiner Recursive (
+ combiner (mkMonoBind Recursive (
poly_binds `andMonoBinds`
lie_binds `andMonoBinds`
- prag_binds) thing
+ prag_binds)) thing
)
else
returnM (
- combiner NonRecursive poly_binds $
- combiner NonRecursive prag_binds $
- combiner Recursive lie_binds $
+ combiner (mkMonoBind NonRecursive poly_binds) $
+ combiner (mkMonoBind NonRecursive prag_binds) $
+ combiner (mkMonoBind Recursive lie_binds) $
-- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
-- aren't guaranteed in dependency order (though we could change
-- that); hence the Recursive marker.
tcBindWithSigs
:: TopLevelFlag
-> RenamedMonoBinds
- -> [TcSigInfo]
-> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
-> RecFlag
-> TcM (TcMonoBinds, [TcId])
-tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
- = recoverM (
+tcBindWithSigs top_lvl mbind sigs is_rec
+ = -- TYPECHECK THE SIGNATURES
+ recoverM (returnM []) (
+ mappM tcTySig [sig | sig@(Sig name _ _) <- sigs]
+ ) `thenM` \ tc_ty_sigs ->
+
+ -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
+ recoverM (
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise subsequent
-- error messages
poly_ids = [poly_id | (_, poly_id, _) <- exports]
dict_tys = map idType zonked_dict_ids
- inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
+ inlines = mkNameSet [name | InlineSig True name _ loc <- sigs]
-- Any INLINE sig (regardless of phase control)
-- makes the RHS look small
- inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs,
+ inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- sigs,
not (isAlwaysActive phase)]
-- Set the IdInfo field to control the inline phase
-- AlwaysActive is the default, so don't bother with them
projects / ghc-hetmet.git / blobdiff