From 2205f0ceeb65d8acb7db953bf4fd2ad673dc55ee Mon Sep 17 00:00:00 2001 From: chak Date: Fri, 7 Jun 2002 07:16:06 +0000 Subject: [PATCH] [project @ 2002-06-07 07:16:04 by chak] Fixed handling of infix operators in types: - Pretty printing didn't take nested infix operators into account - Explicit parenthesis were ignored in the fixity parser: * I added a constructor `HsParTy' to `HsType' (in the spirit of `HsPar' in `HsExpr'), which tracks the use of explicit parenthesis * Occurences of `HsParTy' in type-ish things that are not quite types (like context predicates) are removed in `ParseUtils'; all other occurences of `HsParTy' are removed during type checking (just as it works with `HsPar') --- ghc/compiler/hsSyn/HsTypes.lhs | 25 ++++++++++++++++++------- ghc/compiler/parser/ParseUtil.lhs | 17 +++++++++++++---- ghc/compiler/parser/Parser.y | 8 ++++---- ghc/compiler/parser/RdrHsSyn.lhs | 3 ++- ghc/compiler/rename/RnHsSyn.lhs | 1 + ghc/compiler/rename/RnTypes.lhs | 3 +++ ghc/compiler/typecheck/TcMonoType.lhs | 6 ++++++ ghc/compiler/types/Generics.lhs | 3 ++- 8 files changed, 49 insertions(+), 17 deletions(-) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 1706134..bfacdcd 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -109,7 +109,7 @@ data HsType name | HsAppTy (HsType name) (HsType name) - | HsFunTy (HsType name) -- function type + | HsFunTy (HsType name) -- function type (HsType name) | HsListTy (HsType name) -- Element type @@ -120,6 +120,11 @@ data HsType name [HsType name] -- Element types (length gives arity) | HsOpTy (HsType name) (HsTyOp name) (HsType name) + + | HsParTy (HsType name) -- Parenthesis preserved for the + -- precedence parser; are removed by + -- the type checker + | HsNumTy Integer -- Generics only -- these next two are only used in interfaces @@ -310,16 +315,22 @@ ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty) where pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) - = maybeParen (ctxt_prec >= pREC_CON) - (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty]) +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = + maybeParen (ctxt_prec >= pREC_CON) + (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty]) ppr_mono_ty ctxt_prec (HsPredTy pred) = braces (ppr pred) --- Generics -ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2 +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = + maybeParen (ctxt_prec >= pREC_FUN) + (ppr_mono_ty pREC_FUN ty1 <+> ppr op <+> ppr_mono_ty pREC_FUN ty2) + +ppr_mono_ty ctxt_prec (HsParTy ty) = ppr_mono_ty ctxt_prec ty + -- `HsParTy' isn't useful for pretty printing, as it is removed by the type + -- checker and we need to be able to pretty print after type checking + +ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only \end{code} diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index f882c89..3bec98e 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -108,6 +108,8 @@ checkInstType t checkDictTy ty [] `thenP` \ dict_ty -> returnP (HsForAllTy tvs ctxt dict_ty) + HsParTy ty -> checkInstType ty + ty -> checkDictTy ty [] `thenP` \ dict_ty-> returnP (HsForAllTy Nothing [] dict_ty) @@ -127,11 +129,13 @@ checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar]) checkTyClHdr ty = go ty [] where - go (HsTyVar tc) acc + go (HsTyVar tc) acc | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs -> returnP (tc, tvs) - go (HsOpTy t1 (HsTyOp tc) t2) acc = checkTyVars (t1:t2:acc) `thenP` \ tvs -> - returnP (tc, tvs) + go (HsOpTy t1 (HsTyOp tc) t2) acc + = checkTyVars (t1:t2:acc) `thenP` \ tvs -> + returnP (tc, tvs) + go (HsParTy ty) acc = go ty acc go (HsAppTy t1 t2) acc = go t1 (t2:acc) go other acc = parseError "Malformed LHS to type of class declaration" @@ -139,6 +143,9 @@ checkContext :: RdrNameHsType -> P RdrNameContext checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type = mapP checkPred ts +checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way + = checkContext ty + checkContext (HsTyVar t) -- Empty context shows up as a unit type () | t == unitTyCon_RDR = returnP [] @@ -157,12 +164,14 @@ checkPred ty go (HsTyVar t) args | not (isRdrTyVar t) = returnP (HsClassP t args) go (HsAppTy l r) args = go l (r:args) + go (HsParTy t) args = go t args go _ _ = parseError "Illegal class assertion" checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) = returnP (mkHsDictTy t args) checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) +checkDictTy (HsParTy t) args = checkDictTy t args checkDictTy _ _ = parseError "Malformed context in instance header" @@ -246,7 +255,7 @@ checkPat e [] = case e of returnP (RecPatIn c fs) -- Generics HsType ty -> returnP (TypePatIn ty) - _ -> patFail + _ -> patFail checkPat _ _ = patFail diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index c98b2dd..ea8f6f5 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.99 2002/06/05 14:39:28 simonpj Exp $ +$Id: Parser.y,v 1.100 2002/06/07 07:16:05 chak Exp $ Haskell grammar. @@ -805,9 +805,9 @@ atype :: { RdrNameHsType } | tyvar { HsTyVar $1 } | '(' type ',' comma_types1 ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2:$4) } | '(#' comma_types1 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } - | '[' type ']' { HsListTy $2 } - | '[:' type ':]' { HsPArrTy $2 } - | '(' ctype ')' { $2 } + | '[' type ']' { HsListTy $2 } + | '[:' type ':]' { HsPArrTy $2 } + | '(' ctype ')' { HsParTy $2 } | '(' ctype '::' kind ')' { HsKindSig $2 $4 } -- Generics | INTEGER { HsNumTy $1 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 374a441..2f16a89 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -149,8 +149,9 @@ extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsPredTy p) acc = extract_pred p acc extract_ty (HsTyVar tv) acc = tv : acc extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc) --- Generics extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsParTy ty) acc = extract_ty ty acc +-- Generics extract_ty (HsNumTy num) acc = acc extract_ty (HsKindSig ty k) acc = extract_ty ty acc extract_ty (HsForAllTy (Just tvs) ctxt ty) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index a65430a..6b6d949 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -84,6 +84,7 @@ extractHsTyNames ty get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` case tycon of { HsTyOp n -> unitNameSet n ; HsArrow -> emptyNameSet } + get (HsParTy ty) = get ty get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv get (HsKindSig ty k) = get ty diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 74fc881..35ab81b 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -110,6 +110,9 @@ rnHsType doc (HsOpTy ty1 op ty2) lookupTyFixityRn op' `thenRn` \ fix -> mkHsOpTyRn op' fix ty1' ty2' +rnHsType doc (HsParTy ty) + = rnHsType doc ty `thenRn` \ ty' -> + returnRn (HsParTy ty') rnHsType doc (HsNumTy i) | i == 1 = returnRn (HsNumTy i) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index cd1ba2b..cf12315 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -299,6 +299,9 @@ kcHsType ty@(HsOpTy ty1 (HsTyOp op) ty2) tcAddErrCtxt (appKindCtxt (ppr ty)) $ kcAppKind op_kind ty1_kind `thenTc` \ op_kind' -> kcAppKind op_kind' ty2_kind + +kcHsType (HsParTy ty) -- Skip parentheses markers + = kcHsType ty kcHsType (HsNumTy _) -- The unit type for generics = returnTc liftedTypeKind @@ -441,6 +444,9 @@ tc_type (HsOpTy ty1 (HsTyOp op) ty2) tc_type ty2 `thenTc` \ tau_ty2 -> tc_fun_type op [tau_ty1,tau_ty2] +tc_type (HsParTy ty) -- Remove the parentheses markers + = tc_type ty + tc_type (HsNumTy n) = ASSERT(n== 1) returnTc (mkTyConApp genUnitTyCon []) diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index b868c2a..cc61161 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -82,7 +82,8 @@ patterns (not Unit, this is done differently) is done in mk_inst_info HsOpTy is tied to Generic definitions which is not a very good design feature, indeed a bug. However, the check is easy to move from tcHsType back to mk_inst_info and everything will be fine. Also see -bug #5. +bug #5. [I don't think that this is the case anymore after SPJ's latest +changes in that regard. Delete this comment? -=chak/7Jun2] Generics.lhs -- 1.7.10.4