[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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}