[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')

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 1706134..bfacdcd 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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