Skip to content

Improve promoted type applications in GHC < 9. #1

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
ChickenProp wants to merge 1 commit into
base: master
Choose a base branch
from
Draft

Improve promoted type applications in GHC < 9. #1

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
31 changes: 25 additions & 6 deletions src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 "'["
Expand All @@ -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
Expand All @@ -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 $
Expand Down Expand Up @@ -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