From: simonpj Date: Mon, 5 Apr 2004 10:52:25 +0000 (+0000) Subject: [project @ 2004-04-05 10:52:23 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1910 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=25ef3ade4257614cd966e29d0ed595c9db5587a7;p=ghc-hetmet.git [project @ 2004-04-05 10:52:23 by simonpj] Remove the entirely-redundant location from the argument of constructor HsPredTy, so that we have HsPredTy HsType rather than HsPredTy LHsType --- diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index da87898..432e007 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -296,8 +296,8 @@ repDerivs (Just ctxt) where rep_deriv :: LHsType Name -> DsM (Core TH.Name) -- Deriving clauses must have the simple H98 form - rep_deriv (L _ (HsPredTy (L _ (HsClassP cls [])))) = lookupOcc cls - rep_deriv other = panic "rep_deriv" + rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls + rep_deriv other = panic "rep_deriv" ------------------------------------------------------- @@ -421,7 +421,7 @@ repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) repTy (HsParTy t) = repLTy t repTy (HsNumTy i) = panic "DsMeta.repTy: Can't represent number types (for generics)" -repTy (HsPredTy pred) = repLPred pred +repTy (HsPredTy pred) = repPred pred repTy (HsKindSig ty kind) = panic "DsMeta.repTy: Can't represent explicit kind signatures yet" diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 03abd3c..480c64e 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -62,7 +62,7 @@ mk_con con = L loc0 $ case con of = (noLoc (vName i), noLoc $ BangType HsNoBang (cvtType ty)) mk_derivs [] = Nothing -mk_derivs cs = Just [noLoc $ HsPredTy $ noLoc $ HsClassP (tconName c) [] | c <- cs] +mk_derivs cs = Just [noLoc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs] cvt_ltop :: TH.Dec -> Either (LHsDecl RdrName) Message cvt_ltop d = case cvt_top d of @@ -305,12 +305,12 @@ cvt_tvs :: [TH.Name] -> [LHsTyVarBndr RdrName] cvt_tvs tvs = map (noLoc . UserTyVar . tName) tvs cvt_context :: Cxt -> LHsContext RdrName -cvt_context tys = noLoc (map cvt_pred tys) +cvt_context tys = noLoc (map (noLoc . cvt_pred) tys) -cvt_pred :: TH.Type -> LHsPred RdrName +cvt_pred :: TH.Type -> HsPred RdrName cvt_pred ty = case split_ty_app ty of - (ConT tc, tys) -> noLoc (HsClassP (tconName tc) (map cvtType tys)) - (VarT tv, tys) -> noLoc (HsClassP (tName tv) (map cvtType tys)) + (ConT tc, tys) -> HsClassP (tconName tc) (map cvtType tys) + (VarT tv, tys) -> HsClassP (tName tv) (map cvtType tys) other -> cvtPanic "Malformed predicate" (text (TH.pprint ty)) convertToHsType = cvtType diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 9325d27..fdcc3e2 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -128,10 +128,12 @@ data HsType name | HsNumTy Integer -- Generics only - | HsPredTy (LHsPred name) -- Only used in the type of an instance + | HsPredTy (HsPred name) -- Only used in the type of an instance -- declaration, eg. Eq [a] -> Eq a -- ^^^^ -- HsPredTy + -- Note no need for location info on the + -- enclosed HsPred; the one on the type will do | HsKindSig (LHsType name) -- (ty :: kind) Kind -- A type with a kind signature @@ -233,10 +235,10 @@ splitHsInstDeclTy inst_ty (cxt2, cls, tys) = split_tau inst_ty where - split_tau (HsFunTy (L _ (HsPredTy p)) ty) = (p:ps, cls, tys) + split_tau (HsFunTy (L loc (HsPredTy p)) ty) = (L loc p : ps, cls, tys) where (ps, cls, tys) = split_tau (unLoc ty) - split_tau (HsPredTy (L _ (HsClassP cls tys))) = ([], cls, tys) + split_tau (HsPredTy (HsClassP cls tys)) = ([], cls, tys) split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty) \end{code} diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 8b5953c..b011c39 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -113,7 +113,7 @@ extract_ty (HsListTy ty) acc = extract_lty ty acc extract_ty (HsPArrTy ty) acc = extract_lty ty acc extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) -extract_ty (HsPredTy p) acc = extract_pred (unLoc p) acc +extract_ty (HsPredTy p) acc = extract_pred p acc extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc) extract_ty (HsParTy ty) acc = extract_lty ty acc extract_ty (HsNumTy num) acc = acc @@ -319,7 +319,7 @@ hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t] hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts) hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2]) hsIfaceType (HsParTy t) = hsIfaceLType t -hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p) +hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) hsIfaceType (HsKindSig t _) = hsIfaceLType t hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy" @@ -620,7 +620,7 @@ checkPred :: LHsType RdrName -> P (LHsPred RdrName) -- Watch out.. in ...deriving( Show )... we use checkPred on -- the list of partially applied predicates in the deriving, -- so there can be zero args. -checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) ) +checkPred (L spn (HsPredTy (HsIParam n ty))) = return (L spn (HsIParam n ty)) checkPred (L spn ty) = check spn ty [] @@ -637,7 +637,7 @@ checkDictTy :: LHsType RdrName -> P (LHsType RdrName) checkDictTy (L spn ty) = check ty [] where check (HsTyVar t) args | not (isRdrTyVar t) - = return (L spn (HsPredTy (L spn (HsClassP t args)))) + = return (L spn (HsPredTy (HsClassP t args))) check (HsAppTy l r) args = check (unLoc l) (r:args) check (HsParTy t) args = check (unLoc t) args check _ _ = parseError spn "Malformed context in instance header" diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 5d31672..bc2fa4d 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -51,7 +51,7 @@ extractHsTyNames ty get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty get (HsTupleTy con tys) = extractHsTyNames_s tys get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsPredTy p) = extractHsPredTyNames (unLoc p) + get (HsPredTy p) = extractHsPredTyNames p get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) get (HsParTy ty) = getl ty get (HsNumTy n) = emptyNameSet diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 82c1a5d..a793284 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -161,7 +161,7 @@ rnHsType doc (HsAppTy ty1 ty2) returnM (HsAppTy ty1' ty2') rnHsType doc (HsPredTy pred) - = rnLPred doc pred `thenM` \ pred' -> + = rnPred doc pred `thenM` \ pred' -> returnM (HsPredTy pred') rnLHsTypes doc tys = mappM (rnLHsType doc) tys diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 59b1d38..519d29f 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -154,12 +154,11 @@ tcHsSigType ctxt hs_ty ; ty <- tcHsKindedType kinded_ty ; checkValidType ctxt ty ; returnM ty } - -- Used for the deriving(...) items tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type]) tcHsDeriv = addLocM (tc_hs_deriv []) -tc_hs_deriv tv_names (HsPredTy (L _ (HsClassP cls_name hs_tys))) +tc_hs_deriv tv_names (HsPredTy (HsClassP cls_name hs_tys)) = kcHsTyVars tv_names $ \ tv_names' -> do { cls_kind <- kcClass cls_name ; (tys, res_kind) <- kcApps cls_kind (ppr cls_name) hs_tys @@ -201,7 +200,7 @@ tcHsKindedType hs_ty tcHsKindedContext :: LHsContext Name -> TcM ThetaType -- Used when we are expecting a ClassContext (i.e. no implicit params) -- Does not do validity checking, like tcHsKindedType -tcHsKindedContext hs_theta = addLocM (mappM dsHsPred) hs_theta +tcHsKindedContext hs_theta = addLocM (mappM dsHsLPred) hs_theta \end{code} @@ -352,13 +351,16 @@ kcApps fun_kind ppr_fun args --------------------------- kcHsContext :: LHsContext Name -> TcM (LHsContext Name) -kcHsContext ctxt = wrapLocM (mappM kcHsPred) ctxt +kcHsContext ctxt = wrapLocM (mappM kcHsLPred) ctxt + +kcHsLPred :: LHsPred Name -> TcM (LHsPred Name) +kcHsLPred = wrapLocM kcHsPred -kcHsPred (L span pred) -- Checks that the result is of kind liftedType - = addSrcSpan span $ - kc_pred pred `thenM` \ (pred', kind) -> +kcHsPred :: HsPred Name -> TcM (HsPred Name) +kcHsPred pred -- Checks that the result is of kind liftedType + = kc_pred pred `thenM` \ (pred', kind) -> checkExpectedKind pred kind liftedTypeKind `thenM_` - returnM (L span pred') + returnM pred' --------------------------- kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind) @@ -458,7 +460,7 @@ ds_type (HsPredTy pred) ds_type full_ty@(HsForAllTy exp tv_names ctxt ty) = tcTyVarBndrs tv_names $ \ tyvars -> - mappM dsHsPred (unLoc ctxt) `thenM` \ theta -> + mappM dsHsLPred (unLoc ctxt) `thenM` \ theta -> dsHsType ty `thenM` \ tau -> returnM (mkSigmaTy tyvars theta tau) @@ -495,15 +497,15 @@ ds_var_app name arg_tys Contexts ~~~~~~~~ \begin{code} -dsHsPred :: LHsPred Name -> TcM PredType -dsHsPred pred = ds_pred (unLoc pred) +dsHsLPred :: LHsPred Name -> TcM PredType +dsHsLPred pred = dsHsPred (unLoc pred) -ds_pred pred@(HsClassP class_name tys) +dsHsPred pred@(HsClassP class_name tys) = dsHsTypes tys `thenM` \ arg_tys -> tcLookupClass class_name `thenM` \ clas -> returnM (ClassP clas arg_tys) -ds_pred (HsIParam name ty) +dsHsPred (HsIParam name ty) = dsHsType ty `thenM` \ arg_ty -> returnM (IParam name arg_ty) \end{code}