Fix bang deletion on ghc-8.2, Add testcase (fixes #116)

pull/121/head
Lennart Spitzner 2018-02-13 23:48:00 +01:00
parent d749c0da27
commit 91de1ca08c
2 changed files with 33 additions and 4 deletions

View File

@ -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 ()

View File

@ -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