From 91de1ca08cc7e95c072a85fd98d11926ba4c0689 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 13 Feb 2018 23:48:00 +0100
Subject: [PATCH] Fix bang deletion on ghc-8.2, Add testcase (fixes #116)
---
src-literatetests/15-regressions.blt | 6 ++++
.../Brittany/Internal/Layouters/Decl.hs | 31 ++++++++++++++++---
2 files changed, 33 insertions(+), 4 deletions(-)
diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt
index 5c31ab6..dda42a0 100644
--- a/src-literatetests/15-regressions.blt
+++ b/src-literatetests/15-regressions.blt
@@ -513,3 +513,9 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ]
#test issue 70
{-# LANGUAGE TemplateHaskell #-}
deriveFromJSON (unPrefix "assignPost") ''AssignmentPost
+
+#test issue 116
+{-# LANGUAGE BangPatterns #-}
+func = do
+ let !forced = some
+ pure ()
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
index 8724291..c6ff4e0 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
@@ -192,16 +192,17 @@ layoutPatternBind
-> BriDocNumbered
-> LMatch RdrName (LHsExpr RdrName)
-> ToBriDocM BriDocNumbered
-layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do
+layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (GRHSs grhss whereBinds))) = do
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match
- patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
- (Just idStr, p1:pr) | isInfix -> docCols
+ let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr
+ patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
+ (Just idStr, p1 : pr) | isInfix -> docCols
ColPatternsFuncInfix
( [appSep $ docForceSingleline p1, appSep $ docLit idStr]
++ (spacifyDocs $ docForceSingleline <$> pr)
)
- (Just idStr, [] ) -> docLit idStr
+ (Just idStr, []) -> docLit idStr
(Just idStr, ps) ->
docCols ColPatternsFuncPrefix
$ appSep (docLit $ idStr)
@@ -220,6 +221,28 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhs
mWhereDocs
hasComments
+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
+fixPatternBindIdentifier
+ :: HsMatchContext (NameOrRdrName RdrName) -> Text -> Text
+fixPatternBindIdentifier ctx idStr = case ctx of
+ (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr
+ (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr
+ (FunRhs _ _ NoSrcStrict) -> idStr
+ (StmtCtxt ctx1 ) -> fixPatternBindIdentifier' ctx1
+ _ -> idStr
+ where
+ -- I have really no idea if this path ever occurs, but better safe than
+ -- risking another "drop bangpatterns" bugs.
+ fixPatternBindIdentifier' = \case
+ (PatGuard ctx1) -> fixPatternBindIdentifier ctx1 idStr
+ (ParStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1
+ (TransStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1
+ _ -> idStr
+#else /* ghc-8.0 */
+fixPatternBindIdentifier :: MatchFixity RdrName -> Text -> Text
+fixPatternBindIdentifier _ x = x
+#endif
+
layoutPatternBindFinal
:: Maybe Text
-> BriDocNumbered