diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2017-05-26 17:06:11 +0200 |
---|---|---|
committer | Alan Zimmerman <alan.zimm@gmail.com> | 2017-05-28 12:53:57 +0200 |
commit | 3b23f680c2b1f80b693eb8896fb21e4bbf8edc7e (patch) | |
tree | 45dd95b517b0050ccfde463c10938321e1da75e4 | |
parent | 09d5c993aae208e3d34a9e715297922b6ea42b3f (diff) | |
download | haskell-3b23f680c2b1f80b693eb8896fb21e4bbf8edc7e.tar.gz |
Remove HsContext from ppr_mono_ty, and remove ppParendHsType
This is a cleanup after Trac #13238, as the context was no longer being used.
17 files changed, 89 insertions, 91 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 8efb665506..5f67515c71 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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' diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 863443267b..7fcc3b8699 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -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 diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index f32c24ee46..c281e6361c 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -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)) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 2144a28597..9d7efc5bb5 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -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 diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 7f7f734ca9..5eec0129df 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -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 {- diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 603314257e..7c591a87d4 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -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] diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr index 49618904a2..8f06390348 100644 --- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr +++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr @@ -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 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr index c0233de0d5..fcb953a495 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr @@ -1,7 +1,7 @@ ==================== 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 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr index f1db2374b1..9f57f5df07 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module ShouldCompile where -test2 :: (a doc1 ) -> (b doc2 ) -> a doc 3 +test2 :: a doc1 -> b doc2 -> a doc 3 test2 x y = x diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr index 4b208f858a..472ec1a1eb 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module ShouldCompile where -test2 :: (a doc1 ) -> a +test2 :: a doc1 -> a test2 x = x diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr index fcf9e0c2d6..5f7335b6b9 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr @@ -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 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr index cd8884080f..e7707c5ec0 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr @@ -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 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr index 9e1edc661b..47d2468ea5 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr @@ -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 diff --git a/testsuite/tests/indexed-types/should_compile/Simple14.stderr b/testsuite/tests/indexed-types/should_compile/Simple14.stderr index 0c600e378f..40d1d90fb7 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple14.stderr +++ b/testsuite/tests/indexed-types/should_compile/Simple14.stderr @@ -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 diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr index fd0b98799a..13a0dff9e3 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr @@ -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) diff --git a/testsuite/tests/polykinds/T10503.stderr b/testsuite/tests/polykinds/T10503.stderr index b0f17adaad..731a14b117 100644 --- a/testsuite/tests/polykinds/T10503.stderr +++ b/testsuite/tests/polykinds/T10503.stderr @@ -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 diff --git a/testsuite/tests/polykinds/T7328.stderr b/testsuite/tests/polykinds/T7328.stderr index e6accc56f4..76f81555dd 100644 --- a/testsuite/tests/polykinds/T7328.stderr +++ b/testsuite/tests/polykinds/T7328.stderr @@ -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) |