-@checkSigTyVars@ is used after the type in a type signature has been unified with
-the actual type found. It then checks that the type variables of the type signature
-are
- (a) still all type variables
- eg matching signature [a] against inferred type [(p,q)]
- [then a will be unified to a non-type variable]
-
- (b) still all distinct
- eg matching signature [(a,b)] against inferred type [(p,p)]
- [then a and b will be unified together]
-
-BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS
-
- (c) not mentioned in the environment
- eg the signature for f in this:
-
- g x = ... where
- f :: a->[a]
- f y = [x,y]
-
- Here, f is forced to be monorphic by the free occurence of x.
-
-Before doing this, the substitution is applied to the signature type variable.
-
-\begin{code}
-checkSigTyVars :: [TcTyVar s] -- The original signature type variables
- -> TcType s -- signature type (for err msg)
- -> TcM s ()
+ -- This function is used when dealing with a LHS binder;
+ -- we make a monomorphic version of the Id.
+ -- We check for a type signature; if there is one, we use the mono_id
+ -- from the signature. This is how we make sure the tau part of the
+ -- signature actually maatches the type of the LHS; then tc_mb_pats
+ -- ensures the LHS and RHS have the same type
+
+ tc_pat_bndr name pat_ty
+ = case maybeSig tc_ty_sigs name of
+ Nothing
+ -> newLocalId (getOccName name) pat_ty (getSrcLoc name)
+
+ Just (TySigInfo _ _ _ _ _ mono_id _ _)
+ -> tcAddSrcLoc (getSrcLoc name) $
+ unifyTauTy (idType mono_id) pat_ty `thenTc_`
+ returnTc mono_id
+
+ mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
+ Nothing -> (name, mono_id)
+ Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
+
+ tc_mb_pats EmptyMonoBinds
+ = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+ tc_mb_pats (AndMonoBinds mb1 mb2)
+ = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
+ tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
+ let
+ complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
+ complete_it2 xve `thenTc` \ (mb2', lie2) ->
+ returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
+ in
+ returnTc (complete_it,
+ lie_req1 `plusLIE` lie_req2,
+ tvs1 `unionBags` tvs2,
+ ids1 `unionBags` ids2,
+ lie_avail1 `plusLIE` lie_avail2)
+
+ tc_mb_pats (FunMonoBind name inf matches locn)
+ = newTyVarTy kind `thenNF_Tc` \ bndr_ty ->
+ tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
+ let
+ complete_it xve = tcAddSrcLoc locn $
+ tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
+ returnTc (FunMonoBind bndr_id inf matches' locn, lie)
+ in
+ returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
+
+ tc_mb_pats bind@(PatMonoBind pat grhss locn)
+ = tcAddSrcLoc locn $
+ newTyVarTy kind `thenNF_Tc` \ pat_ty ->
+
+ -- Now typecheck the pattern
+ -- We don't support binding fresh (not-already-in-scope) scoped
+ -- type variables in the pattern of a pattern binding.
+ -- For example, this is illegal:
+ -- (x::a, y::b) = e
+ -- whereas this is ok
+ -- (x::Int, y::Bool) = e
+ --
+ -- We don't check explicitly for this problem. Instead, we simply
+ -- type check the pattern with tcPat. If the pattern mentions any
+ -- fresh tyvars we simply get an out-of-scope type variable error
+ tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+ let
+ complete_it xve = tcAddSrcLoc locn $
+ tcAddErrCtxt (patMonoBindsCtxt bind) $
+ tcExtendLocalValEnv xve $
+ tcGRHSs PatBindRhs grhss pat_ty `thenTc` \ (grhss', lie) ->
+ returnTc (PatMonoBind pat' grhss' locn, lie)
+ in
+ returnTc (complete_it, lie_req, tvs, ids, lie_avail)
projects / ghc-hetmet.git / blobdiff