Remove HsContext from ppr_mono_ty, and remove ppParendHsType
authorAlan Zimmerman <alan.zimm@gmail.com>
Fri, 26 May 2017 15:06:11 +0000 (17:06 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Sun, 28 May 2017 10:53:57 +0000 (12:53 +0200)
This is a cleanup after Trac #13238, as the context was no longer being used.

17 files changed:
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsTypes.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcInstDcls.hs
testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr
testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr
testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr
testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr
testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr
testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr
testsuite/tests/indexed-types/should_compile/Simple14.stderr
testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr
testsuite/tests/polykinds/T10503.stderr
testsuite/tests/polykinds/T7328.stderr

index 8efb665..5f67515 100644 (file)
@@ -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'
index 8634432..7fcc3b8 100644 (file)
@@ -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
index f32c24e..c281e63 100644 (file)
@@ -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))
index 2144a28..9d7efc5 100644 (file)
@@ -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
index 7f7f734..5eec012 100644 (file)
@@ -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
 
 
 {-
index 6033142..7c591a8 100644 (file)
@@ -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]
 
index 4961890..8f06390 100644 (file)
@@ -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
index c0233de..fcb953a 100644 (file)
@@ -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
 
 
index f1db237..9f57f5d 100644 (file)
@@ -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
 
 
index 4b208f8..472ec1a 100644 (file)
@@ -1,7 +1,7 @@
 
 ==================== Parser ====================
 module ShouldCompile where
-test2 :: (a  doc1 ) -> a
+test2 :: a  doc1  -> a
 test2 x = x
 
 
index fcf9e0c..5f7335b 100644 (file)
@@ -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
 
 
index cd88840..e7707c5 100644 (file)
@@ -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
 
 
index 9e1edc6..47d2468 100644 (file)
@@ -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
 
 
index 0c600e3..40d1d90 100644 (file)
@@ -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
index fd0b987..13a0dff 100644 (file)
@@ -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)
index b0f17ad..731a14b 100644 (file)
@@ -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
index e6accc5..76f8155 100644 (file)
@@ -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)