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.
remotes/ChickenProp/promoted-type-applications-backport
Phil Hazelden 2022-11-01 12:17:59 +00:00
parent 434f9f8e49
commit 7b9437229b
1 changed files with 25 additions and 6 deletions

View File

@ -50,8 +50,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
#else /* ghc-8.6 */ #else /* ghc-8.6 */
Promoted -> docSeq Promoted -> docSeq
#endif #endif
[ docSeparator [ docTick
, docTick
, docWrapNode name $ docLit t , docWrapNode name $ docLit t
] ]
NotPromoted -> docWrapNode name $ docLit t NotPromoted -> docWrapNode name $ docLit t
@ -562,14 +561,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsRecTy{} -> -- TODO HsRecTy{} -> -- TODO
briDocByExactInlineOnly "HsRecTy{}" ltype briDocByExactInlineOnly "HsRecTy{}" ltype
HsExplicitListTy _ _ typs -> do 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 typDocs <- docSharedWrapper layoutType `mapM` typs
hasComments <- hasAnyCommentsBelow ltype hasComments <- hasAnyCommentsBelow ltype
let specialCommaSep = appSep $ docLit $ Text.pack " ,"
docAlt docAlt
[ docSeq [ docSeq
$ [docLit $ Text.pack "'["] $ [docLit $ Text.pack "'[", sepIfHeadPromoted]
++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
++ [docLit $ Text.pack "]"] ++ [sepIfHeadPromoted, docLit $ Text.pack "]"]
, case splitFirstLast typDocs of , case splitFirstLast typDocs of
FirstLastEmpty -> docSeq FirstLastEmpty -> docSeq
[ docLit $ Text.pack "'[" [ docLit $ Text.pack "'["
@ -578,7 +588,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
FirstLastSingleton e -> docAlt FirstLastSingleton e -> docAlt
[ docSeq [ docSeq
[ docLit $ Text.pack "'[" [ docLit $ Text.pack "'["
, sepIfHeadPromoted
, docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e
, sepIfHeadPromoted
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
, docSetBaseY $ docLines , docSetBaseY $ docLines
@ -593,7 +605,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
FirstLast e1 ems eN -> runFilteredAlternative $ do FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
$ [docLit $ Text.pack "'["] $ [docLit $ Text.pack "'[", sepIfHeadPromoted]
++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]))
++ [docLit $ Text.pack " ]"] ++ [docLit $ Text.pack " ]"]
addAlternative $ addAlternative $
@ -663,3 +675,10 @@ processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
, docForceSingleline $ doc , docForceSingleline $ doc
, docLit $ Text.pack ")" , 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