Commit 3b23f680 authored by Alan Zimmerman's avatar Alan Zimmerman

Remove HsContext from ppr_mono_ty, and remove ppParendHsType

This is a cleanup after Trac #13238, as the context was no longer being used.
parent 09d5c993
......@@ -1210,7 +1210,11 @@ cvtTypeKind ty_str ty
-> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
tys'
ArrowT
| [x',y'] <- tys' -> returnL (HsFunTy x' y')
| [x',y'] <- tys' -> do
case x' of
(L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x')
; returnL (HsFunTy x'' y') }
_ -> returnL (HsFunTy x' y')
| otherwise ->
mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
tys'
......
......@@ -1244,7 +1244,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con
where
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
: map (pprParendHsType . unLoc) tys)
: map (pprHsType . unLoc) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
tvs = case mtvs of
......@@ -1495,10 +1495,10 @@ pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context
where
pp_pats (patl:patsr)
| fixity == Infix
= hsep [pprParendHsType (unLoc patl), pprInfixOcc (unLoc thing)
, hsep (map (pprParendHsType.unLoc) patsr)]
= hsep [pprHsType (unLoc patl), pprInfixOcc (unLoc thing)
, hsep (map (pprHsType.unLoc) patsr)]
| otherwise = hsep [ pprPrefixOcc (unLoc thing)
, hsep (map (pprParendHsType.unLoc) (patl:patsr))]
, hsep (map (pprHsType.unLoc) (patl:patsr))]
pp_pats [] = empty
instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where
......
......@@ -1057,7 +1057,7 @@ ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
where
pp (Left arg) = ppr arg
pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
= char '@' <> pprParendHsType arg
= char '@' <> pprHsType arg
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
......
......@@ -64,7 +64,7 @@ module HsTypes (
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
-- Printing
pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
) where
......@@ -615,7 +615,7 @@ data HsAppType name
deriving instance (DataId name) => Data (HsAppType name)
instance (OutputableBndrId name) => Outputable (HsAppType name) where
ppr = ppr_app_ty TopPrec
ppr = ppr_app_ty
{-
Note [HsForAllTy tyvar binders]
......@@ -1207,13 +1207,13 @@ pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
-- For use in a HsQualTy, which always gets printed if it exists.
pprHsContextAlways :: (OutputableBndrId name) => HsContext name -> SDoc
pprHsContextAlways [] = parens empty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty FunPrec ty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
......@@ -1252,96 +1252,90 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
pprHsType, pprParendHsType :: (OutputableBndrId name) => HsType name -> SDoc
pprHsType :: (OutputableBndrId name) => HsType name -> SDoc
pprHsType ty = ppr_mono_ty ty
pprHsType ty = ppr_mono_ty TopPrec ty
pprParendHsType ty = ppr_mono_ty TyConPrec ty
ppr_mono_lty :: (OutputableBndrId name) => LHsType name -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_lty :: (OutputableBndrId name) => TyPrec -> LHsType name -> SDoc
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: (OutputableBndrId name) => HsType name -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
ppr_mono_ty :: (OutputableBndrId name) => TyPrec -> HsType name -> SDoc
ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= maybeParen ctxt_prec FunPrec $
sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty]
ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
ppr_mono_ty _ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
= sep [pprHsContextAlways ctxt, ppr_mono_lty TopPrec ty]
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name
ppr_mono_ty _ (HsTyVar Promoted (L _ name))
ppr_mono_ty (HsBangTy b ty) = ppr b <> ppr_mono_lty ty
ppr_mono_ty (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name
ppr_mono_ty (HsTyVar Promoted (L _ name))
= space <> quote (pprPrefixOcc name)
-- We need a space before the ' above, so the parser
-- does not attach it to the previous symbol
ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2
ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
ppr_mono_ty (HsFunTy ty1 ty2) = ppr_fun_ty ty1 ty2
ppr_mono_ty (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
where std_con = case con of
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
ppr_mono_ty _ (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys)
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind)
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty TopPrec ty)
ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty)
ppr_mono_ty _ (HsSpliceTy s _) = pprSplice s
ppr_mono_ty prec (HsCoreTy ty) = pprPrecType prec ty
ppr_mono_ty _ (HsExplicitListTy Promoted _ tys)
ppr_mono_ty (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys)
ppr_mono_ty (HsKindSig ty kind) = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
ppr_mono_ty (HsListTy ty) = brackets (ppr_mono_lty ty)
ppr_mono_ty (HsPArrTy ty) = paBrackets (ppr_mono_lty ty)
ppr_mono_ty (HsIParamTy n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
ppr_mono_ty (HsSpliceTy s _) = pprSplice s
ppr_mono_ty (HsCoreTy ty) = ppr ty
ppr_mono_ty (HsExplicitListTy Promoted _ tys)
= quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys)
ppr_mono_ty (HsExplicitListTy NotPromoted _ tys)
= brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty _ (HsTyLit t) = ppr_tylit t
ppr_mono_ty _ (HsWildCardTy {}) = char '_'
ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty (HsTyLit t) = ppr_tylit t
ppr_mono_ty (HsWildCardTy {}) = char '_'
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
= maybeParen ctxt_prec TyOpPrec $
ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2
ppr_mono_ty (HsEqTy ty1 ty2)
= ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2
ppr_mono_ty _ctxt_prec (HsAppsTy tys)
= hsep (map (ppr_app_ty TyConPrec . unLoc) tys)
ppr_mono_ty (HsAppsTy tys)
= hsep (map (ppr_app_ty . unLoc) tys)
ppr_mono_ty _ctxt_prec (HsAppTy fun_ty arg_ty)
= hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty]
ppr_mono_ty (HsAppTy fun_ty arg_ty)
= hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
ppr_mono_ty ctxt_prec (HsOpTy ty1 (L _ op) ty2)
= maybeParen ctxt_prec TyOpPrec $
sep [ ppr_mono_lty TyOpPrec ty1
, sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ]
ppr_mono_ty (HsOpTy ty1 (L _ op) ty2)
= sep [ ppr_mono_lty ty1
, sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
ppr_mono_ty _ (HsParTy ty)
= parens (ppr_mono_lty TopPrec ty)
ppr_mono_ty (HsParTy ty)
= parens (ppr_mono_lty ty)
-- Put the parens in where the user did
-- But we still use the precedence stuff to add parens because
-- toHsType doesn't put in any HsParTys, so we may still need them
ppr_mono_ty ctxt_prec (HsDocTy ty doc)
= maybeParen ctxt_prec TyOpPrec $
ppr_mono_lty TyOpPrec ty <+> ppr (unLoc doc)
ppr_mono_ty (HsDocTy ty doc)
-- AZ: Should we add parens? Should we introduce "-- ^"?
= ppr_mono_lty ty <+> ppr (unLoc doc)
-- we pretty print Haddock comments on types as if they were
-- postfix operators
--------------------------
ppr_fun_ty :: (OutputableBndrId name)
=> TyPrec -> LHsType name -> LHsType name -> SDoc
ppr_fun_ty ctxt_prec ty1 ty2
= let p1 = ppr_mono_lty FunPrec ty1
p2 = ppr_mono_lty TopPrec ty2
=> LHsType name -> LHsType name -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
in
maybeParen ctxt_prec FunPrec $
sep [p1, text "->" <+> p2]
--------------------------
ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc
ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n
ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
ppr_app_ty :: (OutputableBndrId name) => HsAppType name -> SDoc
ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n
ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
= pprPrefixOcc n
ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar Promoted (L _ n))))
ppr_app_ty (HsAppPrefix (L _ (HsTyVar Promoted (L _ n))))
= space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so
-- the parser does not attach it to the
-- previous symbol
ppr_app_ty ctxt (HsAppPrefix ty) = ppr_mono_lty ctxt ty
ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty
--------------------------
ppr_tylit :: HsTyLit -> SDoc
......
......@@ -1858,7 +1858,7 @@ too_many_args fun args
2 (sep (map pp args))
where
pp (Left e) = ppr e
pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t
pp (Right (HsWC { hswc_body = L _ t })) = pprHsType t
{-
......
......@@ -1575,7 +1575,8 @@ mkDefMethBind clas inst_tys sel_id dm_name
; return (bind, inline_prags) }
where
mk_vta :: LHsExpr Name -> Type -> LHsExpr Name
mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs $ noLoc $ HsCoreTy ty))
mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs
$ nlHsParTy $ noLoc $ HsCoreTy ty))
-- NB: use visible type application
-- See Note [Default methods in instances]
......
......@@ -151,26 +151,26 @@ data Ex a
Ex4 (forall a. a -> a)
<document comment>
k ::
(T () () This argument has type 'T')
-> ((T2 Int Int) This argument has type 'T2 Int Int')
-> ((T3 Bool Bool
-> T4 Float Float) This argument has type @T3 Bool Bool -> T4 Float Float@)
-> (T5 () () This argument has a very long description that should
T () () This argument has type 'T'
-> (T2 Int Int) This argument has type 'T2 Int Int'
-> (T3 Bool Bool
-> T4 Float Float) This argument has type @T3 Bool Bool -> T4 Float Float@
-> T5 () () This argument has a very long description that should
hopefully cause some wrapping to happen when it is finally
rendered by Haddock in the generated HTML page.)
rendered by Haddock in the generated HTML page.
-> IO () This is the result type
l :: ((Int, Int, Float) takes a triple) -> Int returns an 'Int'
l :: (Int, Int, Float) takes a triple -> Int returns an 'Int'
<document comment>
m ::
R -> (N1 () one of the arguments) -> IO Int and the return value
R -> N1 () one of the arguments -> IO Int and the return value
<document comment>
newn ::
(R one of the arguments, an 'R')
-> (N1 () one of the arguments) -> IO Int
R one of the arguments, an 'R'
-> N1 () one of the arguments -> IO Int
newn = undefined
<document comment>
foreign import ccall unsafe "header.h" o
:: (Float The input float) -> IO Float The output float
:: Float The input float -> IO Float The output float
<document comment>
newp :: Int
newp = undefined
......
==================== Parser ====================
module ShouldCompile where
test :: (Eq a) => ([a] doc1) -> ([a] doc2 ) -> [a] doc3
test :: (Eq a) => [a] doc1 -> [a] doc2 -> [a] doc3
test xs ys = xs
==================== Parser ====================
module ShouldCompile where
test2 :: (a doc1 ) -> (b doc2 ) -> a doc 3
test2 :: a doc1 -> b doc2 -> a doc 3
test2 x y = x
==================== Parser ====================
module ShouldCompile where
test2 :: (a doc1 ) -> a
test2 :: a doc1 -> a
test2 x = x
......@@ -2,7 +2,7 @@
==================== Parser ====================
module ShouldCompile where
test ::
(Eq a) => ([a] doc1) -> forall b. ([b] doc2 ) -> [a] doc3
(Eq a) => [a] doc1 -> forall b. [b] doc2 -> [a] doc3
test xs ys = xs
......@@ -2,9 +2,9 @@
==================== Parser ====================
module ShouldCompile where
test ::
([a] doc1)
[a] doc1
-> forall b.
(Ord b) => ([b] doc2 ) -> forall c. (Num c) => ([c] doc3) -> [a]
(Ord b) => [b] doc2 -> forall c. (Num c) => [c] doc3 -> [a]
test xs ys zs = xs
......@@ -2,7 +2,7 @@
==================== Parser ====================
module ShouldCompile where
data a <--> b = Mk a b
test :: ([a] doc1 ) -> a <--> b -> [a] blabla
test :: [a] doc1 -> a <--> b -> [a] blabla
test xs ys = xs
......@@ -14,4 +14,4 @@ Simple14.hs:8:8: error:
Actual type: EQ_ z z
• In the ambiguity check for ‘eqE’
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
In the type signature: eqE :: EQ_ x y -> ((x ~ y) => EQ_ z z) -> p
In the type signature: eqE :: EQ_ x y -> (x ~ y => EQ_ z z) -> p
......@@ -2,4 +2,4 @@
SimpleFail15.hs:5:8: error:
• Illegal qualified type: (a ~ b) => t
Perhaps you intended to use RankNTypes or Rank2Types
• In the type signature: foo :: (a, b) -> ((a ~ b) => t) -> (a, b)
• In the type signature: foo :: (a, b) -> (a ~ b => t) -> (a, b)
......@@ -13,6 +13,5 @@ T10503.hs:8:6: error:
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
In the type signature:
h :: forall r.
((Proxy ( 'KProxy :: KProxy k) ~ Proxy ( 'KProxy :: KProxy *)) =>
r)
(Proxy ( 'KProxy :: KProxy k) ~ Proxy ( 'KProxy :: KProxy *) => r)
-> r
......@@ -3,4 +3,4 @@ T7328.hs:8:34: error:
• Occurs check: cannot construct the infinite kind: k1 ~ k0 -> k1
• In the first argument of ‘Foo’, namely ‘f’
In the first argument of ‘Proxy’, namely ‘(Foo f)’
In the type signature: foo :: (a ~ f i) => Proxy (Foo f)
In the type signature: foo :: a ~ f i => Proxy (Foo f)
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