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')
| HsAppTy (HsType name)
(HsType name)
| HsAppTy (HsType name)
(HsType name)
- | HsFunTy (HsType name) -- function type
+ | HsFunTy (HsType name) -- function type
(HsType name)
| HsListTy (HsType name) -- Element type
(HsType name)
| HsListTy (HsType name) -- Element type
[HsType name] -- Element types (length gives arity)
| HsOpTy (HsType name) (HsTyOp name) (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
| HsNumTy Integer -- Generics only
-- these next two are only used in interfaces
where
pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
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)
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
checkDictTy ty [] `thenP` \ dict_ty ->
returnP (HsForAllTy tvs ctxt dict_ty)
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)
ty -> checkDictTy ty [] `thenP` \ dict_ty->
returnP (HsForAllTy Nothing [] dict_ty)
checkTyClHdr ty
= go ty []
where
checkTyClHdr ty
= go ty []
where
| not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs ->
returnP (tc, tvs)
| 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"
go (HsAppTy t1 t2) acc = go t1 (t2:acc)
go other acc = parseError "Malformed LHS to type of class declaration"
checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
= mapP checkPred ts
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 []
checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
| t == unitTyCon_RDR = returnP []
go (HsTyVar t) args | not (isRdrTyVar t)
= returnP (HsClassP t args)
go (HsAppTy l r) args = go l (r:args)
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)
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"
checkDictTy _ _ = parseError "Malformed context in instance header"
returnP (RecPatIn c fs)
-- Generics
HsType ty -> returnP (TypePatIn ty)
returnP (RecPatIn c fs)
-- Generics
HsType ty -> returnP (TypePatIn ty)
{- -*-haskell-*-
-----------------------------------------------------------------------------
{- -*-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 $
| tyvar { HsTyVar $1 }
| '(' type ',' comma_types1 ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2:$4) }
| '(#' comma_types1 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 }
| 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 }
| '(' ctype '::' kind ')' { HsKindSig $2 $4 }
-- Generics
| INTEGER { HsNumTy $1 }
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)
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)
extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
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)
extract_ty (HsNumTy num) acc = acc
extract_ty (HsKindSig ty k) acc = extract_ty ty acc
extract_ty (HsForAllTy (Just tvs) ctxt ty)
get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets`
case tycon of { HsTyOp n -> unitNameSet n ;
HsArrow -> emptyNameSet }
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
get (HsNumTy n) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsKindSig ty k) = get ty
lookupTyFixityRn op' `thenRn` \ fix ->
mkHsOpTyRn op' fix ty1' 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)
rnHsType doc (HsNumTy i)
| i == 1 = returnRn (HsNumTy i)
tcAddErrCtxt (appKindCtxt (ppr ty)) $
kcAppKind op_kind ty1_kind `thenTc` \ op_kind' ->
kcAppKind op_kind' ty2_kind
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
kcHsType (HsNumTy _) -- The unit type for generics
= returnTc liftedTypeKind
tc_type ty2 `thenTc` \ tau_ty2 ->
tc_fun_type op [tau_ty1,tau_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 [])
tc_type (HsNumTy n)
= ASSERT(n== 1)
returnTc (mkTyConApp genUnitTyCon [])
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
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. [I don't think that this is the case anymore after SPJ's latest
+changes in that regard. Delete this comment? -=chak/7Jun2]