diff options
22 files changed, 98 insertions, 46 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 58c9d9eb25..176685bbf9 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -2781,4 +2781,5 @@ pretendNameIsInScope n , liftedDataConKey, unliftedDataConKey , tYPETyConKey , runtimeRepTyConKey, boxedRepDataConKey - , eqTyConKey ] + , eqTyConKey + , listTyConKey ] diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 54354fcd5f..e566dea938 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -18,7 +18,7 @@ module GHC.Builtin.Types ( mkWiredInIdName, -- used in GHC.Types.Id.Make -- * All wired in things - wiredInTyCons, isBuiltInOcc_maybe, + wiredInTyCons, isBuiltInOcc_maybe, isPunOcc_maybe, -- * Bool boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, @@ -372,7 +372,7 @@ falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") fa trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon listTyConName, nilDataConName, consDataConName :: Name -listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon +listTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "List") listTyConKey listTyCon nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon @@ -931,6 +931,21 @@ isBuiltInOcc_maybe occ = = choose_ns (getName (tupleTyCon boxity arity)) (getName (tupleDataCon boxity arity)) +-- When resolving names produced by Template Haskell (see thOrigRdrName +-- in GHC.ThToHs), we want ghc-prim:GHC.Types.List to yield an Exact name, not +-- an Orig name. +-- +-- This matters for pretty-printing under ListTuplePuns. If we don't do it, +-- then -ddump-splices will print ''[] as ''GHC.Types.List. +-- +-- Test case: th/T13776 +-- +isPunOcc_maybe :: Module -> OccName -> Maybe Name +isPunOcc_maybe mod occ + | mod == gHC_TYPES, occ == occName listTyConName + = Just listTyConName +isPunOcc_maybe _ _ = Nothing + mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName -- No need to cache these, the caching is done in mk_tuple mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ar) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index bf74bac0ab..b0f5888317 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -4969,6 +4969,7 @@ initSDocContext dflags style = SDC , sdocStarIsType = xopt LangExt.StarIsType dflags , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags , sdocLinearTypes = xopt LangExt.LinearTypes dflags + , sdocListTuplePuns = True , sdocPrintTypeAbbreviations = True , sdocUnitIdForUser = ftext } diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index ab7b344eb9..40dccb6e0e 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -1610,26 +1610,26 @@ pprIfaceCoTcApp ctxt_prec tc tys = -- 2. Coercions (from 'pprIfaceCoTcApp') ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc -ppr_iface_tc_app pp _ tc [ty] - | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) -ppr_iface_tc_app pp ctxt_prec tc tys - | tc `ifaceTyConHasKey` liftedTypeKindTyConKey - = ppr_kind_type ctxt_prec +ppr_iface_tc_app pp ctxt_prec tc tys = + sdocOption sdocListTuplePuns $ \listTuplePuns -> + if | listTuplePuns, tc `ifaceTyConHasKey` listTyConKey, [ty] <- tys + -> brackets (pp topPrec ty) - | not (isSymOcc (nameOccName (ifaceTyConName tc))) - = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + -> ppr_kind_type ctxt_prec - | [ ty1@(_, Required) - , ty2@(_, Required) ] <- tys - -- Infix, two visible arguments (we know nothing of precedence though). - -- Don't apply this special case if one of the arguments is invisible, - -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). - = pprIfaceInfixApp ctxt_prec (ppr tc) - (pp opPrec ty1) (pp opPrec ty2) + | not (isSymOcc (nameOccName (ifaceTyConName tc))) + -> pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) - | otherwise - = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) + | [ ty1@(_, Required), ty2@(_, Required) ] <- tys + -- Infix, two visible arguments (we know nothing of precedence though). + -- Don't apply this special case if one of the arguments is invisible, + -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). + -> pprIfaceInfixApp ctxt_prec (ppr tc) (pp opPrec ty1) (pp opPrec ty2) + + | otherwise + -> pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) -- | Pretty-print an unboxed sum type. The sum should be saturated: -- as many visible arguments as the arity of the sum. diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 82f30c4757..194250aff8 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -57,6 +57,7 @@ import GHC.Utils.Panic import qualified Data.ByteString as BS import Control.Monad( unless, ap ) +import Control.Applicative( (<|>) ) import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -2107,9 +2108,10 @@ thRdrName loc ctxt_ns th_occ th_name thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName thOrigRdrName occ th_ns pkg mod = let occ' = mk_occ (mk_ghc_ns th_ns) occ - in case isBuiltInOcc_maybe occ' of + mod' = mkModule (mk_pkg pkg) (mk_mod mod) + in case isBuiltInOcc_maybe occ' <|> isPunOcc_maybe mod' occ' of Just name -> nameRdrName name - Nothing -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ' + Nothing -> (mkOrig $! mod') $! occ' thRdrNameGuesses :: TH.Name -> [RdrName] thRdrNameGuesses (TH.Name occ flavour) diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index d919919e81..3d18d7bbb0 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -54,6 +54,7 @@ module GHC.Types.Name ( setNameLoc, tidyNameOcc, localiseName, + namePun_maybe, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, pprFullName, pprTickyName, @@ -83,6 +84,7 @@ module GHC.Types.Name ( import GHC.Prelude import {-# SOURCE #-} GHC.Types.TyThing ( TyThing ) +import {-# SOURCE #-} GHC.Builtin.Types ( listTyCon ) import GHC.Platform import GHC.Types.Name.Occurrence @@ -332,6 +334,12 @@ nameModule_maybe _ = Nothing is_interactive_or_from :: Module -> Module -> Bool is_interactive_or_from from mod = from == mod || isInteractiveModule mod +-- Return the pun for a name if available. +-- Used for pretty-printing under ListTuplePuns. +namePun_maybe :: Name -> Maybe FastString +namePun_maybe name | getUnique name == getUnique listTyCon = Just (fsLit "[]") +namePun_maybe _ = Nothing + nameIsLocalOrFrom :: Module -> Name -> Bool -- ^ Returns True if the name is -- (a) Internal @@ -616,14 +624,21 @@ instance OutputableBndr Name where pprPrefixOcc = pprPrefixName pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) +pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \sty -> getPprDebug $ \debug -> + sdocOption sdocListTuplePuns $ \listTuplePuns -> + handlePuns listTuplePuns (namePun_maybe name) $ case sort of WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin External mod -> pprExternal debug sty uniq mod occ False UserSyntax System -> pprSystem debug sty uniq occ Internal -> pprInternal debug sty uniq occ + where + -- Print GHC.Types.List as [], etc. + handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc + handlePuns True (Just pun) _ = ftext pun + handlePuns _ _ r = r -- | Print fully qualified name (with unit-id, module and unique) pprFullName :: Module -> Name -> SDoc diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs index 536fb63b43..8b203aac20 100644 --- a/compiler/GHC/Types/TyThing/Ppr.hs +++ b/compiler/GHC/Types/TyThing/Ppr.hs @@ -33,6 +33,8 @@ import GHC.Iface.Make ( tyThingToIfaceDecl ) import GHC.Utils.Outputable import GHC.Utils.Trace +import Data.Maybe ( isJust ) + -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API @@ -178,7 +180,7 @@ pprTyThing ss ty_thing ppr_bndr :: Name -> Maybe (OccName -> SDoc) ppr_bndr name - | isBuiltInSyntax name + | isBuiltInSyntax name || isJust (namePun_maybe name) = Nothing | otherwise = case nameModule_maybe name of diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index f4bf62232d..782dbd45fc 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -385,6 +385,7 @@ data SDocContext = SDC , sdocStarIsType :: !Bool , sdocLinearTypes :: !Bool , sdocImpredicativeTypes :: !Bool + , sdocListTuplePuns :: !Bool , sdocPrintTypeAbbreviations :: !Bool , sdocUnitIdForUser :: !(FastString -> SDoc) -- ^ Used to map UnitIds to more friendly "package-version:component" @@ -444,6 +445,7 @@ defaultSDocContext = SDC , sdocStarIsType = False , sdocImpredicativeTypes = False , sdocLinearTypes = False + , sdocListTuplePuns = True , sdocPrintTypeAbbreviations = True , sdocUnitIdForUser = ftext } diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 52a247ffae..cecd1f28ae 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -17,7 +17,7 @@ GHC.Prim Has no implementation. It defines built-in things, and copied to make GHC.Prim.hi GHC.Base Classes: Eq, Ord, Functor, Monad - Types: list, (), Int, Bool, Ordering, Char, String + Types: List, (), Int, Bool, Ordering, Char, String Data.Tuple Types: tuples, plus instances for GHC.Base classes diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs index c3800d5d59..6cb7412936 100644 --- a/libraries/base/GHC/List.hs +++ b/libraries/base/GHC/List.hs @@ -18,7 +18,9 @@ ----------------------------------------------------------------------------- module GHC.List ( - -- [] (..), -- built-in syntax; can't be used in export list + + -- The list data type + List, -- List-monomorphic Foldable methods and misc functions foldr, foldr', foldr1, diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 843da4055c..28aedb7240 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -22,16 +22,15 @@ ----------------------------------------------------------------------------- module GHC.Types ( - -- Data types that are built-in syntax - -- They are defined here, but not explicitly exported - -- - -- Lists: []( [], (:) ) - -- Type equality: (~)( Eq# ) - -- * Built-in types Bool(..), Char(..), Int(..), Word(..), Float(..), Double(..), Ordering(..), IO(..), + + List, -- List( [], (:) ) + -- List constructors are not exported + -- because they are built-in syntax + isTrue#, SPEC(..), Symbol, @@ -177,7 +176,7 @@ type family Any :: k where { } -- >>> ['h','e','l','l','o'] == "hello" -- True -- -data [] a = [] | a : [a] +data List a = [] | a : List a {- ********************************************************************* diff --git a/testsuite/tests/ghci/scripts/T12550.stdout b/testsuite/tests/ghci/scripts/T12550.stdout index d753d4f666..0a30edf362 100644 --- a/testsuite/tests/ghci/scripts/T12550.stdout +++ b/testsuite/tests/ghci/scripts/T12550.stdout @@ -28,9 +28,9 @@ instance ∀ a b. Functor ((,,) a b) -- Defined in ‘GHC.Base’ instance ∀ a b c. Functor ((,,,) a b c) -- Defined in ‘GHC.Base’ instance ∀ r. Functor ((->) r) -- Defined in ‘GHC.Base’ instance Functor IO -- Defined in ‘GHC.Base’ +instance Functor [] -- Defined in ‘GHC.Base’ instance Functor Maybe -- Defined in ‘GHC.Base’ instance Functor Solo -- Defined in ‘GHC.Base’ -instance Functor [] -- Defined in ‘GHC.Base’ instance ∀ a. Functor (Either a) -- Defined in ‘Data.Either’ instance ∀ (f ∷ ★ → ★) (g ∷ ★ → ★). (Functor f, Functor g) ⇒ diff --git a/testsuite/tests/ghci/scripts/T21294a.script b/testsuite/tests/ghci/scripts/T21294a.script new file mode 100644 index 0000000000..e4a91a5d83 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T21294a.script @@ -0,0 +1,5 @@ +type L0 = [] +:i L0 + +type L1 a = [a] +:i L1 diff --git a/testsuite/tests/ghci/scripts/T21294a.stdout b/testsuite/tests/ghci/scripts/T21294a.stdout new file mode 100644 index 0000000000..58fb4e6c27 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T21294a.stdout @@ -0,0 +1,6 @@ +type L0 :: * -> * +type L0 = [] :: * -> * + -- Defined at <interactive>:1:1 +type L1 :: * -> * +type L1 a = [a] + -- Defined at <interactive>:4:1 diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index f2d03bd8cf..9e7ca144a6 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -367,3 +367,4 @@ test('T21088', normal, ghci_script, ['T21088.script']) test('T21110', [extra_files(['T21110A.hs'])], ghci_script, ['T21110.script']) test('T17830', [filter_stdout_lines(r'======.*')], ghci_script, ['T17830.script']) +test('T21294a', normal, ghci_script, ['T21294a.script']) diff --git a/testsuite/tests/ghci/scripts/ghci011.stdout b/testsuite/tests/ghci/scripts/ghci011.stdout index d03977e3b5..edb6158456 100644 --- a/testsuite/tests/ghci/scripts/ghci011.stdout +++ b/testsuite/tests/ghci/scripts/ghci011.stdout @@ -1,5 +1,5 @@ -type [] :: * -> * -data [] a = [] | a : [a] +type List :: * -> * +data List a = [] | a : [a] -- Defined in ‘GHC.Types’ instance Monoid [a] -- Defined in ‘GHC.Base’ instance Semigroup [a] -- Defined in ‘GHC.Base’ @@ -35,9 +35,9 @@ instance (Semigroup a, Semigroup b) => Semigroup (a, b) instance Foldable ((,) a) -- Defined in ‘Data.Foldable’ instance (Bounded a, Bounded b) => Bounded (a, b) -- Defined in ‘GHC.Enum’ -instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’ instance (Eq a, Eq b) => Eq (a, b) -- Defined in ‘GHC.Classes’ instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’ +instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’ instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’ instance Monoid a => Applicative ((,) a) -- Defined in ‘GHC.Base’ instance Functor ((,) a) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/hiefile/should_run/HieQueries.stdout b/testsuite/tests/hiefile/should_run/HieQueries.stdout index 98f0466815..d352cc9c38 100644 --- a/testsuite/tests/hiefile/should_run/HieQueries.stdout +++ b/testsuite/tests/hiefile/should_run/HieQueries.stdout @@ -3,14 +3,15 @@ At point (31,9), we found: ========================== ┌ │ $dC at HieQueries.hs:31:1-13, of type: C [a] -│ is an evidence variable bound by a let, depending on: [$fC[], $dC] +│ is an evidence variable bound by a let, depending on: [$fCList, +│ $dC] │ with scope: LocalScope HieQueries.hs:31:1-13 │ bound at: HieQueries.hs:31:1-13 │ Defined at <no location info> └ | +- ┌ -| │ $fC[] at HieQueries.hs:27:10-21, of type: forall a. C a => C [a] +| │ $fCList at HieQueries.hs:27:10-21, of type: forall a. C a => C [a] | │ is an evidence variable bound by an instance of class C | │ with scope: ModuleScope | │ @@ -30,7 +31,7 @@ At point (37,9), we found: ========================== ┌ │ $dShow at HieQueries.hs:37:1-22, of type: Show [(Integer, x, A)] -│ is an evidence variable bound by a let, depending on: [$fShow[], +│ is an evidence variable bound by a let, depending on: [$fShowList, │ $dShow] │ with scope: LocalScope HieQueries.hs:37:1-22 │ bound at: HieQueries.hs:37:1-22 @@ -38,7 +39,7 @@ At point (37,9), we found: └ | +- ┌ -| │ $fShow[] at HieQueries.hs:37:1-22, of type: forall a. Show a => Show [a] +| │ $fShowList at HieQueries.hs:37:1-22, of type: forall a. Show a => Show [a] | │ is a usage of an external evidence variable | │ Defined in `GHC.Show' | └ diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr index 4d8bc6666a..d4efc75d76 100644 --- a/testsuite/tests/roles/should_compile/Roles4.stderr +++ b/testsuite/tests/roles/should_compile/Roles4.stderr @@ -35,7 +35,7 @@ $krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep $krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep $krep [InlPrag=[~]] - = GHC.Types.KindRepTyConApp GHC.Types.$tc[] ((:) $krep []) + = GHC.Types.KindRepTyConApp GHC.Types.$tcList ((:) $krep []) $krep [InlPrag=[~]] = GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint [] $krep [InlPrag=[~]] diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index 6a6e3dc627..b06d0df7f8 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -59,7 +59,7 @@ $krep [InlPrag=[~]] $krep ((:) @GHC.Types.KindRep $krep [] @GHC.Types.KindRep)) $krep [InlPrag=[~]] = GHC.Types.KindRepTyConApp - GHC.Types.$tc[] + GHC.Types.$tcList ((:) @GHC.Types.KindRep $krep [] @GHC.Types.KindRep) $krep [InlPrag=[~]] = GHC.Types.KindRepTyConApp diff --git a/testsuite/tests/showIface/DocsInHiFileTH.stdout b/testsuite/tests/showIface/DocsInHiFileTH.stdout index 0e9c1af6d5..1eac242a68 100644 --- a/testsuite/tests/showIface/DocsInHiFileTH.stdout +++ b/testsuite/tests/showIface/DocsInHiFileTH.stdout @@ -106,9 +106,9 @@ docs: $fCTYPEInt -> [text: -- |A new instance identifiers:], - $fCTYPE[] -> [text: - -- |Another new instance - identifiers:], + $fCTYPEList -> [text: + -- |Another new instance + identifiers:], $fDka -> [text: -- |Another new instance identifiers:], diff --git a/testsuite/tests/simplCore/should_compile/T15445.stderr b/testsuite/tests/simplCore/should_compile/T15445.stderr index 5e8a086e6d..b67e385a98 100644 --- a/testsuite/tests/simplCore/should_compile/T15445.stderr +++ b/testsuite/tests/simplCore/should_compile/T15445.stderr @@ -2,7 +2,7 @@ Rule fired: Class op + (BUILTIN) Rule fired: Class op fromInteger (BUILTIN) Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer) Rule fired: SPEC plusTwoRec (T15445a) -Rule fired: SPEC $fShow[] (GHC.Show) +Rule fired: SPEC $fShowList (GHC.Show) Rule fired: Class op >> (BUILTIN) Rule fired: Class op show (BUILTIN) Rule fired: SPEC plusTwoRec (T15445a) diff --git a/utils/haddock b/utils/haddock -Subproject fb0e9bac0a5297f995b151f25aa1ce3e622e12e +Subproject d504cd50d8b660c207573864890392f02a48ca5 |