X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FBuildTyCl.lhs;h=333d8084ce4a301144cadb1ddcde85b41ef3c47c;hp=75d7234059bf25bf071d05dc44f95e44c6e4775e;hb=6777144f7522d8db5935737e12fa451ca3211e6d;hpb=49c98d143c382a1341e1046f5ca00819a25691ba diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 75d7234..333d808 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -7,7 +7,7 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, - mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs, + mkAbstractTyConRhs, mkOpenDataTyConRhs, mkNewTyConRhs, mkDataTyConRhs ) where @@ -28,7 +28,6 @@ import Class import TyCon import Type import Coercion -import Outputable import Data.List \end{code} @@ -36,16 +35,29 @@ import Data.List \begin{code} ------------------------------------------------------ -buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon -buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki) - = mkSynTyCon name kind tvs rhs - where - kind = mkArrowKinds (map tyVarKind tvs) rhs_ki -buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty) - = mkSynTyCon name kind tvs rhs - where - kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty) +buildSynTyCon :: Name -> [TyVar] + -> SynTyConRhs + -> Maybe (TyCon, [Type]) -- family instance if applicable + -> TcRnIf m n TyCon +buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _ + = let + kind = mkArrowKinds (map tyVarKind tvs) rhs_ki + in + return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon + +buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family + = do { -- We need to tie a knot as the coercion of a data instance depends + -- on the instance representation tycon and vice versa. + ; tycon <- fixM (\ tycon_rec -> do + { parent <- mkParentInfo mb_family tc_name tvs tycon_rec + ; let { tycon = mkSynTyCon tc_name kind tvs rhs parent + ; kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty) + } + ; return tycon + }) + ; return tycon + } ------------------------------------------------------ buildAlgTyCon :: Name -> [TyVar] @@ -62,7 +74,7 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn = do { -- We need to tie a knot as the coercion of a data instance depends -- on the instance representation tycon and vice versa. ; tycon <- fixM (\ tycon_rec -> do - { parent <- parentInfo mb_family tycon_rec + { parent <- mkParentInfo mb_family tc_name tvs tycon_rec ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs fields parent is_rec want_generics gadt_syn ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind @@ -72,38 +84,38 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn }) ; return tycon } - where - -- If a family tycon with instance types is given, the current tycon is an - -- instance of that family and we need to - -- - -- (1) create a coercion that identifies the family instance type and the - -- representation type from Step (1); ie, it is of the form - -- `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion, - -- `F' the family tycon and `R' the (derived) representation tycon, - -- and - -- (2) produce a `AlgTyConParent' value containing the parent and coercion - -- information. - -- - parentInfo Nothing rep_tycon = - return NoParentTyCon - parentInfo (Just (family, instTys)) rep_tycon = - do { -- Create the coercion - ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc - ; let co_tycon = mkDataInstCoercion co_tycon_name tvs - family instTys rep_tycon - ; return $ FamilyTyCon family instTys co_tycon - } - +-- If a family tycon with instance types is given, the current tycon is an +-- instance of that family and we need to +-- +-- (1) create a coercion that identifies the family instance type and the +-- representation type from Step (1); ie, it is of the form +-- `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion, +-- `F' the family tycon and `R' the (derived) representation tycon, +-- and +-- (2) produce a `TyConParent' value containing the parent and coercion +-- information. +-- +mkParentInfo :: Maybe (TyCon, [Type]) + -> Name -> [TyVar] + -> TyCon + -> TcRnIf m n TyConParent +mkParentInfo Nothing _ _ _ = + return NoParentTyCon +mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon = + do { -- Create the coercion + ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc + ; let co_tycon = mkFamInstCoercion co_tycon_name tvs + family instTys rep_tycon + ; return $ FamilyTyCon family instTys co_tycon + } + ------------------------------------------------------ mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs = AbstractTyCon mkOpenDataTyConRhs :: AlgTyConRhs -mkOpenDataTyConRhs = OpenDataTyCon - -mkOpenNewTyConRhs :: AlgTyConRhs -mkOpenNewTyConRhs = OpenNewTyCon +mkOpenDataTyConRhs = OpenTyCon Nothing mkDataTyConRhs :: [DataCon] -> AlgTyConRhs mkDataTyConRhs cons @@ -115,15 +127,15 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs -- because the latter is part of a knot, whereas the former is not. mkNewTyConRhs tycon_name tycon con = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_rhs + ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs cocon_maybe | all_coercions || isRecursiveTyCon tycon = Just co_tycon | otherwise = Nothing ; return (NewTyCon { data_con = con, nt_rhs = rhs_ty, - nt_etad_rhs = etad_rhs, - nt_co = cocon_maybe, + nt_etad_rhs = (etad_tvs, etad_rhs), + nt_co = cocon_maybe, -- Coreview looks through newtypes with a Nothing -- for nt_co, or uses explicit coercions otherwise nt_rep = mkNewTyConRep tycon rhs_ty }) } @@ -137,9 +149,11 @@ mkNewTyConRhs tycon_name tycon con -- Instantiate the data con with the -- type variables from the tycon - etad_rhs :: ([TyVar], Type) - etad_rhs = eta_reduce (reverse tvs) rhs_ty - + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can + etad_rhs :: Type -- return a TyCon without pulling on rhs_ty + -- See Note [Tricky iface loop] in LoadIface + (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty + eta_reduce :: [TyVar] -- Reversed -> Type -- Rhs type -> ([TyVar], Type) -- Eta-reduced version (tyvars in normal order) @@ -300,7 +314,7 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; tycon = mkClassTyCon tycon_name clas_kind tvs - rhs rec_clas tc_isrec + rhs rec_clas tc_isrec -- A class can be recursive, and in the case of newtypes -- this matters. For example -- class C a where { op :: C b => a -> b -> Int }