From 7b9437229b4b4af3fd6b0e4a286cf9a398481d07 Mon Sep 17 00:00:00 2001
From: Phil Hazelden <phazelden@triviumre.com>
Date: Tue, 1 Nov 2022 12:17:59 +0000
Subject: [PATCH] Improve promoted type applications in GHC < 9.
This is https://github.com/lspitzner/brittany/pull/376 backported so we
can use it on GHC 8.10.7.
Backporting the tests would have been a hassle so I didn't bother.
---
.../Brittany/Internal/Layouters/Type.hs | 31 +++++++++++++++----
1 file changed, 25 insertions(+), 6 deletions(-)
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
index 3437fcd..e8bad7c 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
@@ -50,8 +50,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
#else /* ghc-8.6 */
Promoted -> docSeq
#endif
- [ docSeparator
- , docTick
+ [ docTick
, docWrapNode name $ docLit t
]
NotPromoted -> docWrapNode name $ docLit t
@@ -562,14 +561,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsRecTy{} -> -- TODO
briDocByExactInlineOnly "HsRecTy{}" ltype
HsExplicitListTy _ _ typs -> do
+ -- `'['Foo]` isn't valid because it parses as a character. So if the list
+ -- starts with a promoted type var, we swap to `'[ 'Foo ]`.
+ let
+ sepIfHeadPromoted = case typs of
+ (L _ t) : _ | startsWithTick t -> docSeparator
+ _ -> docEmpty
+
+ -- When rendering on multiple lines, this causes commas to line up with the
+ -- opening bracket. Unfortunately it also adds unnecessary space when
+ -- rendering on a single line.
+ let specialCommaSep = appSep $ docLit $ Text.pack " ,"
+
typDocs <- docSharedWrapper layoutType `mapM` typs
hasComments <- hasAnyCommentsBelow ltype
- let specialCommaSep = appSep $ docLit $ Text.pack " ,"
docAlt
[ docSeq
- $ [docLit $ Text.pack "'["]
+ $ [docLit $ Text.pack "'[", sepIfHeadPromoted]
++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
- ++ [docLit $ Text.pack "]"]
+ ++ [sepIfHeadPromoted, docLit $ Text.pack "]"]
, case splitFirstLast typDocs of
FirstLastEmpty -> docSeq
[ docLit $ Text.pack "'["
@@ -578,7 +588,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
FirstLastSingleton e -> docAlt
[ docSeq
[ docLit $ Text.pack "'["
+ , sepIfHeadPromoted
, docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e
+ , sepIfHeadPromoted
, docLit $ Text.pack "]"
]
, docSetBaseY $ docLines
@@ -593,7 +605,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
- $ [docLit $ Text.pack "'["]
+ $ [docLit $ Text.pack "'[", sepIfHeadPromoted]
++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]))
++ [docLit $ Text.pack " ]"]
addAlternative $
@@ -663,3 +675,10 @@ processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
, docForceSingleline $ doc
, docLit $ Text.pack ")"
]
+
+-- | Determine if the type starts with a tick mark (single quote) when rendered.
+startsWithTick :: HsType pass -> Bool
+startsWithTick = \case
+ HsTyVar _ IsPromoted _ -> True
+ HsAppTy _ (L _ t) _ -> startsWithTick t
+ _ -> False