binder_ftvs = munge_id_ty binder
-- We need to collect free tyvars from the binder
+-- Don't forget to notice that the idSpecVars of the binder
+-- are free in the whole expression; albeit not in the RHS or body
+
fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
- = (FVInfo (freeVarsOf rhs' `combine` body_fvs)
+ = (FVInfo (freeVarsOf rhs' `combine` body_fvs `combine` mkIdSet (idSpecVars binder))
(freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
(leakinessOf rhs' `orLeak` leakinessOf body2),
AnnLet (AnnNonRec binder rhs') body2)
FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
= foldr1 combineFVInfo [info | (info,_) <- rhss']
- binds_fvs = rhss_fvs `minusIdSet` binders_set
+ -- Don't forget to notice that the idSpecVars of the binder
+ -- are free in the whole expression; albeit not in the RHS or body
+ binds_fvs = (foldr (unionIdSets . mkIdSet . idSpecVars) rhss_fvs binders)
+ `minusIdSet`
+ binders_set
+
body2 = fvExpr new_id_cands tyvar_cands body
body_fvs = freeVarsOf body2 `minusIdSet` binders_set
binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
where
expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
--- fvRhs returns the annotated RHS, but it adds to the
--- free vars of the RHS the idSpecVars of the binder,
--- since those are, in truth, free in the definition.
fvRhs id_cands tyvar_cands (bndr,rhs)
- = (FVInfo fvs' ftvs leak, rhs')
- where
- (FVInfo fvs ftvs leak, rhs') = fvExpr id_cands tyvar_cands rhs
- fvs' = fvs `unionIdSets` mkIdSet (idSpecVars bndr)
-
+ = fvExpr id_cands tyvar_cands rhs
\end{code}
\begin{code}
| DERIVING dtyclses { $$ = mkjust($2); }
;
-classd : classkey simple_context DARROW simple_con_app1 cbody
- { $$ = mkcbind($2,$4,$5,startlineno); }
- | classkey simple_con_app1 cbody
- { $$ = mkcbind(Lnil,$2,$3,startlineno); }
+classd : classkey btype DARROW simple_con_app1 cbody
+ /* Context can now be more than simple_context */
+ { $$ = mkcbind(type2context($2),$4,$5,startlineno); }
+ | classkey btype cbody
+ /* We have to say btype rather than simple_con_app1, else
+ we get reduce/reduce errs */
+ { check_class_decl_head($3);
+ $$ = mkcbind(Lnil,$2,$3,startlineno); }
;
cbody : /* empty */ { $$ = mknullbind(); }
/* Compare ctype */
inst_type : type DARROW type { is_context_format( $3, 0 ); /* Check the instance head */
$$ = mkcontext(type2context($1),$3); }
- | type { is_context_format( $1, 0 ); /* Check the instance head */
+ | btype { is_context_format( $1, 0 ); /* Check the instance head */
$$ = $1; }
;
/* A sigtype is a rank 2 type; it can have for-alls as function args:
f :: All a => (All b => ...) -> Int
*/
-sigtype : type DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
+sigtype : btype DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
| sigarrowtype
;
;
/* A "big" atype can be a forall-type in brackets. */
-bigatype: OPAREN type DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
+bigatype: OPAREN btype DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
;
/* 1 S/R conflict at DARROW -> shift */
-ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); }
+ctype : btype DARROW type { $$ = mkcontext(type2context($1),$3); }
| type
;
;
constr : constr_after_context
- | type DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
+ | btype DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
;
constr_after_context :
hsperror("syntax error: unexpected ! in type");
checknobangs(gtapp((struct Stapp *)app));
- }
+ }
+}
+
+
+/* Check that a type is of the form
+ C a1 a2 .. an
+ where n>=1, and the ai are all type variables
+ This is used to check that a class decl is well formed.
+*/
+void
+check_class_decl_head_help( app, n )
+ ttype app;
+ int n; /* Number of args so far */
+{
+ switch (tttype(app)) {
+ case tapp:
+ /* Check the arg is a type variable */
+ switch (tttype (gtarg((struct Stapp *) app))) {
+ case namedtvar: break;
+ default: hsperror("Class declaration head must use only type variables");
+ }
+
+ /* Check the fun part */
+ check_class_decl_head_help( gtapp((struct Stapp *) app), n+1 );
+ break;
+
+ case tname:
+ /* Class name; check there is at least one argument */
+ if (n==0) {
+ hsperror("Class must have at least one argument");
+ }
+ break;
+
+ default:
+ hsperror("Illegal syntax in class declaration head");
+ }
}
+void
+check_class_decl_head( app )
+ ttype app;
+{ check_class_decl_head_help( app, 0 ); }
+
+
/*
Splits a tycon application into its constructor and a list of types.
split' drop_pts_fvs [] mult_branch drop_boxes
= (drop_boxes, mult_branch, drop_pts_fvs)
- -- only in a or unused
- split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
- | all (\b -> {-b `elementOfIdSet` a &&-}
- not (b `elementOfIdSet` (unionManyIdSets as)))
- (bindersOf (fst bind))
- = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
- where
- a' = a `unionIdSets` fvsOfBind bind
+ split' drop_pts_fvs (bind:binds) mult_branch drop_boxes
+ | no_of_branches == 1 -- Exactly one branch
+ = split' drop_pts_fvs' binds mult_branch drop_boxes'
- -- not in a
- split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
- | all (\b -> not (b `elementOfIdSet` a)) (bindersOf (fst bind))
- = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
- where
- (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
+ | otherwise -- Zero or many branches; drop it here
+ = split' drop_pts_fvs binds (bind:mult_branch) drop_boxes
- -- in a and in as
- split' aas@(a:as) (bind:binds) mult_branch drop_boxes
- = split' aas' binds (bind : mult_branch) drop_boxes
where
- aas' = map (unionIdSets (fvsOfBind bind)) aas
+ binders = bindersOf (fst bind)
+ no_of_branches = length [() | True <- in_branch_flags]
+ in_branch_flags = [ any (`elementOfIdSet` branch_fvs) binders
+ | branch_fvs <- drop_pts_fvs ]
+
+ (drop_pts_fvs', drop_boxes') = unzip (zipWith3 drop in_branch_flags drop_pts_fvs drop_boxes)
+ drop True drop_fvs box = (drop_fvs `unionIdSets` fvsOfBind bind, bind:box)
+ drop False drop_fvs box = (drop_fvs, box)
+
-------------------------
fvsOfBind (_,fvs) = fvs
-- The tyvars_not_to_gen are free in the environment, and hence
-- candidates for generalisation, but sometimes the monomorphism
-- restriction means we can't generalise them nevertheless
- getTyVarsToGen is_unrestricted mono_id_tys lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
+ getTyVarsToGen is_unrestricted mono_id_tys lie `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-- DEAL WITH TYPE VARIABLE KINDS
-- **** This step can do unification => keep other zonking after this ****
- mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
+ mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
let
real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list
-- It's important that the final list
in
if is_unrestricted
then
- returnTc (emptyTyVarSet, tyvars_to_gen)
+ returnNF_Tc (emptyTyVarSet, tyvars_to_gen)
else
+ -- This recover and discard-errs is to avoid duplicate error
+ -- messages; this, after all, is an "extra" call to tcSimplify
+ recoverNF_Tc (returnNF_Tc (emptyTyVarSet, tyvars_to_gen)) $
+ discardErrsTc $
+
tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
let
-- ASSERT: dicts_sig is already zonked!
import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
InPat(..), HsBinds(..), GRHSsAndBinds(..), GRHS(..),
- HsExpr(..), HsLit(..),
+ HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
unguardedRHS, andMonoBinds, getTyVarName
)
import HsPragmas ( ClassPragmas(..) )
unifyKinds class_kinds tyvar_kinds `thenTc_`
-- CHECK THE CONTEXT
- tcClassContext rec_class rec_tyvars context pragmas
+ tcClassContext class_name rec_class rec_tyvars context pragmas
`thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
-- CHECK THE CLASS SIGNATURES,
\begin{code}
-tcClassContext :: Class -> [TyVar]
+tcClassContext :: Name -> Class -> [TyVar]
-> RenamedContext -- class context
-> RenamedClassPragmas -- pragmas for superclasses
-> TcM s (ThetaType, -- the superclass context
[Type], -- types of the superclass dictionaries
[Id]) -- superclass selector Ids
-tcClassContext rec_class rec_tyvars context pragmas
+tcClassContext class_name rec_class rec_tyvars context pragmas
= -- Check the context.
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
+
+ -- For std Haskell check that the context constrains only tyvars
+ (if opt_GlasgowExts then
+ returnTc []
+ else
+ mapTc check_constraint context
+ ) `thenTc_`
+
tcContext context `thenTc` \ sc_theta ->
+
let
sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
in
in
returnTc (mkSuperDictSelId uniq rec_class index ty)
+ check_constraint (c, tys) = checkTc (all is_tyvar tys)
+ (superClassErr class_name (c, tys))
+
+ is_tyvar (MonoTyVar _) = True
+ is_tyvar other = False
+
tcClassSig :: GlobalValueEnv -- Knot tying only!
-> Class -- ...ditto...
classDeclCtxt class_name
= ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
+superClassErr class_name sc
+ = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
+ <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
+
methodCtxt sel_id
= ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
Inst, LIE, pprInsts, pprInstsInFull, mkLIE,
InstOrigin, pprOrigin
)
-import TcEnv ( TcIdOcc(..) )
+import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars )
import TcType ( TcType, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta )
import Unify ( unifyTauTy )
import Id ( mkIdSet )
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
import TyVar ( intersectTyVarSets, unionManyTyVarSets, minusTyVarSet,
- isEmptyTyVarSet, tyVarSetToList,
+ isEmptyTyVarSet, tyVarSetToList, unionTyVarSets,
zipTyVarEnv, emptyTyVarEnv
)
import FiniteMap
-- But we can get stuck with
-- C a b
-- where "a" is one of the local_tvs, but "b" is unconstrained.
- -- Then we must yell about the ambiguous b
+ -- Then we must yell about the ambiguous b.
+ -- But we must only do so if "b" really is unconstrained; so
+ -- we must grab the global tyvars to answer that question
+ tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
let
+ avail_tvs = local_tvs `unionTyVarSets` global_tvs
(irreds', bad_guys) = partition (isEmptyTyVarSet . ambig_tv_fn) irreds
- ambig_tv_fn dict = tyVarsOfInst dict `minusTyVarSet` local_tvs
+ ambig_tv_fn dict = tyVarsOfInst dict `minusTyVarSet` avail_tvs
in
addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
text "----------------------"
]) $
-}
-
-- Build the Avail mapping from "givens"
foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
text "given" <+> ppr givens,
text "wanted" <+> ppr wanteds,
text "----",
- pprAvails avails,
+ text "avails" <+> pprAvails avails,
+ text "free" <+> ppr frees,
+ text "irreds" <+> ppr irreds,
text "----------------------"
]) $
-}
import TyCon ( isFunTyCon )
import Kind ( Kind )
import TcMonad
+import Name ( changeUnique )
import TysPrim ( voidTy )
tcNewMutVar UnBound `thenNF_Tc` \ box ->
-- Was DontBind, but we've nuked that "optimisation"
+ let
+ name' = case name of
+ Nothing -> Nothing
+ Just n -> Just (changeUnique n uniq)
+ in
- returnNF_Tc (TyVar uniq kind name box)
+ returnNF_Tc (TyVar uniq kind name' box)
-- We propagate the name of the sigature type variable
\end{code}
projects / ghc-hetmet.git / commitdiff