TH-spliced class instances are pretty-printed incorrectly post-#3384
authorAlan Zimmerman <alan.zimm@gmail.com>
Sun, 29 Jan 2017 20:35:41 +0000 (22:35 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Fri, 10 Feb 2017 10:42:44 +0000 (12:42 +0200)
Summary:
The HsSyn prettyprinter tests patch 499e43824bda967546ebf95ee33ec1f84a114a7c
broke the pretty-printing of Template Haskell-spliced class instances.

Test Plan: ./validate

Reviewers: RyanGlScott, austin, goldfire, bgamari

Reviewed By: RyanGlScott, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3043

16 files changed:
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/rename/RnSplice.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcGenGenerics.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTypeable.hs
ghc/GHCi/UI.hs
testsuite/tests/ghci/scripts/T10508.stderr
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
testsuite/tests/printer/Makefile
testsuite/tests/printer/T13199.hs [new file with mode: 0644]
testsuite/tests/printer/T13199.stdout [new file with mode: 0644]
testsuite/tests/printer/all.T
testsuite/tests/th/T12530.stderr

index ed19314..7e786bd 100644 (file)
@@ -754,9 +754,10 @@ cvtClause :: HsMatchContext RdrName
           -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
 cvtClause ctxt (Clause ps body wheres)
   = do  { ps' <- cvtPats ps
+        ; pps <- mapM wrap_conpat ps'
         ; g'  <- cvtGuard body
         ; ds' <- cvtLocalDecs (text "a where clause") wheres
-        ; returnL $ Hs.Match ctxt ps' Nothing
+        ; returnL $ Hs.Match ctxt pps Nothing
                              (GRHSs g' (noLoc ds')) }
 
 
@@ -773,12 +774,13 @@ cvtl e = wrapL (cvt e)
       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
-                                   ; return $ HsApp (mkLHsPar x') y' }
+                                   ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
     cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
-                                   ; return $ HsApp x' y' }
+                                   ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
     cvt (AppTypeE e t) = do { e' <- cvtl e
                             ; t' <- cvtType t
-                            ; return $ HsAppType e' $ mkHsWildCardBndrs t' }
+                            ; tp <- wrap_apps t'
+                            ; return $ HsAppType e' $ mkHsWildCardBndrs tp }
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; return $ HsLam (mkMatchGroup FromSource
                                              [mkSimpleMatch LambdaExpr ps' e'])}
@@ -983,9 +985,12 @@ cvtMatch :: HsMatchContext RdrName
          -> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
 cvtMatch ctxt (TH.Match p body decs)
   = do  { p' <- cvtPat p
+        ; lp <- case ctxt of
+            CaseAlt -> return p'
+            _       -> wrap_conpat p'
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (text "a where clause") decs
-        ; returnL $ Hs.Match ctxt [p'] Nothing
+        ; returnL $ Hs.Match ctxt [lp] Nothing
                              (GRHSs g' (noLoc decs')) }
 
 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
@@ -1077,13 +1082,17 @@ cvtp (UnboxedSumP p alt arity)
                             ; unboxedSumChecks alt arity
                             ; return $ SumPat p' alt arity placeHolderType }
 cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
-                            ; return $ ConPatIn s' (PrefixCon ps') }
+                            ; pps <- mapM wrap_conpat ps'
+                            ; return $ ConPatIn s' (PrefixCon pps) }
 cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
                             ; wrapParL ParPat $
                               ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
                             -- See Note [Operator association]
 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
-cvtp (ParensP p)       = do { p' <- cvtPat p; return $ ParPat p' }
+cvtp (ParensP p)       = do { p' <- cvtPat p;
+                            ; case p' of  -- may be wrapped ConPatIn
+                                (L _ (ParPat {})) -> return $ unLoc p'
+                                _                 -> return $ ParPat p' }
 cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }
 cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
 cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
@@ -1106,6 +1115,12 @@ cvtPatFld (s,p)
                                      , hsRecFieldArg = p'
                                      , hsRecPun      = False}) }
 
+wrap_conpat :: Hs.LPat RdrName -> CvtM (Hs.LPat RdrName)
+wrap_conpat p@(L _ (ConPatIn _ (InfixCon{})))   = returnL $ ParPat p
+wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
+wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _)))  = returnL $ ParPat p
+wrap_conpat p                                   = return p
+
 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
 The produced tree of infix patterns will be left-biased, provided @x@ is.
 
@@ -1295,8 +1310,17 @@ cvtTypeKind ty_str ty
 -- | Constructs an application of a type to arguments passed in a list.
 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
 mk_apps head_ty []       = returnL head_ty
-mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
-                              ; mk_apps (HsAppTy head_ty' ty) tys }
+mk_apps head_ty (ty:tys) =
+  do { head_ty' <- returnL head_ty
+     ; p_ty      <- add_parens ty
+     ; mk_apps (HsAppTy head_ty' p_ty) tys }
+  where
+    add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t)
+    add_parens t                 = return t
+
+wrap_apps  :: LHsType RdrName -> CvtM (LHsType RdrName)
+wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
+wrap_apps t                  = return t
 
 -- | Constructs an arrow type with a specified return type
 mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName)
index 7500189..7202452 100644 (file)
@@ -719,15 +719,21 @@ Note [Parens in HsSyn]
 ~~~~~~~~~~~~~~~~~~~~~~
 HsPar (and ParPat in patterns, HsParTy in types) is used as follows
 
-  * Generally HsPar is optional; the pretty printer adds parens where
-    necessary.  Eg (HsApp f (HsApp g x)) is fine, and prints 'f (g x)'
-
-  * HsPars are pretty printed as '( .. )' regardless of whether
-    or not they are strictly necssary
+  * HsPar is required; the pretty printer does not add parens.
 
   * HsPars are respected when rearranging operator fixities.
     So   a * (b + c)  means what it says (where the parens are an HsPar)
 
+  * For ParPat and HsParTy the pretty printer does add parens but this should be
+    a no-op for ParsedSource, based on the pretty printer round trip feature
+    introduced in
+    https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c
+
+  * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or
+    not they are strictly necssary. This should be addressed when #13238 is
+    completed, to be treated the same as HsPar.
+
+
 Note [Sections in HsSyn]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 Sections should always appear wrapped in an HsPar, thus
@@ -949,7 +955,7 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
   = hang (ppr con_id) 2 (ppr rbinds)
 
 ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
-  = hang (pprParendExpr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
+  = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
 
 ppr_expr (ExprWithTySig expr sig)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
@@ -962,8 +968,8 @@ ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
 ppr_expr (PArrSeq  _ info) = paBrackets (ppr info)
 
 ppr_expr EWildPat       = char '_'
-ppr_expr (ELazyPat e)   = char '~' <> pprParendLExpr e
-ppr_expr (EAsPat v e)   = ppr v <> char '@' <> pprParendLExpr e
+ppr_expr (ELazyPat e)   = char '~' <> ppr e
+ppr_expr (EAsPat v e)   = ppr v <> char '@' <> ppr e
 ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e
 
 ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
@@ -971,11 +977,11 @@ ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
          -- no doublequotes if stl empty, for the case where the SCC was written
          -- without quotes.
           <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
-          pprParendLExpr expr ]
+          ppr expr ]
 
 ppr_expr (HsWrap co_fn e)
-  = pprHsWrapper co_fn (\parens -> if parens then pprParendExpr e
-                                             else pprExpr       e)
+  = pprHsWrapper co_fn (\parens -> if parens then pprExpr e
+                                             else pprExpr e)
 
 ppr_expr (HsSpliceE s)         = pprSplice s
 ppr_expr (HsBracket b)         = pprHsBracket b
@@ -988,7 +994,7 @@ ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
   = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
 
 ppr_expr (HsStatic _ e)
-  = hsep [text "static", pprParendLExpr e]
+  = hsep [text "static", ppr e]
 
 ppr_expr (HsTick tickish exp)
   = pprTicks (ppr exp) $
@@ -1043,7 +1049,7 @@ ppr_apps (HsAppTypeOut (L _ fun) arg) args
   = ppr_apps fun (Right (LHsWcTypeX arg) : args)
 ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
   where
-    pp (Left arg)                             = pprParendLExpr arg
+    pp (Left arg)                             = ppr arg
     pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
       = char '@' <> pprParendHsType arg
 
@@ -1274,7 +1280,7 @@ ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
 
 ppr_cmd (HsCmdApp c e)
   = let (fun, args) = collect_args c [e] in
-    hang (ppr_lcmd fun) 2 (sep (map pprParendLExpr args))
+    hang (ppr_lcmd fun) 2 (sep (map ppr args))
   where
     collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
     collect_args fun args = (fun, args)
index 58948cc..8001a15 100644 (file)
@@ -384,7 +384,7 @@ nlLitPat :: HsLit -> LPat id
 nlLitPat l = noLoc (LitPat l)
 
 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
