From: simonpj Date: Fri, 5 Sep 1997 16:24:32 +0000 (+0000) Subject: [project @ 1997-09-05 16:23:41 by simonpj] X-Git-Tag: Approx_2487_patches~1520 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e72062f5239a13f243d6e98b5124e2fdbab1c940;p=ghc-hetmet.git [project @ 1997-09-05 16:23:41 by simonpj] SLPJ fixes --- diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 5ec4732..2b3e68a 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -45,7 +45,11 @@ import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccNam OccName, occNameString, nameOccName, nameString, isExported, Name {-instance NamedThing-}, Provenance, NamedThing(..) ) -import TyCon ( TyCon(..) {-instance NamedThing-} ) +import TyCon ( TyCon {-instance NamedThing-}, + isSynTyCon, isAlgTyCon, isNewTyCon, tyConDataCons, + tyConTheta, tyConTyVars, + getSynTyConDefn + ) import Class ( GenClass(..){-instance NamedThing-}, SYN_IE(Class), classBigSig ) import FieldLabel ( FieldLabel{-instance NamedThing-}, fieldLabelName, fieldLabelType ) @@ -403,30 +407,32 @@ upp_class clas = ifaceClass PprInterface clas \begin{code} ifaceTyCon :: PprStyle -> TyCon -> Doc + ifaceTyCon sty tycon - = case tycon of - DataTyCon uniq name kind tyvars theta data_cons deriv new_or_data - -> hsep [ ptext (keyword new_or_data), - ppr_decl_context sty theta, - ppr sty name, - hsep (map (pprTyVarBndr sty) tyvars), - ptext SLIT("="), - hsep (punctuate (ptext SLIT(" | ")) (map ppr_con data_cons)), - semi - ] - - SynTyCon uniq name kind arity tyvars ty - -> hsep [ ptext SLIT("type"), - ppr sty name, - hsep (map (pprTyVarBndr sty) tyvars), - ptext SLIT("="), - ppr sty ty, - semi - ] - other -> pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon) + | isSynTyCon tycon + = hsep [ ptext SLIT("type"), + ppr sty (getName tycon), + hsep (map (pprTyVarBndr sty) tyvars), + ptext SLIT("="), + ppr sty ty, + semi + ] where - keyword NewType = SLIT("newtype") - keyword DataType = SLIT("data") + (tyvars, ty) = getSynTyConDefn tycon + +ifaceTyCon sty tycon + | isAlgTyCon tycon + = hsep [ ptext keyword, + ppr_decl_context sty (tyConTheta tycon), + ppr sty (getName tycon), + hsep (map (pprTyVarBndr sty) (tyConTyVars tycon)), + ptext SLIT("="), + hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))), + semi + ] + where + keyword | isNewTyCon tycon = SLIT("newtype") + | otherwise = SLIT("data") ppr_con data_con | null field_labels @@ -458,6 +464,9 @@ ifaceTyCon sty tycon ppr_strict_mark strict_mark <> pprParendType sty (fieldLabelType field_label) ] +ifaceTyCon sty tycon + = pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon) + ifaceClass sty clas = hsep [ptext SLIT("class"), ppr_decl_context sty theta, diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 069f54f..36134a2 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -16,7 +16,7 @@ IMP_Ubiq(){-uitous-} import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) import Name ( mkWiredInTyConName ) import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn -import TyCon ( mkPrimTyCon, mkDataTyCon, SYN_IE(TyCon) ) +import TyCon ( mkPrimTyCon, mkDataTyCon, TyCon ) import BasicTypes ( NewOrData(..) ) import Type ( applyTyCon, mkTyVarTys, mkTyConTy, SYN_IE(Type) ) import TyVar ( GenTyVar(..), alphaTyVars ) @@ -44,9 +44,7 @@ pcPrimTyCon key str arity primrep = the_tycon where name = mkWiredInTyConName key gHC__ str the_tycon - the_tycon = mkPrimTyCon name (mk_kind arity) primrep - mk_kind 0 = mkUnboxedTypeKind - mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1) + the_tycon = mkPrimTyCon name arity primrep charPrimTy = applyTyCon charPrimTyCon [] diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index dc31266..dc65e0f 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -411,10 +411,14 @@ show_uniq PprDebug u = ppr PprDebug u show_uniq sty u = empty \end{code} -Printing in error messages +Printing in error messages. These two must look the same. \begin{code} noInstanceErr inst sty = ptext SLIT("No instance for:") <+> ppr sty inst + +noSimpleInst clas ty sty + = ptext SLIT("No instance for:") <+> + (pprQuote sty (\ sty -> ppr sty clas <+> pprParendGenType sty ty)) \end{code} %************************************************************************ @@ -534,10 +538,6 @@ lookupSimpleInst class_inst_env clas ty Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta] where (_, theta, _) = splitSigmaTy (idType dfun) - -noSimpleInst clas ty sty - = ptext SLIT("No instance for") <+> - (pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty) \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 9961cc6..e2e65d5 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -26,7 +26,7 @@ import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr), mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod ) -import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo, +import TcEnv ( tcLookupClass, tcLookupTyVar, newLocalIds, tcAddImportedIdInfo, tcExtendGlobalTyVars ) import TcBinds ( tcBindWithSigs, TcSigInfo(..) ) import TcKind ( unifyKind, TcKind ) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 7d667e3..94aa166 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -37,7 +37,7 @@ import RnEnv ( newDfunName, bindLocatedLocalsRn ) import RnMonad ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..), setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn ) -import Bag ( Bag, isEmptyBag, unionBags, listToBag ) +import Bag ( Bag, emptyBag, isEmptyBag, unionBags, listToBag ) import Class ( classKey, GenClass, SYN_IE(Class) ) import ErrUtils ( addErrLoc, SYN_IE(Error) ) import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId ) @@ -48,7 +48,7 @@ import Name ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance, ) import Outputable ( PprStyle(..), Outputable(..){-instances e.g., (,)-} ) import PprType ( GenType, GenTyVar, GenClass, TyCon ) -import Pretty ( ($$), vcat, hsep, hcat, parens, +import Pretty ( ($$), vcat, hsep, hcat, parens, empty, (<+>), ptext, char, hang, Doc ) import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, @@ -207,7 +207,9 @@ tcDeriving :: Module -- name of module under scrutiny -- for debugging via -ddump-derivings. tcDeriving modname rn_name_supply inst_decl_infos_in - = -- Fish the "deriving"-related information out of the TcEnv + = recoverTc (returnTc (emptyBag, EmptyBinds, \_ -> empty)) $ + + -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". makeDerivEqns `thenTc` \ eqns -> @@ -431,13 +433,21 @@ solveDerivEqns inst_decl_infos_in orig_eqns initial_solutions :: [DerivSoln] initial_solutions = [ [] | _ <- orig_eqns ] + ------------------------------------------------------------------ -- iterateDeriv calculates the next batch of solutions, -- compares it with the current one; finishes if they are the -- same, otherwise recurses with the new solutions. - + -- It fails if any iteration fails iterateDeriv :: [DerivSoln] ->TcM s [InstInfo] - iterateDeriv current_solns + = checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_inst_infos, new_solns) -> + if (current_solns `eq_solns` new_solns) then + returnTc new_inst_infos + else + iterateDeriv new_solns + + ------------------------------------------------------------------ + iterateOnce current_solns = -- Extend the inst info from the explicit instance decls -- with the current set of solutions, giving a @@ -448,27 +458,24 @@ solveDerivEqns inst_decl_infos_in orig_eqns in -- Simplify each RHS - listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs - | (_,_,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns -> + listTc [ tcAddErrCtxt (derivCtxt tc) $ + tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs + | (_,tc,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns -> -- Canonicalise the solutions, so they compare nicely let canonicalised_next_solns - = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in - - if (current_solns `eq_solns` canonicalised_next_solns) then - returnTc new_inst_infos - else - iterateDeriv canonicalised_next_solns + = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] + in + returnTc (new_inst_infos, canonicalised_next_solns) - where - ------------------------------------------------------------------ - lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False } - eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False } - cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2 - cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2) + ------------------------------------------------------------------ + lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False } + eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False } + cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2 + cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2) = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2) #ifdef DEBUG - cmp_rhs other_1 other_2 + cmp_rhs other_1 other_2 = panic# "tcDeriv:cmp_rhs:" --(hsep [ppr PprDebug other_1, ppr PprDebug other_2]) #endif @@ -483,9 +490,16 @@ add_solns :: Bag InstInfo -- The global, non-derived ones -- because we need the LHS info for addClassInstance. add_solns inst_infos_in eqns solns - = discardErrsTc (buildInstanceEnvs all_inst_infos) `thenTc` \ inst_mapper -> + +-- ------------------ +-- OLD: checkErrsTc above now deals with this +-- = discardErrsTc (buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper -> -- We do the discard-errs so that we don't get repeated error messages - -- about missing or duplicate instances. + -- about duplicate instances. + -- They'll appear later, when we do the top-level buildInstanceEnvs. +-- ------------------ + + = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper -> returnTc (new_inst_infos, inst_mapper) where new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns @@ -503,7 +517,8 @@ add_solns inst_infos_in eqns solns (my_panic "upragmas") where dummy_dfun_id - = mkDictFunId bottom dummy_dfun_ty bottom bottom + = mkDictFunId (getName tycon) dummy_dfun_ty bottom bottom + -- The name is getSrcLoc'd in an error message where bottom = panic "dummy_dfun_id" @@ -722,4 +737,7 @@ derivingThingErr thing why tycon sty = hang (hsep [ptext SLIT("Can't make a derived instance of"), ptext thing]) 0 (hang (hsep [ptext SLIT("for the type"), ppr sty tycon]) 0 (parens (ptext why))) + +derivCtxt tycon sty + = ptext SLIT("When deriving classes for") <+> ppr sty tycon \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 2fb27cb..32fdf22 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -39,7 +39,7 @@ import TcType ( SYN_IE(TcIdBndr), TcIdOcc(..), import TyVar ( unionTyVarSets, emptyTyVarSet, tyVarSetToList, SYN_IE(TyVar) ) import PprType ( GenTyVar ) import Type ( tyVarsOfTypes, splitForAllTy ) -import TyCon ( TyCon, tyConKind, synTyConArity, SYN_IE(Arity) ) +import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon, SYN_IE(Arity) ) import Class ( SYN_IE(Class), GenClass ) import TcMonad @@ -141,21 +141,34 @@ tcLookupTyVar name tcLookupTyCon name - = case maybeWiredInTyConName name of - Just tc -> returnTc (kindToTcKind (tyConKind tc), synTyConArity tc, tc) - Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - case lookupUFM tce name of - Just stuff -> returnTc stuff - Nothing -> -- Could be that he's using a class name as a type constructor - case lookupUFM ce name of - Just _ -> failTc (classAsTyConErr name) - Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name) + = -- Try for a wired-in tycon + case maybeWiredInTyConName name of { + Just tc | isSynTyCon tc -> returnTc (kind, Just (tyConArity tc), tc) + | otherwise -> returnTc (kind, Nothing, tc) + where { + kind = kindToTcKind (tyConKind tc) + }; + + Nothing -> + + -- Try in the environment + tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + case lookupUFM tce name of { + Just stuff -> returnTc stuff; + + Nothing -> + + -- Could be that he's using a class name as a type constructor + case lookupUFM ce name of + Just _ -> failTc (classAsTyConErr name) + Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name) + } } tcLookupTyConByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce - (pprPanic "tcLookupTyCon:" (pprUnique10 uniq)) + (pprPanic "tcLookupTyConByKey:" (pprUnique10 uniq)) uniq in returnNF_Tc tycon diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index b563125..542ff8d 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -66,7 +66,9 @@ import TysWiredIn ( addrTy, boolTy, charTy, stringTy, mkListTy, mkTupleTy, mkPrimIoTy, stDataCon ) -import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) +import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, + unifyFunTy, unifyListTy, unifyTupleTy + ) import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, @@ -334,15 +336,11 @@ tcExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list tcExpr expr elt_ty tcExpr (ExplicitTuple exprs) res_ty - -- ToDo: more direct way of testing if res_ty is a tuple type (cf. unifyListTy)? - = mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..len] `thenNF_Tc` \ ty_vars -> - unifyTauTy (mkTupleTy len ty_vars) res_ty `thenTc_` - mapAndUnzipTc (\ (expr,ty_var) -> tcExpr expr ty_var) - (exprs `zip` ty_vars) -- we know they're of equal length. + = unifyTupleTy (length exprs) res_ty `thenTc` \ arg_tys -> + mapAndUnzipTc (\ (expr, arg_ty) -> tcExpr expr arg_ty) + (exprs `zip` arg_tys) -- we know they're of equal length. `thenTc` \ (exprs', lies) -> returnTc (ExplicitTuple exprs', plusLIEs lies) - where - len = length exprs tcExpr (RecordCon con rbinds) res_ty = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> @@ -483,7 +481,7 @@ tcExpr (RecordUpd record_expr rbinds) res_ty tcExpr (ArithSeqIn seq@(From expr)) res_ty = unifyListTy res_ty `thenTc` \ elt_ty -> - tcExpr expr elt_ty `thenTc` \ (expr', lie1) -> + tcExpr expr elt_ty `thenTc` \ (expr', lie1) -> tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id -> newMethod (ArithSeqOrigin seq) @@ -549,11 +547,9 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty let (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig' in - unifyTauTy sig_tau' res_ty `thenTc_` - -- Type check the expression, *after* we've incorporated the signature - -- info into res_ty - tcExpr expr res_ty `thenTc` \ (texpr, lie) -> + -- Type check the expression, expecting the signature type + tcExpr expr sig_tau' `thenTc` \ (texpr, lie) -> -- Check the type variables of the signature, -- *after* typechecking the expression @@ -565,6 +561,13 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty (mkTyVarSet sig_tyvars') sig_dicts lie `thenTc_` + -- Now match the signature type with res_ty. + -- We must not do this earlier, because res_ty might well + -- mention variables free in the environment, and we'd get + -- bogus complaints about not being able to for-all the + -- sig_tyvars + unifyTauTy sig_tau' res_ty `thenTc_` + -- If everything is ok, return the stuff unchanged, except for -- the effect of any substutions etc. We simply discard the -- result of the tcSimplifyAndCheck, except for any default @@ -588,20 +591,6 @@ tcExpr_id id_expr other -> newTyVarTy mkTypeKind `thenNF_Tc` \ id_ty -> tcExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) -> returnTc (id_expr', lie_id, id_ty) - - ---ToDo: move to Unify? -unifyListTy :: TcType s -- expected list type - -> TcM s (TcType s) -- list element type -unifyListTy res_ty - -- ToDo: more direct way of testing if res_ty is a list type (cf. unifyFunTy)? - = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty -> - unifyTauTy (mkListTy elt_ty) res_ty `thenTc_` - - -- This zonking makes the returned type as informative - -- as possible. - zonkTcType elt_ty `thenNF_Tc` \ elt_ty' -> - returnTc elt_ty' \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index e47929b..baaee4e 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -192,8 +192,7 @@ tcInstDecls1 unf_env decls mod_name rn_name_supply in -- Handle "derived" instances; note that we only do derivings -- for things in this module; we ignore deriving decls from - -- interfaces! We pass fixities, because they may be used - -- in deriving Read and Show. + -- interfaces! tcDeriving mod_name rn_name_supply decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) -> diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 8dfdacc..8f81f0b 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -17,7 +17,7 @@ module TcMonad( listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc, checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, - failTc, warnTc, recoverTc, recoverNF_Tc, discardErrsTc, + failTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc, tcGetEnv, tcSetEnv, tcGetDefaultTys, tcSetDefaultTys, @@ -316,6 +316,40 @@ recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r recoverNF_Tc recover m down env = recoverSST (\ _ -> recover down env) (m down env) +-- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors +-- If m fails then (checkNoErrsTc m) fails. +-- If m succeeds, it checks whether m generated any errors messages +-- (it might have recovered internally) +-- If so, it fails too. +-- Regardless, any errors generated by m are propagated to the enclosing +-- context. + +checkNoErrsTc :: TcM s r -> TcM s r +checkNoErrsTc m down env + = newMutVarSST (emptyBag,emptyBag) `thenSST` \ m_errs_var -> + let + errs_var = getTcErrs down + propagate_errs + = readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) -> + readMutVarSST errs_var `thenSST` \ (warns, errs) -> + writeMutVarSST errs_var (warns `unionBags` m_warns, + errs `unionBags` m_errs) `thenSST_` + returnSST m_errs + in + + recoverFSST (\ _ -> propagate_errs `thenSST_` failFSST ()) $ + + m (setTcErrs down m_errs_var) env `thenFSST` \ result -> + + -- Check that m has no errors; if it has internal recovery + -- mechanisms it might "succeed" but having found a bunch of + -- errors along the way. + propagate_errs `thenSST` \ errs -> + if isEmptyBag errs then + returnFSST result + else + failFSST () + -- (tryTc r m) tries m; if it succeeds it returns it, -- otherwise it returns r. Any error messages added by m are discarded, -- whether or not m succeeds. diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index cbc42a8..dcab735 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -9,21 +9,25 @@ updatable substitution). \begin{code} #include "HsVersions.h" -module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where +module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, + unifyFunTy, unifyListTy, unifyTupleTy + ) where IMP_Ubiq() + -- friends: import TcMonad -import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe ) -import TyCon ( TyCon, mkFunTyCon ) +import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe, splitAppTys ) +import TyCon ( TyCon, mkFunTyCon, isTupleTyCon, tyConArity ) import Class ( GenClass ) import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind ) import TcType ( SYN_IE(TcType), TcMaybe(..), SYN_IE(TcTauType), SYN_IE(TcTyVar), newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType ) -- others: -import Kind ( Kind, hasMoreBoxityInfo, mkTypeKind ) +import Kind ( Kind, hasMoreBoxityInfo, mkTypeKind, mkBoxedTypeKind ) +import TysWiredIn ( listTyCon, mkListTy, mkTupleTy ) import Usage ( duffUsage ) import PprType ( GenTyVar, GenType ) -- instances import Pretty @@ -317,20 +321,62 @@ unifyFunTy ty@(TyVarTy tyvar) = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of BoundTo ty' -> unifyFunTy ty' + other -> unify_fun_ty_help ty - UnBound -> newTyVarTy mkTypeKind `thenNF_Tc` \ arg -> - newTyVarTy mkTypeKind `thenNF_Tc` \ res -> - tcWriteTyVar tyvar (mkFunTy arg res) `thenNF_Tc_` - returnTc (arg,res) +unifyFunTy ty + = case getFunTy_maybe ty of + Just arg_and_res -> returnTc arg_and_res + Nothing -> unify_fun_ty_help ty - DontBind -> failTc (expectedFunErr ty) +unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification + = newTyVarTy mkTypeKind `thenNF_Tc` \ arg -> + newTyVarTy mkTypeKind `thenNF_Tc` \ res -> + unifyTauTy (mkFunTy arg res) ty `thenTc_` + returnTc (arg,res) +\end{code} -unifyFunTy other_ty - = case getFunTy_maybe other_ty of - Just arg_and_res -> returnTc arg_and_res - Nothing -> failTc (expectedFunErr other_ty) +\begin{code} +unifyListTy :: TcType s -- expected list type + -> TcM s (TcType s) -- list element type + +unifyListTy ty@(TyVarTy tyvar) + = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + BoundTo ty' -> unifyListTy ty' + other -> unify_list_ty_help ty + +unifyListTy (AppTy (TyConTy tycon _) arg_ty) + | tycon == listTyCon + = returnTc arg_ty + +unifyListTy ty = unify_list_ty_help ty + +unify_list_ty_help ty -- Revert to ordinary unification + = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty -> + unifyTauTy (mkListTy elt_ty) ty `thenTc_` + returnTc elt_ty \end{code} +\begin{code} +unifyTupleTy :: Arity -> TcType s -> TcM s [TcType s] +unifyTupleTy arity ty@(TyVarTy tyvar) + = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + BoundTo ty' -> unifyTupleTy arity ty' + other -> unify_tuple_ty_help arity ty + +unifyTupleTy arity ty + = case splitAppTys ty of + (TyConTy tycon _, arg_tys) | isTupleTyCon tycon + && tyConArity tycon == arity + -> returnTc arg_tys + other -> unify_tuple_ty_help arity ty + +unify_tuple_ty_help arity ty + = mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..arity] `thenNF_Tc` \ arg_tys -> + unifyTauTy (mkTupleTy arity arg_tys) ty `thenTc_` + returnTc arg_tys +\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 41e2d25..051ad92 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -34,7 +34,7 @@ import {-# SOURCE #-} Id import Type ( GenType(..), maybeAppTyCon, Type(..), splitFunTy, splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys ) import TyVar ( GenTyVar(..), TyVar(..), cloneTyVar ) -import TyCon ( TyCon(..), NewOrData ) +import TyCon ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity ) import Class ( SYN_IE(Class), GenClass(..) ) import Kind ( Kind(..), isBoxedTypeKind, pprParendKind ) import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), cloneUVar ) @@ -199,15 +199,16 @@ ppr_ty env ctxt_prec (DictTy clas ty usage) -- Some help functions -ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys - | length arg_tys == 2 +ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys + | isFunTyCon tycon && length arg_tys == 2 = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) where (ty1:ty2:_) = arg_tys -ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ arity) usage) arg_tys - | not (codeStyle (pStyle env)) -- no magic in that case - && length arg_tys == arity -- no magic if partially applied +ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys + | isTupleTyCon tycon + && not (codeStyle (pStyle env)) -- no magic in that case + && length arg_tys == tyConArity tycon -- no magic if partially applied = parens arg_tys_w_commas where arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys)) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index ada7c8d..370faf5 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -1,4 +1,4 @@ -% + % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[TyCon]{The @TyCon@ datatype} @@ -7,12 +7,13 @@ #include "HsVersions.h" module TyCon( - TyCon(..), -- NB: some pals need to see representation + TyCon, SYN_IE(Arity), NewOrData(..), isFunTyCon, isPrimTyCon, isBoxedTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon, + isEnumerationTyCon, isTupleTyCon, mkDataTyCon, mkFunTyCon, @@ -30,11 +31,10 @@ module TyCon( tyConDerivings, tyConTheta, tyConPrimRep, - synTyConArity, + tyConArity, getSynTyConDefn, maybeTyConSingleCon, - isEnumerationTyCon, isTupleTyCon, derivedClasses ) where @@ -58,8 +58,9 @@ import {-# SOURCE #-} TysWiredIn ( tupleCon ) import BasicTypes ( SYN_IE(Arity), NewOrData(..) ) import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, SYN_IE(TyVar) ) import Usage ( GenUsage, SYN_IE(Usage) ) -import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind ) - +import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkUnboxedTypeKind, + mkArrowKind, resultKind, argKind + ) import Maybes import Name ( Name, nameUnique, mkWiredInTyConName, NamedThing(getName) ) import Unique ( Unique, funTyConKey, Uniquable(..) ) @@ -102,6 +103,7 @@ data TyCon Unique -- Always unboxed; hence never represented by a closure Name -- Often represented by a bit-pattern for the thing Kind -- itself (eg Int#), but sometimes by a pointer to + Arity PrimRep | SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#) @@ -134,13 +136,19 @@ mkSpecTyCon = SpecTyCon mkTupleTyCon = TupleTyCon mkDataTyCon name = DataTyCon (nameUnique name) name -mkPrimTyCon name = PrimTyCon (nameUnique name) name + +mkPrimTyCon name arity rep + = PrimTyCon (nameUnique name) name (mk_kind arity) arity rep + where + mk_kind 0 = mkUnboxedTypeKind + mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1) + mkSynTyCon name = SynTyCon (nameUnique name) name isFunTyCon FunTyCon = True isFunTyCon _ = False -isPrimTyCon (PrimTyCon _ _ _ _) = True +isPrimTyCon (PrimTyCon _ _ _ _ _) = True isPrimTyCon _ = False -- At present there are no unboxed non-primitive types, so @@ -172,6 +180,15 @@ isNewTyCon other = False isSynTyCon (SynTyCon _ _ _ _ _ _) = True isSynTyCon _ = False + +isEnumerationTyCon (TupleTyCon _ _ arity) + = arity == 0 +isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _) + = not (null data_cons) && all isNullaryDataCon data_cons + +isTupleTyCon (TupleTyCon _ _ arity) = arity >= 2 -- treat "0-tuple" specially +isTupleTyCon (SpecTyCon tc tys) = isTupleTyCon tc +isTupleTyCon other = False \end{code} \begin{code} @@ -182,7 +199,7 @@ kind2 = mkBoxedTypeKind `mkArrowKind` kind1 tyConKind :: TyCon -> Kind tyConKind FunTyCon = kind2 tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind -tyConKind (PrimTyCon _ _ kind _) = kind +tyConKind (PrimTyCon _ _ kind _ _) = kind tyConKind (SynTyCon _ _ k _ _ _) = k tyConKind (TupleTyCon _ _ n) @@ -207,13 +224,17 @@ tyConUnique :: TyCon -> Unique tyConUnique FunTyCon = funTyConKey tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq tyConUnique (TupleTyCon uniq _ _) = uniq -tyConUnique (PrimTyCon uniq _ _ _) = uniq +tyConUnique (PrimTyCon uniq _ _ _ _) = uniq tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon" -synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon -synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity -synTyConArity _ = Nothing +tyConArity :: TyCon -> Arity +tyConArity FunTyCon = 2 +tyConArity (DataTyCon _ _ _ tyvars _ _ _ _) = length tyvars +tyConArity (TupleTyCon _ _ arity) = arity +tyConArity (PrimTyCon _ _ _ arity _) = arity +tyConArity (SynTyCon _ _ _ arity _ _) = arity +tyConArity (SpecTyCon _ _ ) = panic "tyConArity:SpecTyCon" \end{code} \begin{code} @@ -223,7 +244,7 @@ tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs #ifdef DEBUG -tyConTyVars (PrimTyCon _ _ _ _) = panic "tyConTyVars:PrimTyCon" +tyConTyVars (PrimTyCon _ _ _ _ _) = panic "tyConTyVars:PrimTyCon" tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon" #endif \end{code} @@ -246,7 +267,7 @@ tyConFamilySize (TupleTyCon _ _ _) = 1 #endif tyConPrimRep :: TyCon -> PrimRep -tyConPrimRep (PrimTyCon _ _ _ rep) = rep +tyConPrimRep (PrimTyCon _ __ _ rep) = rep tyConPrimRep _ = PtrRep \end{code} @@ -274,21 +295,9 @@ maybeTyConSingleCon :: TyCon -> Maybe Id maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (tupleCon arity) maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing -maybeTyConSingleCon (PrimTyCon _ _ _ _) = Nothing +maybeTyConSingleCon (PrimTyCon _ _ _ _ _) = Nothing maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon" -- requires DataCons of TyCon - -isEnumerationTyCon (TupleTyCon _ _ arity) - = arity == 0 -isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _) - = not (null data_cons) && all isNullaryDataCon data_cons - - -isTupleTyCon (TupleTyCon _ _ arity) = arity >= 2 -- treat "0-tuple" specially -isTupleTyCon (SpecTyCon tc tys) = isTupleTyCon tc -isTupleTyCon other = False - - \end{code} @derivedFor@ reports if we have an {\em obviously}-derived instance @@ -331,18 +340,13 @@ instance Ord TyCon where _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } instance Uniquable TyCon where - uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u - uniqueOf (TupleTyCon u _ _) = u - uniqueOf (PrimTyCon u _ _ _) = u - uniqueOf (SynTyCon u _ _ _ _ _) = u - uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon" - uniqueOf tc = uniqueOf (getName tc) + uniqueOf tc = tyConUnique tc \end{code} \begin{code} instance NamedThing TyCon where getName (DataTyCon _ n _ _ _ _ _ _) = n - getName (PrimTyCon _ n _ _) = n + getName (PrimTyCon _ n _ _ _) = n getName (SpecTyCon tc _) = getName tc getName (SynTyCon _ n _ _ _ _) = n getName FunTyCon = mkFunTyConName