[Git][ghc/ghc][master] Fix TH pretty-printing of nested GADTs, issue #23937
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Sep 12 08:34:09 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
f418f919 by Mario Blažević at 2023-09-12T04:33:45-04:00
Fix TH pretty-printing of nested GADTs, issue #23937
This commit fixes `Language.Haskell.TH.Ppr.pprint` so that it correctly
pretty-prints GADTs declarations contained within data family instances.
Fixes #23937
- - - - -
4 changed files:
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- + testsuite/tests/th/T23927.hs
- + testsuite/tests/th/T23927.stdout
- testsuite/tests/th/all.T
Changes:
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -392,7 +392,7 @@ pprPat _ (TypeP t) = parens $ text "type" <+> ppr t
instance Ppr Dec where
ppr = ppr_dec True
-ppr_dec :: Bool -- declaration on the toplevel?
+ppr_dec :: Bool -- ^ declaration on the toplevel?
-> Dec
-> Doc
ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs
@@ -400,12 +400,12 @@ ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
$$ where_clause ds
ppr_dec _ (TySynD t xs rhs)
= ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs
-ppr_dec _ (DataD ctxt t xs ksig cs decs)
- = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs
-ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
- = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs
-ppr_dec _ (TypeDataD t xs ksig cs)
- = ppr_type_data empty [] (Just t) (hsep (map ppr xs)) ksig cs []
+ppr_dec isTop (DataD ctxt t xs ksig cs decs)
+ = ppr_data isTop empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs
+ppr_dec isTop (NewtypeD ctxt t xs ksig c decs)
+ = ppr_newtype isTop empty ctxt (Just t) (sep (map ppr xs)) ksig c decs
+ppr_dec isTop (TypeDataD t xs ksig cs)
+ = ppr_type_data isTop empty [] (Just t) (hsep (map ppr xs)) ksig cs []
ppr_dec _ (ClassD ctxt c xs fds ds)
= text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds
@@ -427,13 +427,13 @@ ppr_dec isTop (DataFamilyD tc tvs kind)
maybeKind | (Just k') <- kind = dcolon <+> ppr k'
| otherwise = empty
ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs)
- = ppr_data (maybeInst <+> ppr_bndrs bndrs)
+ = ppr_data isTop (maybeInst <+> ppr_bndrs bndrs)
ctxt Nothing (ppr ty) ksig cs decs
where
maybeInst | isTop = text "instance"
| otherwise = empty
ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs)
- = ppr_newtype (maybeInst <+> ppr_bndrs bndrs)
+ = ppr_newtype isTop (maybeInst <+> ppr_bndrs bndrs)
ctxt Nothing (ppr ty) ksig c decs
where
maybeInst | isTop = text "instance"
@@ -494,27 +494,31 @@ ppr_overlap o = text $
Overlapping -> "{-# OVERLAPPING #-}"
Incoherent -> "{-# INCOHERENT #-}"
-ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
+ppr_data :: Bool -- ^ declaration on the toplevel?
+ -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
-> Doc
ppr_data = ppr_typedef "data"
-ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
+ppr_newtype :: Bool -- ^ declaration on the toplevel?
+ -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
-> Doc
-ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs
+ppr_newtype isTop maybeInst ctxt t argsDoc ksig c decs
+ = ppr_typedef "newtype" isTop maybeInst ctxt t argsDoc ksig [c] decs
-ppr_type_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
- -> Doc
+ppr_type_data :: Bool -- ^ declaration on the toplevel?
+ -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
+ -> Doc
ppr_type_data = ppr_typedef "type data"
-ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
-ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs
+ppr_typedef :: String -> Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
+ppr_typedef data_or_newtype isTop maybeInst ctxt t argsDoc ksig cs decs
= sep [text data_or_newtype <+> maybeInst
<+> pprCxt ctxt
<+> case t of
Just n -> pprName' Applied n <+> argsDoc
Nothing -> argsDoc
<+> ksigDoc <+> maybeWhere,
- nest nestDepth (vcat (pref $ map ppr cs)),
+ nest nestDepth (layout (pref $ map ppr cs)),
if null decs
then empty
else nest nestDepth
@@ -525,6 +529,10 @@ ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs
pref [] = [] -- No constructors; can't happen in H98
pref (d:ds) = (char '=' <+> d):map (bar <+>) ds
+ layout :: [Doc] -> Doc
+ layout | isGadtDecl && not isTop = braces . semiSepWith id
+ | otherwise = vcat
+
maybeWhere :: Doc
maybeWhere | isGadtDecl = text "where"
| otherwise = empty
=====================================
testsuite/tests/th/T23927.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs, TemplateHaskell, TypeFamilies #-}
+
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main =
+ runQ [d|
+ class C a where {data D a; f :: a -> D a};
+ instance C Int where {data D Int where {C1 :: Int -> D Int; C2 :: D Int}; f = C1}
+ |]
+ >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23927.stdout
=====================================
@@ -0,0 +1,7 @@
+class C_0 a_1
+ where {data D_2 a_1; f_3 :: a_1 -> D_2 a_1}
+instance C_0 GHC.Types.Int
+ where {data D_2 GHC.Types.Int where
+ {C1_4 :: GHC.Types.Int -> D_2 GHC.Types.Int;
+ C2_5 :: D_2 GHC.Types.Int};
+ f_3 = C1_4}
=====================================
testsuite/tests/th/all.T
=====================================
@@ -580,6 +580,7 @@ test('T22559a', normal, compile_fail, [''])
test('T22559b', normal, compile_fail, [''])
test('T22559c', normal, compile_fail, [''])
test('T23525', normal, compile, [''])
+test('T23927', normal, compile_and_run, [''])
test('CodeQ_HKD', normal, compile, [''])
test('T23748', normal, compile, [''])
test('T23796', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f418f919e3a009fd850a93fec79dbc25d297f6ae
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f418f919e3a009fd850a93fec79dbc25d297f6ae
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230912/1d5d01df/attachment-0001.html>
More information about the ghc-commits
mailing list