Commit 25ef3ade authored by simonpj's avatar simonpj

[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
parent c7c01b0d
......@@ -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"
......
......@@ -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
......
......@@ -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}
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment