Smarter HsType pretty-print for promoted datacons

Fix Trac #15898, by being smarter about when to print
a space before a promoted data constructor, in a HsType.
I had to implement a mildly tiresome function
    HsType.lhsTypeHasLeadingPromotionQuote
It has multiple cases, of course, but it's very simple.

The patch improves the error-message output in a bunch of
cases, and (to my surprise) actually fixes a bug in the
output of T14343 (Trac #14343), thus

  -  In the expression: _ :: Proxy '('( 'True,  'False),  'False)
  +  In the expression: _ :: Proxy '( '( 'True, 'False), 'False)

I discovered that there were two copies of the PromotionFlag
type (a boolean, with helpfully named data cons), one in
IfaceType and one in HsType.  So I combined into one,
PromotionFlag, and moved it to BasicTypes.  That's why
quite a few files are touched, but it's all routine.

8 files changed, 120 insertions, 61 deletions

diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index cf56957f7b..200e5c9b8a 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -28,6 +28,7 @@ module BasicTypes(
 
         Alignment,
 
+        PromotionFlag(..), isPromoted,
         FunctionOrData(..),
 
         WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),
@@ -270,6 +271,24 @@ unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
 unSwap NotSwapped f a b = f a b
 unSwap IsSwapped  f a b = f b a
 
+
+{- *********************************************************************
+*                                                                      *
+           Promotion flag
+*                                                                      *
+********************************************************************* -}
+
+-- | Is a TyCon a promoted data constructor or just a normal type constructor?
+data PromotionFlag
+  = NotPromoted
+  | IsPromoted
+  deriving ( Eq, Data )
+
+isPromoted :: PromotionFlag -> Bool
+isPromoted IsPromoted  = True
+isPromoted NotPromoted = False
+
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 06d5d6ca7a..8bd33d6a5b 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -1350,7 +1350,7 @@ cvtTypeKind ty_str ty
                            -- names, as opposed to PromotedT, which can only
                            -- contain data constructor names. See #15572.
                            let prom = if isRdrDataCon nm'
-                                      then Promoted
+                                      then IsPromoted
                                       else NotPromoted
                          ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}
 
@@ -1398,8 +1398,8 @@ cvtTypeKind ty_str ty
                    }
 
            PromotedT nm -> do { nm' <- cName nm
-                              ; mk_apps (HsTyVar noExt Promoted
-                                                             (noLoc nm')) tys' }
+                              ; let hs_ty = HsTyVar noExt IsPromoted (noLoc nm')
+                              ; mk_apps hs_ty tys' }
                  -- Promoted data constructor; hence cName
 
            PromotedTupleT n
@@ -1408,20 +1408,20 @@ cvtTypeKind ty_str ty
              | m == n   -- Saturated
              -> returnL (HsExplicitTupleTy noExt tys')
              | otherwise
-             -> mk_apps (HsTyVar noExt Promoted
+             -> mk_apps (HsTyVar noExt IsPromoted
                                (noLoc (getRdrName (tupleDataCon Boxed n)))) tys'
              where
                m = length tys'
 
            PromotedNilT
-             -> mk_apps (HsExplicitListTy noExt Promoted []) tys'
+             -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'
 
            PromotedConsT  -- See Note [Representing concrete syntax in types]
                           -- in Language.Haskell.TH.Syntax
              | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
              -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
              | otherwise
-             -> mk_apps (HsTyVar noExt Promoted
+             -> mk_apps (HsTyVar noExt IsPromoted
                          (noLoc (getRdrName consDataCon)))
                         tys'
 
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 8200707e16..f0f71be738 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -24,7 +24,6 @@ module HsTypes (
         HsWildCardBndrs(..),
         LHsSigType, LHsSigWcType, LHsWcType,
         HsTupleSort(..),
-        Promoted(..),
         HsContext, LHsContext,
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
@@ -515,10 +514,10 @@ data HsType pass
       , hst_ctxt  :: LHsContext pass       -- Context C => blah
       , hst_body  :: LHsType pass }
 
-  | HsTyVar             (XTyVar pass)
-                        Promoted -- whether explicitly promoted, for the pretty
-                                 -- printer
-                        (Located (IdP pass))
+  | HsTyVar  (XTyVar pass)
+              PromotionFlag    -- Whether explicitly promoted,
+                               -- for the pretty printer
+             (Located (IdP pass))
                   -- Type variable, type constructor, or data constructor
                   -- see Note [Promotions (HsTyVar)]
                   -- See Note [Located RdrNames] in HsExpr
@@ -641,7 +640,7 @@ data HsType pass
 
   | HsExplicitListTy       -- A promoted explicit list
         (XExplicitListTy pass)
-        Promoted           -- whether explcitly promoted, for pretty printer
+        PromotionFlag      -- whether explcitly promoted, for pretty printer
         [LHsType pass]
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
       --         'ApiAnnotation.AnnClose' @']'@
@@ -854,12 +853,6 @@ data HsTupleSort = HsUnboxedTuple
                  | HsBoxedOrConstraintTuple
                  deriving Data
 
-
--- | Promoted data types.
-data Promoted = Promoted
-              | NotPromoted
-              deriving (Data, Eq, Show)
-
 -- | Located Constructor Declaration Field
 type LConDeclField pass = Located (ConDeclField pass)
       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
@@ -1401,11 +1394,9 @@ ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
 
 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 (HsTyVar _ prom (L _ name))
+  | isPromoted prom = quote (pprPrefixOcc name)
+  | otherwise       = pprPrefixOcc name
 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
@@ -1418,11 +1409,11 @@ ppr_mono_ty (HsKindSig _ ty kind)
 ppr_mono_ty (HsListTy _ ty)       = brackets (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 (HsExplicitListTy _ Promoted tys)
-  = quote $ brackets (interpp'SP tys)
-ppr_mono_ty (HsExplicitListTy _ NotPromoted tys)
-  = brackets (interpp'SP tys)
-ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
+ppr_mono_ty (HsExplicitListTy _ prom tys)
+  | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)
+  | otherwise       = brackets (interpp'SP tys)
+ppr_mono_ty (HsExplicitTupleTy _ tys)
+  = quote $ parens (maybeAddSpace tys $ interpp'SP tys)
 ppr_mono_ty (HsTyLit _ t)       = ppr_tylit t
 ppr_mono_ty (HsWildCardTy {})   = char '_'
 
@@ -1492,6 +1483,46 @@ hsTypeNeedsParens p = go
     go (HsDocTy _ (L _ t) _) = go t
     go (XHsType{})           = False
 
+maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc
+-- See Note [Printing promoted type constructors]
+-- in IfaceType.  This code implements the same
+-- logic for printing HsType
+maybeAddSpace tys doc
+  | (ty : _) <- tys
+  , lhsTypeHasLeadingPromotionQuote ty = space <> doc
+  | otherwise                          = doc
+
+lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool
+lhsTypeHasLeadingPromotionQuote ty
+  = goL ty
+  where
+    goL (L _ ty) = go ty
+
+    go (HsForAllTy{})        = False
+    go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})
+      | L _ (c:_) <- ctxt    = goL c
+      | otherwise            = goL body
+    go (HsBangTy{})          = False
+    go (HsRecTy{})           = False
+    go (HsTyVar _ p _)       = isPromoted p
+    go (HsFunTy _ arg _)     = goL arg
+    go (HsListTy{})          = False
+    go (HsTupleTy{})         = False
+    go (HsSumTy{})           = False
+    go (HsOpTy _ t1 _ _)     = goL t1
+    go (HsKindSig _ t _)     = goL t
+    go (HsIParamTy{})        = False
+    go (HsSpliceTy{})        = False
+    go (HsExplicitListTy _ p _) = isPromoted p
+    go (HsExplicitTupleTy{}) = True
+    go (HsTyLit{})           = False
+    go (HsWildCardTy{})      = False
+    go (HsStarTy{})          = False
+    go (HsAppTy _ t _)       = goL t
+    go (HsParTy{})           = False
+    go (HsDocTy _ t _)       = goL t
+    go (XHsType{})           = False
+
 -- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is
 -- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
 -- returns @ty@.
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 264dfa0c57..4d6a3b3be3 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -16,7 +16,7 @@ module IfaceType (
         IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
         IfaceMCoercion(..),
         IfaceUnivCoProv(..),
-        IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
+        IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..),
         IfaceTyLit(..), IfaceAppArgs(..),
         IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
         IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
@@ -143,7 +143,7 @@ data IfaceType
 
   | IfaceTupleTy                  -- Saturated tuples (unsaturated ones use IfaceTyConApp)
        TupleSort                  -- What sort of tuple?
-       IsPromoted                 -- A bit like IfaceTyCon
+       PromotionFlag                 -- A bit like IfaceTyCon
        IfaceAppArgs               -- arity = length args
           -- For promoted data cons, the kind args are omitted
 
@@ -186,10 +186,6 @@ data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
                              , ifaceTyConInfo :: IfaceTyConInfo }
     deriving (Eq)
 
--- | Is a TyCon a promoted data constructor or just a normal type constructor?
-data IsPromoted = IsNotPromoted | IsPromoted
-    deriving (Eq)
-
 -- | The various types of TyCons which have special, built-in syntax.
 data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon
 
@@ -290,7 +286,7 @@ See Note [The equality types story] in TysPrim.
 
 data IfaceTyConInfo   -- Used to guide pretty-printing
                       -- and to disambiguate D from 'D (they share a name)
-  = IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted
+  = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag
                    , ifaceTyConSort       :: IfaceTyConSort }
     deriving (Eq)
 
@@ -1033,11 +1029,24 @@ criteria are met:
    in TyCoRep.
 
 N.B. Until now (Aug 2018) we didn't check anything for coercion variables.
+
+Note [Printing promoted type constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this GHCi session (Trac #14343)
+    > _ :: Proxy '[ 'True ]
+    error:
+      Found hole: _ :: Proxy '['True]
+
+This would be bad, because the '[' looks like a character literal.
+Solution: in type-level lists and tuples, add a leading space
+if the first type is itself promoted.  See pprSpaceIfPromotedTyCon.
 -}
 
+
 -------------------
 
 -- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'.
+-- See Note [Printing promoted type constructors]
 pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc
 pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _)
   = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of
@@ -1229,7 +1238,7 @@ ppr_iface_tc_app pp ctxt_prec tc tys
   | otherwise
   = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
 
-pprSum :: Arity -> IsPromoted -> IfaceAppArgs -> SDoc
+pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc
 pprSum _arity is_promoted args
   =   -- drop the RuntimeRep vars.
       -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
@@ -1238,8 +1247,8 @@ pprSum _arity is_promoted args
     in pprPromotionQuoteI is_promoted
        <> sumParens (pprWithBars (ppr_ty topPrec) args')
 
-pprTuple :: PprPrec -> TupleSort -> IsPromoted -> IfaceAppArgs -> SDoc
-pprTuple ctxt_prec ConstraintTuple IsNotPromoted IA_Nil
+pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc
+pprTuple ctxt_prec ConstraintTuple NotPromoted IA_Nil
   = maybeParen ctxt_prec appPrec $
     text "() :: Constraint"
 
@@ -1375,8 +1384,8 @@ pprPromotionQuote :: IfaceTyCon -> SDoc
 pprPromotionQuote tc =
     pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
 
-pprPromotionQuoteI  :: IsPromoted -> SDoc
-pprPromotionQuoteI IsNotPromoted = empty
+pprPromotionQuoteI  :: PromotionFlag -> SDoc
+pprPromotionQuoteI NotPromoted = empty
 pprPromotionQuoteI IsPromoted    = char '\''
 
 instance Outputable IfaceCoercion where
@@ -1389,17 +1398,6 @@ instance Binary IfaceTyCon where
                i <- get bh
                return (IfaceTyCon n i)
 
-instance Binary IsPromoted where
-   put_ bh IsNotPromoted = putByte bh 0
-   put_ bh IsPromoted    = putByte bh 1
-
-   get bh = do
-       n <- getByte bh
-       case n of
-         0 -> return IsNotPromoted
-         1 -> return IsPromoted
-         _ -> fail "Binary(IsPromoted): fail)"
-
 instance Binary IfaceTyConSort where
    put_ bh IfaceNormalTyCon             = putByte bh 0
    put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 248f7d3c38..34bcdb7cd5 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -1153,13 +1153,13 @@ tcIfaceType = go
     go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co
     go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co
 
-tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceAppArgs -> IfL Type
+tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
 tcIfaceTupleTy sort is_promoted args
  = do { args' <- tcIfaceAppArgs args
       ; let arity = length args'
       ; base_tc <- tcTupleTyCon True sort arity
       ; case is_promoted of
-          IsNotPromoted
+          NotPromoted
             -> return (mkTyConApp base_tc args')
 
           IsPromoted
@@ -1673,7 +1673,7 @@ tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
 tcIfaceTyCon (IfaceTyCon name info)
   = do { thing <- tcIfaceGlobal name
        ; return $ case ifaceTyConIsPromoted info of
-           IsNotPromoted -> tyThingTyCon thing
+           NotPromoted -> tyThingTyCon thing
            IsPromoted    -> promoteDataCon $ tyThingDataCon thing }
 
 tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs
index 653b7407da..a3d11e8891 100644
--- a/compiler/iface/ToIface.hs
+++ b/compiler/iface/ToIface.hs
@@ -150,7 +150,7 @@ toIfaceTypeX fr (TyConApp tc tys)
     -- tuples
   | Just sort <- tyConTuple_maybe tc
   , n_tys == arity
-  = IfaceTupleTy sort IsNotPromoted (toIfaceTcArgsX fr tc tys)
+  = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)
 
   | Just dc <- isPromotedDataCon_maybe tc
   , isTupleDataCon dc
@@ -159,7 +159,7 @@ toIfaceTypeX fr (TyConApp tc tys)
 
   | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
   , (k1:k2:_) <- tys
-  = let info = IfaceTyConInfo IsNotPromoted sort
+  = let info = IfaceTyConInfo NotPromoted sort
         sort | k1 `eqType` k2 = IfaceEqualityTyCon
              | otherwise      = IfaceNormalTyCon
     in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
@@ -191,7 +191,7 @@ toIfaceTyCon tc
     tc_name = tyConName tc
     info    = IfaceTyConInfo promoted sort
     promoted | isPromotedDataCon tc = IsPromoted
-             | otherwise            = IsNotPromoted
+             | otherwise            = NotPromoted
 
     tupleSort :: TyCon -> Maybe IfaceTyConSort
     tupleSort tc' =
@@ -217,7 +217,7 @@ toIfaceTyCon tc
 
 toIfaceTyCon_name :: Name -> IfaceTyCon
 toIfaceTyCon_name n = IfaceTyCon n info
-  where info = IfaceTyConInfo IsNotPromoted IfaceNormalTyCon
+  where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon
   -- Used for the "rough-match" tycon stuff,
   -- where pretty-printing is not an issue
 
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 8a10516819..f5082174ab 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2030,14 +2030,14 @@ atype :: { LHsType GhcPs }
                                              (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
                                              [mj AnnThIdSplice $1] }
                                       -- see Note [Promotion] for the followings
-        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt IsPromoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
         | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'
                              {% addAnnotation (gl $3) AnnComma (gl $4) >>
                                 ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5))
                                     [mj AnnSimpleQuote $1,mop $2,mcp $6] }
-        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy noExt Promoted $3)
+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy noExt IsPromoted $3)
                                                        [mj AnnSimpleQuote $1,mos $2,mcs $4] }
-        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2)
+        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar noExt IsPromoted $2)
                                                        [mj AnnSimpleQuote $1,mj AnnName $2] }
 
         -- Two or more [ty, ty, ty] must be a promoted list type, just as
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index a38af74efe..63efd14a5b 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -945,6 +945,17 @@ instance Binary LeftOrRight where
                    0 -> return CLeft
                    _ -> return CRight }
 
+instance Binary PromotionFlag where
+   put_ bh NotPromoted = putByte bh 0
+   put_ bh IsPromoted  = putByte bh 1
+
+   get bh = do
+       n <- getByte bh
+       case n of
+         0 -> return NotPromoted
+         1 -> return IsPromoted
+         _ -> fail "Binary(IsPromoted): fail)"
+
 instance Binary Fingerprint where
   put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
   get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)