Fix bang deletion on ghc-8.2, Add testcase (fixes #116)
parent
d749c0da27
commit
91de1ca08c
|
@ -513,3 +513,9 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ]
|
||||||
#test issue 70
|
#test issue 70
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
deriveFromJSON (unPrefix "assignPost") ''AssignmentPost
|
deriveFromJSON (unPrefix "assignPost") ''AssignmentPost
|
||||||
|
|
||||||
|
#test issue 116
|
||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
func = do
|
||||||
|
let !forced = some
|
||||||
|
pure ()
|
||||||
|
|
|
@ -192,16 +192,17 @@ layoutPatternBind
|
||||||
-> BriDocNumbered
|
-> BriDocNumbered
|
||||||
-> LMatch RdrName (LHsExpr RdrName)
|
-> LMatch RdrName (LHsExpr RdrName)
|
||||||
-> ToBriDocM BriDocNumbered
|
-> 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
|
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
|
||||||
let isInfix = isInfixMatch match
|
let isInfix = isInfixMatch match
|
||||||
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
|
let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr
|
||||||
(Just idStr, p1:pr) | isInfix -> docCols
|
patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
|
||||||
|
(Just idStr, p1 : pr) | isInfix -> docCols
|
||||||
ColPatternsFuncInfix
|
ColPatternsFuncInfix
|
||||||
( [appSep $ docForceSingleline p1, appSep $ docLit idStr]
|
( [appSep $ docForceSingleline p1, appSep $ docLit idStr]
|
||||||
++ (spacifyDocs $ docForceSingleline <$> pr)
|
++ (spacifyDocs $ docForceSingleline <$> pr)
|
||||||
)
|
)
|
||||||
(Just idStr, [] ) -> docLit idStr
|
(Just idStr, []) -> docLit idStr
|
||||||
(Just idStr, ps) ->
|
(Just idStr, ps) ->
|
||||||
docCols ColPatternsFuncPrefix
|
docCols ColPatternsFuncPrefix
|
||||||
$ appSep (docLit $ idStr)
|
$ appSep (docLit $ idStr)
|
||||||
|
@ -220,6 +221,28 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhs
|
||||||
mWhereDocs
|
mWhereDocs
|
||||||
hasComments
|
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
|
layoutPatternBindFinal
|
||||||
:: Maybe Text
|
:: Maybe Text
|
||||||
-> BriDocNumbered
|
-> BriDocNumbered
|
||||||
|
|
Loading…
Reference in New Issue