-nlHsApp f x = noLoc (HsApp f x)
+nlHsApp f x = noLoc (HsApp f (mkLHsPar x))
 
 nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
 nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun
index ccfd002..b927a89 100644 (file)
@@ -734,12 +734,6 @@ illegalTypedSplice = text "Typed splices may not appear in untyped brackets"
 illegalUntypedSplice :: SDoc
 illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"
 
--- spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc
--- spliceResultDoc expr
---  = vcat [ hang (text "In the splice:")
---              2 (char '$' <> pprParendExpr expr)
---        , text "To see what the splice expanded to, use -ddump-splices" ]
-
 checkThLocalName :: Name -> RnM ()
 checkThLocalName name
   | isUnboundName name   -- Do not report two errors for
index 4c21a85..b2d7545 100644 (file)
@@ -1825,7 +1825,7 @@ too_many_args fun args
     hang (text "Too many type arguments to" <+> text fun <> colon)
        2 (sep (map pp args))
   where
-    pp (Left e)                             = pprParendLExpr e
+    pp (Left e)                             = ppr e
     pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t
 
 
index 66cf122..ffbade1 100644 (file)
@@ -330,7 +330,8 @@ mkBindsRep gk tycon =
         -- across all cases of a from/to definition, and can be factored out
         -- to save some allocations during typechecking.
         -- See Note [Generics compilation speed tricks]
-        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E $ nlHsCase x_Expr from_matches
+        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E
+                                       $ nlHsPar $ nlHsCase x_Expr from_matches
         to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches
 
         from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
@@ -769,8 +770,10 @@ genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
 genLR_E i n e
   | n == 0       = error "impossible"
   | n == 1       = e
-  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i     (div n 2) e
-  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m)     e
+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E i     (div n 2) e)
+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E (i-m) (n-m)     e)
                      where m = div n 2
 
 --------------------------------------------------------------------------------
index aba70aa..e590494 100644 (file)
@@ -516,7 +516,7 @@ spliceCtxtDoc splice
 spliceResultDoc :: LHsExpr Name -> SDoc
 spliceResultDoc expr
   = sep [ text "In the result of the splice:"
-        , nest 2 (char '$' <> pprParendLExpr expr)
+        , nest 2 (char '$' <> ppr expr)
         , text "To see what the splice expanded to, use -ddump-splices"]
 
 -------------------
index 9996a7d..86d1d1c 100644 (file)
@@ -140,8 +140,8 @@ mkModIdRHS mod
   = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
        ; trNameLit <- mkTrNameLit
        ; return $ nlHsDataCon trModuleDataCon
