From 2fa402ddd9be4577e6824c66add1bf900e4fa3b5 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 7 Dec 2000 08:26:48 +0000 Subject: [PATCH] [project @ 2000-12-07 08:26:47 by simonpj] Better handling of HsTupCon (tidy up + fix minor versioning bug) --- ghc/compiler/hsSyn/HsCore.lhs | 9 ++++-- ghc/compiler/hsSyn/HsTypes.lhs | 14 +++++---- ghc/compiler/rename/RnHsSyn.lhs | 5 ++-- ghc/compiler/rename/RnSource.lhs | 52 +++++++++++++-------------------- ghc/compiler/typecheck/TcIfaceSig.lhs | 32 +++++++++++++------- ghc/compiler/typecheck/TcMonoType.lhs | 19 +++++++----- 6 files changed, 69 insertions(+), 62 deletions(-) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 63583b7..424401f 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -45,7 +45,7 @@ import PrimOp ( PrimOp(CCallOp) ) import Demand ( StrictnessInfo ) import Literal ( Literal, maybeLitLit ) import PrimOp ( CCall, pprCCallOp ) -import DataCon ( dataConTyCon ) +import DataCon ( dataConTyCon, dataConSourceArity ) import TyCon ( isTupleTyCon, tupleTyConBoxity ) import Type ( Kind ) import FiniteMap ( lookupFM ) @@ -134,7 +134,7 @@ toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs] toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r) --------------------- -toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc)) +toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc) | otherwise = UfDataAlt (getName dc) where tc = dataConTyCon dc @@ -145,6 +145,9 @@ toUfCon (LitAlt l) = case maybeLitLit l of toUfCon DEFAULT = UfDefault --------------------- +mk_hs_tup_con tc dc = HsTupCon (getName dc) (tupleTyConBoxity tc) (dataConSourceArity dc) + +--------------------- toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x)) | otherwise = UfTyBinder (getName x) (varType x) @@ -154,7 +157,7 @@ toUfApp (Var v) as = case isDataConId_maybe v of -- We convert the *worker* for tuples into UfTuples Just dc | isTupleTyCon tc && saturated - -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args + -> UfTuple (mk_hs_tup_con tc dc) tup_args where val_args = dropWhile isTypeArg as saturated = length val_args == idArity v diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index c9bb0a3..0ea040c 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -38,7 +38,7 @@ import OccName ( NameSpace, tvName ) import Var ( TyVar, tyVarKind ) import Subst ( mkTyVarSubst, substTy ) import PprType ( {- instance Outputable Kind -}, pprParendKind ) -import BasicTypes ( Boxity(..), tupleParens ) +import BasicTypes ( Boxity(..), Arity, tupleParens ) import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey, usOnceTyConName, usManyTyConName ) @@ -92,16 +92,18 @@ hsUsOnce_Name = HsTyVar usOnceTyConName hsUsMany_Name = HsTyVar usManyTyConName ----------------------- -data HsTupCon name = HsTupCon name Boxity +data HsTupCon name = HsTupCon name Boxity Arity instance Eq name => Eq (HsTupCon name) where - (HsTupCon _ b1) == (HsTupCon _ b2) = b1==b2 + (HsTupCon _ b1 a1) == (HsTupCon _ b2 a2) = b1==b2 && a1==a2 mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName -mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity (length args)) boxity +mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity arity) boxity arity + where + arity = length args hsTupParens :: HsTupCon name -> SDoc -> SDoc -hsTupParens (HsTupCon _ b) p = tupleParens b p +hsTupParens (HsTupCon _ b _) p = tupleParens b p ----------------------- -- Combine adjacent for-alls. @@ -304,7 +306,7 @@ toHsType (PredTy p) = HsPredTy (toHsPred p) toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * | not saturated = generic_case - | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc)) tys' + | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys' | tc `hasKey` listTyConKey = HsListTy (head tys') | tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified | tc `hasKey` usManyTyConKey = hsUsMany_Name -- must print !, . unqualified diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index bc471d3..50f448d 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -77,8 +77,7 @@ extractHsTyNames ty where get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty - get (HsTupleTy (HsTupCon n _) tys) = unitNameSet n - `unionNameSets` extractHsTyNames_s tys + get (HsTupleTy con tys) = hsTupConFVs con `unionNameSets` extractHsTyNames_s tys get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsPredTy p) = extractHsPredTyNames p get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` @@ -205,7 +204,7 @@ ufConFVs other = emptyFVs ufNoteFVs (UfCoerce ty) = extractHsTyNames ty ufNoteFVs note = emptyFVs -hsTupConFVs (HsTupCon n _) = unitFV n +hsTupConFVs (HsTupCon n _ _) = unitFV n \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 11846d6..a68f5d1 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -14,7 +14,7 @@ import RnExpr import HsSyn import HscTypes ( GlobalRdrEnv ) import HsTypes ( hsTyVarNames, pprHsContext ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv ) +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemRdrEnv ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars @@ -34,12 +34,14 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName, import RnMonad import Class ( FunDep, DefMeth (..) ) +import DataCon ( dataConId ) import Name ( Name, OccName, nameOccName, NamedThing(..) ) import NameSet import PrelInfo ( derivableClassKeys, cCallishClassKeys ) import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR, bindIO_RDR, returnIO_RDR ) +import TysWiredIn ( tupleCon ) import List ( partition, nub ) import Outputable import SrcLoc ( SrcLoc ) @@ -612,13 +614,13 @@ rnHsType doc (HsListTy ty) -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys) +rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys) -- Don't do lookupOccRn, because this is built-in syntax -- so it doesn't need to be in scope = mapRn (rnHsType doc) tys `thenRn` \ tys' -> - returnRn (HsTupleTy (HsTupCon n' boxity) tys') + returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys') where - n' = tupleTyCon_name boxity (length tys) + tup_name = tupleTyCon_name boxity arity rnHsType doc (HsAppTy ty1 ty2) @@ -634,20 +636,6 @@ rnHsTypes doc tys = mapRn (rnHsType doc) tys \end{code} \begin{code} --- We use lookupOcc here because this is interface file only stuff --- and we need the workers... -rnHsTupCon (HsTupCon n boxity) - = lookupOccRn n `thenRn` \ n' -> - returnRn (HsTupCon n' boxity) - -rnHsTupConWkr (HsTupCon n boxity) - -- Tuple construtors are for the *worker* of the tuple - -- Going direct saves needless messing about - = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' -> - returnRn (HsTupCon n' boxity) -\end{code} - -\begin{code} rnForAll doc forall_tyvars ctxt ty = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> rnContext doc ctxt `thenRn` \ new_ctxt -> @@ -749,10 +737,12 @@ rnCoreExpr (UfCCall cc ty) = rnHsType (text "ccall") ty `thenRn` \ ty' -> returnRn (UfCCall cc ty') -rnCoreExpr (UfTuple con args) - = rnHsTupConWkr con `thenRn` \ con' -> - mapRn rnCoreExpr args `thenRn` \ args' -> - returnRn (UfTuple con' args') +rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args) + = mapRn rnCoreExpr args `thenRn` \ args' -> + returnRn (UfTuple (HsTupCon tup_name boxity arity) args') + where + tup_name = getName (dataConId (tupleCon boxity arity)) + -- Get the *worker* name and use that rnCoreExpr (UfApp fun arg) = rnCoreExpr fun `thenRn` \ fun' -> @@ -810,7 +800,7 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> \begin{code} rnCoreAlt (con, bndrs, rhs) - = rnUfCon con bndrs `thenRn` \ con' -> + = rnUfCon con `thenRn` \ con' -> bindCoreLocalsRn bndrs $ \ bndrs' -> rnCoreExpr rhs `thenRn` \ rhs' -> returnRn (con', bndrs', rhs') @@ -824,22 +814,22 @@ rnNote UfInlineCall = returnRn UfInlineCall rnNote UfInlineMe = returnRn UfInlineMe -rnUfCon UfDefault _ +rnUfCon UfDefault = returnRn UfDefault -rnUfCon (UfTupleAlt tup_con) bndrs - = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _) -> - returnRn (UfDataAlt con') - -- Makes the type checker a little easier +rnUfCon (UfTupleAlt (HsTupCon _ boxity arity)) + = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity)) + where + tup_name = getName (tupleCon boxity arity) -rnUfCon (UfDataAlt con) _ +rnUfCon (UfDataAlt con) = lookupOccRn con `thenRn` \ con' -> returnRn (UfDataAlt con') -rnUfCon (UfLitAlt lit) _ +rnUfCon (UfLitAlt lit) = returnRn (UfLitAlt lit) -rnUfCon (UfLitLitAlt lit ty) _ +rnUfCon (UfLitLitAlt lit ty) = rnHsType (text "litlit") ty `thenRn` \ ty' -> returnRn (UfLitLitAlt lit ty') \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index cb9a4cf..a606b16 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -32,8 +32,9 @@ import WorkWrap ( mkWrapper ) import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe ) import MkId ( mkCCallOpId ) import IdInfo -import DataCon ( dataConSig, dataConArgTys ) +import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys ) import Type ( mkTyVarTys, splitAlgTyConApp_maybe ) +import TysWiredIn ( tupleCon ) import Var ( mkTyVar, tyVarKind ) import Name ( Name ) import Demand ( wwLazy ) @@ -205,14 +206,16 @@ tcCoreExpr (UfCCall cc ty) tcGetUnique `thenNF_Tc` \ u -> returnTc (Var (mkCCallOpId u cc ty')) -tcCoreExpr (UfTuple (HsTupCon name _) args) - = tcVar name `thenTc` \ con_id -> - mapTc tcCoreExpr args `thenTc` \ args' -> +tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args) + = mapTc tcCoreExpr args `thenTc` \ args' -> let -- Put the missing type arguments back in con_args = map (Type . exprType) args' ++ args' in returnTc (mkApps (Var con_id) con_args) + where + con_id = dataConId (tupleCon boxity arity) + tcCoreExpr (UfLam bndr body) = tcCoreLamBndr bndr $ \ bndr' -> @@ -320,13 +323,9 @@ tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs) -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs) - = tcVar con_name `thenTc` \ con_id -> +tcCoreAlt scrut_ty alt@(con, names, rhs) + = tcConAlt con `thenTc` \ con -> let - con = case isDataConWrapId_maybe con_id of - Just con -> con - Nothing -> pprPanic "tcCoreAlt" (ppr con_id) - (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of @@ -339,7 +338,7 @@ tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs) arg_ids #ifdef DEBUG | length id_names /= length arg_tys - = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$ + = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$ (ppr main_tyvars <+> ppr ex_tyvars) $$ ppr arg_tys) | otherwise @@ -351,6 +350,17 @@ tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs) tcExtendGlobalValEnv arg_ids $ tcCoreExpr rhs `thenTc` \ rhs' -> returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs') + + +tcConAlt :: UfConAlt Name -> TcM DataCon +tcConAlt (UfTupleAlt (HsTupCon _ boxity arity)) + = returnTc (tupleCon boxity arity) + +tcConAlt (UfDataAlt con_name) + = tcVar con_name `thenTc` \ con_id -> + returnTc (case isDataConWrapId_maybe con_id of + Just con -> con + Nothing -> pprPanic "tcCoreAlt" (ppr con_id)) \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 2176456..e8b2335 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -35,9 +35,9 @@ import TcType ( TcKind, TcTyVar, TcThetaType, TcTauType, ) import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr, instFunDeps, instFunDepsOfTheta ) -import FunDeps ( tyVarFunDep, oclose ) +import FunDeps ( oclose ) import TcUnify ( unifyKind, unifyOpenTypeKind ) -import Type ( Type, Kind, PredType(..), ThetaType, +import Type ( Type, Kind, PredType(..), ThetaType, SigmaType, TauType, mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, zipFunTys, hoistForAllTys, mkSigmaTy, mkPredTy, mkTyConApp, @@ -190,7 +190,7 @@ kcHsType (HsListTy ty) = kcBoxedType ty `thenTc` \ tau_ty -> returnTc boxedTypeKind -kcHsType (HsTupleTy (HsTupCon _ boxity) tys) +kcHsType (HsTupleTy (HsTupCon _ boxity _) tys) = mapTc kcTypeType tys `thenTc_` returnTc (case boxity of Boxed -> boxedTypeKind @@ -345,9 +345,10 @@ tc_type wimp_out (HsListTy ty) = tc_arg_type wimp_out ty `thenTc` \ tau_ty -> returnTc (mkListTy tau_ty) -tc_type wimp_out (HsTupleTy (HsTupCon _ boxity) tys) - = mapTc tc_tup_arg tys `thenTc` \ tau_tys -> - returnTc (mkTupleTy boxity (length tys) tau_tys) +tc_type wimp_out (HsTupleTy (HsTupCon _ boxity arity) tys) + = ASSERT( arity == length tys ) + mapTc tc_tup_arg tys `thenTc` \ tau_tys -> + returnTc (mkTupleTy boxity arity tau_tys) where tc_tup_arg = case boxity of Boxed -> tc_arg_type wimp_out @@ -547,6 +548,9 @@ and then we don't need to check for ambiguity either, because the test can't fail (see is_ambig). \begin{code} +checkAmbiguity :: RecFlag -> Bool + -> [TyVar] -> ThetaType -> TauType + -> TcM SigmaType checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau | isRec wimp_out = returnTc sigma_ty | otherwise = mapTc_ check_pred theta `thenTc_` @@ -555,8 +559,7 @@ checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau sigma_ty = mkSigmaTy forall_tyvars theta tau tau_vars = tyVarsOfType tau fds = instFunDepsOfTheta theta - tvFundep = tyVarFunDep fds - extended_tau_vars = oclose tvFundep tau_vars + extended_tau_vars = oclose fds tau_vars is_ambig ct_var = (ct_var `elem` forall_tyvars) && not (ct_var `elemUFM` extended_tau_vars) -- 1.7.10.4