import HsSyn ( HsDecl(..), TyClDecl(..),
HsType(..), HsTyVar,
ConDecl(..), ConDetails(..), BangType(..),
- Sig(..),
+ Sig(..), HsPred(..),
tyClDeclName, isClassDecl, isSynDecl
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name )
import Inst ( InstanceMapper )
import TcClassDcl ( kcClassDecl, tcClassDecl1 )
import TcEnv ( ValueEnv, TcTyThing(..),
- tcExtendTypeEnv
+ tcExtendTypeEnv, getAllEnvTyCons
)
import TcTyDecls ( tcTyDecl, kcTyDecl )
import TcMonoType ( kcHsTyVar )
import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind )
import Type ( mkArrowKind, boxedTypeKind )
-import Class ( Class, classBigSig )
-import Var ( tyVarKind )
+
+import Class ( Class )
+import Var ( TyVar, tyVarKind )
+import FiniteMap
import Bag
+import VarSet
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
import Outputable
-import Maybes ( mapMaybe )
+import Maybes ( mapMaybe, expectJust )
import UniqSet ( UniqSet, emptyUniqSet,
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import ErrUtils ( Message )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon )
+import TyCon ( TyCon, ArgVrcs )
+import Variance ( calcTyConArgVrcs )
import Unique ( Unique, Uniquable(..) )
import UniqFM ( listToUFM, lookupUFM )
\end{code}
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
+The knot-tying parameters: @rec_tyclss@ is an alist mapping @Name@s to
+@TcTyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
+
\begin{code}
tcGroup :: ValueEnv -> InstanceMapper -> SCC RenamedTyClDecl -> TcM s TcEnv
tcGroup unf_env inst_mapper scc
-- Tie the knot
-- traceTc (ppr (map fst ty_env_stuff1)) `thenTc_`
- fixTc ( \ ~(rec_tyclss, _) ->
+ fixTc ( \ ~(rec_tyclss, rec_vrcs, _) ->
let
rec_env = listToUFM rec_tyclss
in
-- Do type checking
mapNF_Tc (getTyBinding2 rec_env) ty_env_stuff1 `thenNF_Tc` \ ty_env_stuff2 ->
tcExtendTypeEnv ty_env_stuff2 $
- mapTc (tcDecl is_rec_group unf_env inst_mapper) decls `thenTc` \ tyclss ->
+ mapTc (tcDecl is_rec_group unf_env inst_mapper rec_vrcs) decls
+ `thenTc` \ tyclss ->
tcGetEnv `thenTc` \ env ->
- returnTc (tyclss, env)
- ) `thenTc` \ (_, env) ->
+ let
+ tycons = getAllEnvTyCons env
+ vrcs = calcTyConArgVrcs tycons
+ in
+
+ returnTc (tyclss, vrcs, env)
+ ) `thenTc` \ (_, _, env) ->
-- traceTc (text "done" <+> ppr (map fst ty_env_stuff1)) `thenTc_`
returnTc env
where
kcTyDecl decl
tcDecl :: RecFlag -- True => recursive group
- -> ValueEnv -> InstanceMapper
+ -> ValueEnv -> InstanceMapper -> FiniteMap Name ArgVrcs
-> RenamedTyClDecl -> TcM s (Name, TcTyThing)
-tcDecl is_rec_group unf_env inst_mapper decl
+tcDecl is_rec_group unf_env inst_mapper vrcs_env decl
= tcAddDeclCtxt decl $
-- traceTc (text "Starting" <+> ppr name) `thenTc_`
if isClassDecl decl then
- tcClassDecl1 unf_env inst_mapper decl `thenTc` \ clas ->
+ tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas ->
-- traceTc (text "Finished" <+> ppr name) `thenTc_`
returnTc (getName clas, AClass clas)
else
- tcTyDecl is_rec_group decl `thenTc` \ tycon ->
+ tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon ->
-- traceTc (text "Finished" <+> ppr name) `thenTc_`
returnTc (getName tycon, ATyCon tycon)
where
(name, loc, thing)
= case decl of
- (ClassDecl _ name _ _ _ _ _ _ loc) -> (name, loc, "class")
+ (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class")
(TySynonym name _ _ loc) -> (name, loc, "type synonym")
(TyData NewType _ name _ _ _ _ loc) -> (name, loc, "data type")
(TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype")
Nothing,
ATyCon (error "ATyCon: data")))
-getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _)
+getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _)
= mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds ->
returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
Just (length tyvars),
mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
-mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _)
- = Just (decl, getUnique name, map (getUnique . fst) ctxt)
+mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
+ = Just (decl, getUnique name, map (getUnique . get_clas) ctxt)
mk_cls_edges other_decl
= Nothing
mk_edges decl@(TySynonym name _ rhs _)
= (decl, getUnique name, uniqSetToList (get_ty rhs))
-mk_edges decl@(ClassDecl ctxt name _ sigs _ _ _ _ _)
+mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _)
= (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_sigs sigs))
----------------------------------------------------
-get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
+get_ctxt ctxt = unionManyUniqSets (map (set_name . get_clas) ctxt)
+get_clas (HsPClass clas _) = clas
----------------------------------------------------
get_deriv Nothing = emptyUniqSet
get_cons cons = unionManyUniqSets (map get_con cons)
----------------------------------------------------
-get_con (ConDecl _ _ ctxt details _)
+get_con (ConDecl _ _ _ ctxt details _)
= get_ctxt ctxt `unionUniqSets` get_con_details details
----------------------------------------------------
----------------------------------------------------
get_bty (Banged ty) = get_ty ty
get_bty (Unbanged ty) = get_ty ty
+get_bty (Unpacked ty) = get_ty ty
----------------------------------------------------
get_ty (MonoTyVar name)
= set_name listTyCon_name `unionUniqSets` get_ty ty
get_ty (MonoTupleTy tys boxed)
= set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys
+get_ty (MonoUsgTy _ ty)
+ = get_ty ty
+get_ty (MonoUsgForAllTy _ ty)
+ = get_ty ty
get_ty (HsForAllTy _ ctxt mty)
= get_ctxt ctxt `unionUniqSets` get_ty mty
-get_ty other = panic "TcTyClsDecls:get_ty"
+get_ty (MonoDictTy name _)
+ = set_name name
----------------------------------------------------
get_tys tys
get_sigs sigs
= unionManyUniqSets (map get_sig sigs)
where
- get_sig (ClassOpSig _ _ ty _) = get_ty ty
+ get_sig (ClassOpSig _ _ _ ty _) = get_ty ty
+ get_sig (FixSig _) = emptyUniqSet
get_sig other = panic "TcTyClsDecls:get_sig"
----------------------------------------------------
projects / ghc-hetmet.git / blobdiff