-                  `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))
-                  `nlHsApp` trNameLit (moduleNameFS (moduleName mod))
+                 `nlHsApp` (nlHsPar $ trNameLit (unitIdFS (moduleUnitId mod)))
+                 `nlHsApp` (nlHsPar $ trNameLit (moduleNameFS (moduleName mod)))
        }
 
 {- *********************************************************************
@@ -276,7 +276,7 @@ mkTyConRepRHS (Stuff {..}) tycon = rep_rhs
               `nlHsApp` nlHsLit (word64 high)
               `nlHsApp` nlHsLit (word64 low)
               `nlHsApp` mod_rep
-              `nlHsApp` trNameLit (mkFastString tycon_str)
+              `nlHsApp` (nlHsPar $ trNameLit (mkFastString tycon_str))
 
     tycon_str = add_tick (occNameString (getOccName tycon))
     add_tick s | isPromotedDataCon tycon = '\'' : s
index 11c086c..97f4739 100644 (file)
@@ -1501,7 +1501,8 @@ defineMacro overwrite s = do
     -- > ghciStepIO . definition :: String -> IO String
     let stringTy = nlHsTyVar stringTy_RDR
         ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
-        body = nlHsVar compose_RDR `mkHsApp` step `mkHsApp` expr
+        body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
+                                   `mkHsApp` (nlHsPar expr)
         tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
         new_expr = L (getLoc expr) $ ExprWithTySig body tySig
     hv <- GHC.compileParsedExprRemote new_expr
index 86cdc82..365bf9f 100644 (file)
@@ -4,7 +4,7 @@
       Expected type: IO Prelude.String
         Actual type: IO (a0 -> a0)
     • In the expression: return id
-      In the second argument of ‘(.)’, namely ‘\ _ -> return id
+      In the second argument of ‘(.)’, namely ‘(\ _ -> return id)
       In the expression:
           (.)
             (GHC.GHCi.ghciStepIO :: IO Prelude.String -> IO Prelude.String)
index a92ab4c..eee11ab 100644 (file)
         (HsVar 
          ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v rHO} [lidx] :: ghc-prim:GHC.Types.Module{tc 625})}))))) 
      ({ <no location info> }
-      (HsApp 
-       ({ <no location info> }
-        (HsConLikeOut 
-         ({abstract:ConLike}))) 
+      (HsPar 
        ({ <no location info> }
-        (HsLit 
-         (HsStringPrim 
-          (NoSourceText) "Peano"))))))) 
+        (HsApp 
+         ({ <no location info> }
+          (HsConLikeOut 
+           ({abstract:ConLike}))) 
+         ({ <no location info> }
+          (HsLit 
+           (HsStringPrim 
+            (NoSourceText) "Peano"))))))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (main:DumpTypecheckedAst.$tc'Zero{v rFM} [lidx] :: ghc-prim:GHC.Types.TyCon{tc 61Z})} 
         (HsVar 
          ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v rHO} [lidx] :: ghc-prim:GHC.Types.Module{tc 625})}))))) 
      ({ <no location info> }
-      (HsApp 
+      (HsPar 
        ({ <no location info> }
-        (HsConLikeOut 
-         ({abstract:ConLike}))) 
-       ({ <no location info> }
-        (HsLit 
-         (HsStringPrim 
-          (NoSourceText) "'Zero"))))))) 
+        (HsApp 
+         ({ <no location info> }
+          (HsConLikeOut 
+           ({abstract:ConLike}))) 
+         ({ <no location info> }
+          (HsLit 
+           (HsStringPrim 
+            (NoSourceText) "'Zero"))))))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (main:DumpTypecheckedAst.$tc'Succ{v rH3} [lidx] :: ghc-prim:GHC.Types.TyCon{tc 61Z})} 
         (HsVar 
          ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v rHO} [lidx] :: ghc-prim:GHC.Types.Module{tc 625})}))))) 
      ({ <no location info> }
-      (HsApp 
-       ({ <no location info> }
-        (HsConLikeOut 
-         ({abstract:ConLike}))) 
+      (HsPar 
        ({ <no location info> }
-        (HsLit 
-         (HsStringPrim 
-          (NoSourceText) "'Succ"))))))) 
+        (HsApp 
+         ({ <no location info> }
+          (HsConLikeOut 
+           ({abstract:ConLike}))) 
+         ({ <no location info> }
+          (HsLit 
+           (HsStringPrim 
+            (NoSourceText) "'Succ"))))))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (main:DumpTypecheckedAst.$trModule{v rHO} [lidx] :: ghc-prim:GHC.Types.Module{tc 625})} 
         (HsConLikeOut 
          ({abstract:ConLike}))) 
        ({ <no location info> }
+        (HsPar 
+         ({ <no location info> }
+          (HsApp 
+           ({ <no location info> }
+            (HsConLikeOut 
+             ({abstract:ConLike}))) 
+           ({ <no location info> }
+            (HsLit 
+             (HsStringPrim 
+              (NoSourceText) "main"))))))))) 
+     ({ <no location info> }
+      (HsPar 
+       ({ <no location info> }
         (HsApp 
          ({ <no location info> }
           (HsConLikeOut 
          ({ <no location info> }
           (HsLit 
            (HsStringPrim 
-            (NoSourceText) "main"))))))) 
-     ({ <no location info> }
-      (HsApp 
-       ({ <no location info> }
-        (HsConLikeOut 
-         ({abstract:ConLike}))) 
-       ({ <no location info> }
-        (HsLit 
-         (HsStringPrim 
-          (NoSourceText) "DumpTypecheckedAst"))))))) 
+            (NoSourceText) "DumpTypecheckedAst"))))))))) 
    (False))),
  ({ DumpTypecheckedAst.hs:11:1-23 }
   (AbsBinds 
index 7a6bbc5..bc2a4ed 100644 (file)
@@ -197,3 +197,7 @@ ppr047:
 .PHONY: ppr048
 ppr048:
        $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr048.hs
+
+.PHONY: T13199
+T13199:
+       $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13199.hs
diff --git a/testsuite/tests/printer/T13199.hs b/testsuite/tests/printer/T13199.hs
new file mode 100644 (file)
index 0000000..0bc36f3
--- /dev/null
@@ -0,0 +1,38 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+module Bug where
+
+class C a b c
+data B a b = B { aa :: a, bb :: b }
+
+-- Types requiring parens.
+$([d| instance C (Maybe a) (Maybe b) c
+    |])
+
+-- ---------------------------------------------------------------------
+-- Patterns requiring parens according to hsPatNeedsParens
+
+-- SigPatIn. What about SigPatOut?
+$([d| g (a :: (Int -> Int) -> Int) = True |])
+
+-- ViewPat
+$([d| h (id -> x) = True |])
+
+-- PrefixCon with non-null args
+$([d| f (Just (Just False)) = True |])
+
+-- InfixCon for ConPatIn
+$([d| i (B (a `B` c) d) = True |])
+
+-- RecCon does not
+$([d| j B { aa = a} = True |])
+
+
+$([d| k = id @(Maybe Int) |])
+
+$([d| l = case Just 'a' of Just a -> Just ((\x -> x) a) |])
diff --git a/testsuite/tests/printer/T13199.stdout b/testsuite/tests/printer/T13199.stdout
new file mode 100644 (file)
index 0000000..62e5659
--- /dev/null
@@ -0,0 +1,48 @@
+T13199.hs:(14,3)-(15,6): Splicing declarations
+    [d| instance C (Maybe a) (Maybe b) c |]
+  ======>
+    instance C (Maybe a) (Maybe b) c
+T13199.hs:21:3-44: Splicing declarations
+    [d| g (a :: (Int -> Int) -> Int) = True |]
+  ======>
+    g (a :: (Int -> Int) -> Int) = True
+T13199.hs:24:3-27: Splicing declarations
+    [d| h (id -> x) = True |] ======> h (id -> x) = True
+T13199.hs:27:3-37: Splicing declarations
+    [d| f (Just (Just False)) = True |]
+  ======>
+    f (Just (Just False)) = True
+T13199.hs:30:3-33: Splicing declarations
+    [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True
+T13199.hs:33:3-29: Splicing declarations
+    [d| j B {aa = a} = True |] ======> j B {aa = a} = True
+T13199.hs:36:3-28: Splicing declarations
+    [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int)
+T13199.hs:38:3-58: Splicing declarations
+    [d| l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } |]
+  ======>
+    l = case Just 'a' of { Just a -> Just ((\ x -> x) a) }
+T13199.ppr.hs:11:3-41: Splicing declarations
+    [d| instance C (Maybe a) (Maybe b) c |]
+  ======>
+    instance C (Maybe a) (Maybe b) c
+T13199.ppr.hs:12:3-44: Splicing declarations
+    [d| g (a :: (Int -> Int) -> Int) = True |]
+  ======>
+    g (a :: (Int -> Int) -> Int) = True
+T13199.ppr.hs:13:3-27: Splicing declarations
+    [d| h (id -> x) = True |] ======> h (id -> x) = True
+T13199.ppr.hs:14:3-37: Splicing declarations
+    [d| f (Just (Just False)) = True |]
+  ======>
+    f (Just (Just False)) = True
+T13199.ppr.hs:15:3-33: Splicing declarations
+    [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True
+T13199.ppr.hs:16:3-28: Splicing declarations
+    [d| j B {aa = a} = True |] ======> j B {aa = a} = True
+T13199.ppr.hs:17:3-28: Splicing declarations
+    [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int)
+T13199.ppr.hs:18:3-63: Splicing declarations
+    [d| l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } |]
+  ======>
+    l = case Just 'a' of { Just a -> Just ((\ x -> x) a) }
index e0cfcc2..3106f93 100644 (file)
@@ -46,3 +46,4 @@ test('Ppr045', ignore_stderr, run_command, ['$MAKE -s --no-print-directory ppr04
 test('Ppr046', ignore_stderr, run_command, ['$MAKE -s --no-print-directory ppr046'])
 test('Ppr047', expect_fail, run_command, ['$MAKE -s --no-print-directory ppr047'])
 test('Ppr048', ignore_stderr, run_command, ['$MAKE -s --no-print-directory ppr048'])
+test('T13199', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13199'])
index d2d1820..0ba1536 100644 (file)
@@ -5,6 +5,6 @@ T12530.hs:(8,3)-(15,6): Splicing declarations
         g = undefined @(_) @(a) |]
   ======>
     f :: Maybe Int -> Maybe Int
-    f = id @Maybe Int
+    f = id @(Maybe Int)
     g :: forall a. a
     g = undefined @_ @a