Fix many HLint warnings

pull/357/head
Taylor Fausak 2021-11-06 21:05:10 +00:00 committed by GitHub
parent 75cf5b83a3
commit 392e5b7569
16 changed files with 134 additions and 200 deletions

View File

@ -5,56 +5,12 @@
# This file contains a template configuration file, which is typically # This file contains a template configuration file, which is typically
# placed as .hlint.yaml in the root of your project # placed as .hlint.yaml in the root of your project
# Specify additional command line arguments
- arguments:
[ "--cross"
, "--threads=0"
]
- ignore: {name: "Use camelCase"}
- ignore: {name: "Redundant as"}
- ignore: {name: "Redundant do"}
- ignore: {name: "Redundant return"}
- ignore: {name: "Redundant guard", whithin: "lrdrNameToTextAnn"}
- ignore: { name: 'Use :' } - ignore: { name: 'Use :' }
- ignore: { name: Avoid lambda }
- ignore: { name: Eta reduce } - ignore: { name: Eta reduce }
- ignore: { name: Move brackets to avoid $ } - ignore: { name: Move brackets to avoid $ }
- ignore: { name: Redundant <$> }
- ignore: { name: Redundant $ } - ignore: { name: Redundant $ }
- ignore: { name: Redundant bang pattern }
- ignore: { name: Redundant bracket } - ignore: { name: Redundant bracket }
- ignore: { name: Redundant flip }
- ignore: { name: Redundant id }
- ignore: { name: Redundant if }
- ignore: { name: Redundant lambda }
- ignore: { name: Replace case with fromMaybe }
- ignore: { name: Use <=< }
- ignore: { name: Use <$> }
- ignore: { name: Use all }
- ignore: { name: Use and }
- ignore: { name: Use any }
- ignore: { name: Use concatMap }
- ignore: { name: Use const }
- ignore: { name: Use elem }
- ignore: { name: Use elemIndex }
- ignore: { name: Use fewer imports }
- ignore: { name: Use first }
- ignore: { name: Use fromLeft }
- ignore: { name: Use getContents }
- ignore: { name: Use if }
- ignore: { name: Use isNothing }
- ignore: { name: Use lambda-case }
- ignore: { name: Use mapM }
- ignore: { name: Use minimumBy }
- ignore: { name: Use newtype instead of data } - ignore: { name: Use newtype instead of data }
- ignore: { name: Use record patterns } - ignore: {name: "Redundant do"}
- ignore: { name: Use second } - ignore: {name: "Redundant return"}
- ignore: { name: Use section } - ignore: {name: "Use camelCase"}
- ignore: { name: Use sortOn }
- ignore: { name: Use sqrt }
- ignore: { name: Use tuple-section }
- ignore: { name: Use unless }
- ignore: { name: Use when }

View File

@ -94,8 +94,8 @@ main = do
fmap groupProcessor fmap groupProcessor
$ groupBy grouperG $ groupBy grouperG
$ filter (not . lineIsSpace) $ filter (not . lineIsSpace)
$ fmap lineMapper $ lineMapper
$ Text.lines input <$> Text.lines input
where where
groupProcessor :: [InputLine] -> (Text, [TestCase]) groupProcessor :: [InputLine] -> (Text, [TestCase])
groupProcessor = \case groupProcessor = \case

View File

@ -60,7 +60,7 @@ import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Indent import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC as GHC import qualified GHC
hiding ( parseModule ) hiding ( parseModule )
import GHC.Parser.Annotation ( AnnKeywordId(..) ) import GHC.Parser.Annotation ( AnnKeywordId(..) )
import GHC ( GenLocated(L) import GHC ( GenLocated(L)
@ -130,7 +130,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
, \s -> "{" `isPrefixOf` dropWhile (== ' ') s , \s -> "{" `isPrefixOf` dropWhile (== ' ') s
, Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")
$ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) $ fmap (\lconf -> (mempty { _conf_layout = lconf }, ""))
. either (\_ -> Nothing) Just . either (const Nothing) Just
. Data.Yaml.decodeEither' . Data.Yaml.decodeEither'
. Data.ByteString.Char8.pack . Data.ByteString.Char8.pack
-- TODO: use some proper utf8 encoder instead? -- TODO: use some proper utf8 encoder instead?
@ -299,7 +299,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
then then
( ews ( ews
, TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn
(TextL.pack "\n") (TextL.pack "\n")
outRaw outRaw
) )
@ -311,11 +311,9 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorMacroConfig{} = 5
let hasErrors = let hasErrors =
case if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack then not $ null errsWarns
of else 0 < maximum (-1 : fmap customErrOrder errsWarns)
False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
True -> not $ null errsWarns
if hasErrors if hasErrors
then throwE $ errsWarns then throwE $ errsWarns
else pure $ TextL.toStrict outputTextL else pure $ TextL.toStrict outputTextL
@ -402,7 +400,7 @@ parsePrintModuleTests conf filename input = do
then return $ pPrintModule moduleConf perItemConf anns parsedModule then return $ pPrintModule moduleConf perItemConf anns parsedModule
else lift else lift
$ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
if null $ filter (not . isErrorUnusedComment) errs if all isErrorUnusedComment errs
then pure $ TextL.toStrict $ ltext then pure $ TextL.toStrict $ ltext
else else
let let
@ -533,7 +531,7 @@ getDeclBindingNames (L _ decl) = case decl of
ppPreamble ppPreamble
:: GenLocated SrcSpan HsModule :: GenLocated SrcSpan HsModule
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _ _)) = do ppPreamble lmod@(L loc m@HsModule{}) = do
filteredAnns <- mAsk <&> \annMap -> filteredAnns <- mAsk <&> \annMap ->
Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap
-- Since ghc-exactprint adds annotations following (implicit) -- Since ghc-exactprint adds annotations following (implicit)

View File

@ -11,10 +11,12 @@ module Language.Haskell.Brittany.Internal.Backend where
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.State.Strict as StateS import qualified Control.Monad.Trans.State.Strict as StateS
import qualified Data.Either as Either
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
import qualified Data.IntMap.Lazy as IntMapL import qualified Data.IntMap.Lazy as IntMapL
import qualified Data.IntMap.Strict as IntMapS import qualified Data.IntMap.Strict as IntMapS
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
@ -171,7 +173,7 @@ layoutBriDocM = \case
-- layoutResetSepSpace -- layoutResetSepSpace
priors priors
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (not $ comment == "(" || comment == ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment let commentLines = Text.lines $ Text.pack $ comment
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)
@ -191,7 +193,7 @@ layoutBriDocM = \case
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let mToSpan = case mAnn of let mToSpan = case mAnn of
Just anns | keyword == Nothing -> Just anns Just anns | Maybe.isNothing keyword -> Just anns
Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just
annR annR
_ -> Nothing _ -> Nothing
@ -212,7 +214,7 @@ layoutBriDocM = \case
Nothing -> pure () Nothing -> pure ()
Just comments -> do Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (not $ comment == "(" || comment == ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment let commentLines = Text.lines $ Text.pack $ comment
-- evil hack for CPP: -- evil hack for CPP:
case comment of case comment of
@ -229,7 +231,7 @@ layoutBriDocM = \case
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
pure $ Map.lookup annKey m pure $ Map.lookup annKey m
let mComments = nonEmpty =<< extractAllComments <$> annMay let mComments = nonEmpty . extractAllComments =<< annMay
let semiCount = length [ () let semiCount = length [ ()
| Just ann <- [ annMay ] | Just ann <- [ annMay ]
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
@ -252,10 +254,10 @@ layoutBriDocM = \case
case mComments of case mComments of
Nothing -> do Nothing -> do
when shouldAddSemicolonNewlines $ do when shouldAddSemicolonNewlines $ do
[1..semiCount] `forM_` \_ -> layoutWriteNewline [1..semiCount] `forM_` const layoutWriteNewline
Just comments -> do Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (not $ comment == "(" || comment == ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack comment let commentLines = Text.lines $ Text.pack comment
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) 1 ('#':_) -> layoutMoveToCommentPos y (-999) 1
@ -351,13 +353,13 @@ briDocIsMultiLine briDoc = rec briDoc
BDBaseYPop bd -> rec bd BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> rec bd
BDPar _ _ _ -> True BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt" BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t | [_] <- Text.lines t -> False BDExternal _ _ _ t | [_] <- Text.lines t -> False
BDExternal _ _ _ _ -> True BDExternal{} -> True
BDPlain t | [_] <- Text.lines t -> False BDPlain t | [_] <- Text.lines t -> False
BDPlain _ -> True BDPlain _ -> True
BDAnnotationPrior _ bd -> rec bd BDAnnotationPrior _ bd -> rec bd
@ -453,7 +455,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs))
curX <- do curX <- do
state <- mGet state <- mGet
return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe
0 0
(_lstate_addSepSpace state) (_lstate_addSepSpace state)
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
@ -543,8 +545,8 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-- personal preference to not break alignment for those, even if -- personal preference to not break alignment for those, even if
-- multiline. Really, this should be configurable.. (TODO) -- multiline. Really, this should be configurable.. (TODO)
shouldBreakAfter :: BriDoc -> Bool shouldBreakAfter :: BriDoc -> Bool
shouldBreakAfter bd = if alignBreak shouldBreakAfter bd = alignBreak &&
then briDocIsMultiLine bd && case bd of briDocIsMultiLine bd && case bd of
(BDCols ColTyOpPrefix _) -> False (BDCols ColTyOpPrefix _) -> False
(BDCols ColPatternsFuncPrefix _) -> True (BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatternsFuncInfix _) -> True (BDCols ColPatternsFuncInfix _) -> True
@ -565,7 +567,6 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
(BDCols ColTuples _) -> False (BDCols ColTuples _) -> False
(BDCols ColOpPrefix _) -> False (BDCols ColOpPrefix _) -> False
_ -> True _ -> True
else False
mergeInfoBriDoc mergeInfoBriDoc
:: Bool :: Bool
@ -644,9 +645,7 @@ processInfo maxSpace m = \case
curX <- do curX <- do
state <- mGet state <- mGet
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
let spaceAdd = case _lstate_addSepSpace state of let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state
Nothing -> 0
Just i -> i
return $ case _lstate_curYOrAddNewline state of return $ case _lstate_curYOrAddNewline state of
Left i -> case _lstate_commentCol state of Left i -> case _lstate_commentCol state of
Nothing -> spaceAdd + i Nothing -> spaceAdd + i
@ -655,7 +654,7 @@ processInfo maxSpace m = \case
let colMax = min colMaxConf (curX + maxSpace) let colMax = min colMaxConf (curX + maxSpace)
-- tellDebugMess $ show curX -- tellDebugMess $ show curX
let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m
let maxCols2 = list <&> \e -> case e of let maxCols2 = list <&> \case
(_, ColInfo i _ _) -> (_, ColInfo i _ _) ->
let Just (_, ms, _) = IntMapS.lookup i m in sum ms let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(l, _) -> l (l, _) -> l

View File

@ -49,9 +49,7 @@ layoutWriteAppend t = do
replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"
Left{} -> do Left{} -> do
return () return ()
let spaces = case _lstate_addSepSpace state of let spaces = fromMaybe 0 $ _lstate_addSepSpace state
Just i -> i
Nothing -> 0
mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ')
mTell $ Text.Builder.fromText $ t mTell $ Text.Builder.fromText $ t
mModify $ \s -> s mModify $ \s -> s
@ -452,7 +450,7 @@ layoutWritePriorComments ast = do
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just priors -> do Just priors -> do
when (not $ null priors) $ layoutSetCommentCol unless (null priors) $ layoutSetCommentCol
priors `forM_` \( ExactPrint.Comment comment _ _ priors `forM_` \( ExactPrint.Comment comment _ _
, ExactPrint.DP (x, y) , ExactPrint.DP (x, y)
) -> do ) -> do
@ -484,7 +482,7 @@ layoutWritePostComments ast = do
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just posts -> do Just posts -> do
when (not $ null posts) $ layoutSetCommentCol unless (null posts) $ layoutSetCommentCol
posts `forM_` \( ExactPrint.Comment comment _ _ posts `forM_` \( ExactPrint.Comment comment _ _
, ExactPrint.DP (x, y) , ExactPrint.DP (x, y)
) -> do ) -> do

View File

@ -27,7 +27,7 @@ import Data.HList.HList
import GHC ( GenLocated(L) ) import GHC ( GenLocated(L) )
import qualified GHC.Driver.Session as GHC import qualified GHC.Driver.Session as GHC
import qualified GHC as GHC hiding (parseModule) import qualified GHC hiding (parseModule)
import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Driver.CmdLine as GHC import qualified GHC.Driver.CmdLine as GHC
@ -78,11 +78,11 @@ parseModuleWithCpp cpp opts args fp dynCheck =
-- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063. -- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063.
void $ lift $ GHC.setSessionDynFlags dflags1 void $ lift $ GHC.setSessionDynFlags dflags1
dflags2 <- lift $ ExactPrint.initDynFlags fp dflags2 <- lift $ ExactPrint.initDynFlags fp
when (not $ null leftover) unless (null leftover)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: leftover flags: " $ "when parsing ghc flags: leftover flags: "
++ show (leftover <&> \(L _ s) -> s) ++ show (leftover <&> \(L _ s) -> s)
when (not $ null warnings) unless (null warnings)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: " $ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> warnExtractorCompat) ++ show (warnings <&> warnExtractorCompat)
@ -110,11 +110,11 @@ parseModuleFromString args fp dynCheck str =
dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str
(dflags1, leftover, warnings) <- lift (dflags1, leftover, warnings) <- lift
$ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)
when (not $ null leftover) unless (null leftover)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: leftover flags: " $ "when parsing ghc flags: leftover flags: "
++ show (leftover <&> \(L _ s) -> s) ++ show (leftover <&> \(L _ s) -> s)
when (not $ null warnings) unless (null warnings)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: " $ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> warnExtractorCompat) ++ show (warnings <&> warnExtractorCompat)
@ -135,7 +135,7 @@ commentAnnFixTransformGlob ast = do
let nodes = SYB.everything (<>) extract ast let nodes = SYB.everything (<>) extract ast
let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap = Map.fromListWith annsMap = Map.fromListWith
(flip const) (const id)
[ (GHC.realSrcSpanEnd span, annKey) [ (GHC.realSrcSpanEnd span, annKey)
| (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
] ]
@ -174,8 +174,8 @@ commentAnnFixTransformGlob ast = do
in in
Map.insert annKey2 ann2' anns Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node. _ -> return True -- retain comment at current node.
priors' <- flip filterM priors processCom priors' <- filterM processCom priors
follows' <- flip filterM follows $ processCom follows' <- filterM processCom follows
assocs' <- flip filterM assocs $ \case assocs' <- flip filterM assocs $ \case
(ExactPrint.AnnComment com, dp) -> processCom (com, dp) (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
_ -> return True _ -> return True
@ -286,7 +286,7 @@ foldedAnnKeys ast = SYB.everything
( \x -> maybe ( \x -> maybe
Set.empty Set.empty
Set.singleton Set.singleton
[ SYB.gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x) | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
-- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- for some reason, ghc-8.8 has forgotten how to infer the type of l,

View File

@ -36,11 +36,10 @@ import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.ExactPrintUtils
import GHC.Types.Name.Reader ( RdrName(..) ) import GHC.Types.Name.Reader ( RdrName(..) )
import GHC ( Located, GenLocated(L), moduleNameString ) import GHC ( Located, GenLocated(L), moduleName, moduleNameString )
import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Name ( getOccString ) import GHC.Types.Name ( getOccString )
import GHC ( moduleName )
import GHC.Parser.Annotation ( AnnKeywordId(..) ) import GHC.Parser.Annotation ( AnnKeywordId(..) )
import Data.Data import Data.Data

View File

@ -37,13 +37,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
docWrapNode ltycl $ do docWrapNode ltycl $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- fmap return $ createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
-- headDoc <- fmap return $ docSeq -- headDoc <- fmap return $ docSeq
-- [ appSep $ docLitS "newtype") -- [ appSep $ docLitS "newtype")
-- , appSep $ docLit nameStr -- , appSep $ docLit nameStr
-- , appSep tyVarLine -- , appSep tyVarLine
-- ] -- ]
rhsDoc <- fmap return $ createDetailsDoc consNameStr details rhsDoc <- return <$> createDetailsDoc consNameStr details
createDerivingPar mDerivs $ docSeq createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "newtype" [ appSep $ docLitS "newtype"
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -62,7 +62,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
docWrapNode ltycl $ do docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
tyVarLine <- fmap return $ createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
createDerivingPar mDerivs $ docSeq createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, lhsContextDoc , lhsContextDoc
@ -79,14 +79,14 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- fmap return $ createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
forallDocMay <- case createForallDoc qvars of forallDocMay <- case createForallDoc qvars of
Nothing -> pure Nothing Nothing -> pure Nothing
Just x -> Just . pure <$> x Just x -> Just . pure <$> x
rhsContextDocMay <- case mRhsContext of rhsContextDocMay <- case mRhsContext of
Nothing -> pure Nothing Nothing -> pure Nothing
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
rhsDoc <- fmap return $ createDetailsDoc consNameStr details rhsDoc <- return <$> createDetailsDoc consNameStr details
consDoc <- fmap pure consDoc <- fmap pure
$ docNonBottomSpacing $ docNonBottomSpacing
$ case (forallDocMay, rhsContextDocMay) of $ case (forallDocMay, rhsContextDocMay) of

View File

@ -162,7 +162,7 @@ layoutBind lbind@(L _ bind) = case bind of
patDocs <- colsWrapPat =<< layoutPat pat patDocs <- colsWrapPat =<< layoutPat pat
clauseDocs <- layoutGrhs `mapM` grhss clauseDocs <- layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds mWhereDocs <- layoutLocalBinds whereBinds
let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lbind, d) -- TODO: is this the right AnnKey? let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
hasComments <- hasAnyCommentsBelow lbind hasComments <- hasAnyCommentsBelow lbind
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing
@ -206,7 +206,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
let unordered = let unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ] [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ] ++ [ BagSig s | s <- sigs ]
ordered = sortBy (comparing $ ExactPrint.rs . bindOrSigtoSrcSpan) unordered ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
docs <- docWrapNode lbinds $ join <$> ordered `forM` \case docs <- docWrapNode lbinds $ join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b BagBind b -> either id return <$> layoutBind b
BagSig s -> return <$> layoutSig s BagSig s -> return <$> layoutSig s
@ -271,7 +271,7 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
$ (List.intersperse docSeparator $ docForceSingleline <$> ps) $ (List.intersperse docSeparator $ docForceSingleline <$> ps)
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds mWhereDocs <- layoutLocalBinds whereBinds
let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lmatch, d) let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
let alignmentToken = if null pats then Nothing else funId let alignmentToken = if null pats then Nothing else funId
hasComments <- hasAnyCommentsBelow lmatch hasComments <- hasAnyCommentsBelow lmatch
layoutPatternBindFinal alignmentToken layoutPatternBindFinal alignmentToken
@ -331,7 +331,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
-- be shared between alternatives. -- be shared between alternatives.
wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of
Nothing -> return $ [] Nothing -> return $ []
Just (annKeyWhere, [w]) -> fmap (pure . pure) $ docAlt Just (annKeyWhere, [w]) -> pure . pure <$> docAlt
[ docEnsureIndent BrIndentRegular [ docEnsureIndent BrIndentRegular
$ docSeq $ docSeq
[ docLit $ Text.pack "where" [ docLit $ Text.pack "where"

View File

@ -595,7 +595,7 @@ layoutExpr lexpr@(L _ expr) = do
expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc1 <- docSharedWrapper layoutExpr exp1
-- We jump through some ugly hoops here to ensure proper sharing. -- We jump through some ugly hoops here to ensure proper sharing.
hasComments <- hasAnyCommentsBelow lexpr hasComments <- hasAnyCommentsBelow lexpr
mBindDocs <- fmap (fmap (fmap pure)) $ layoutLocalBinds binds mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds
let let
ifIndentFreeElse :: a -> a -> a ifIndentFreeElse :: a -> a -> a
ifIndentFreeElse x y = ifIndentFreeElse x y =

View File

@ -55,7 +55,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
(layoutWrapped lie x) (layoutWrapped lie x)
(layoutItems (splitFirstLast sortedNs)) (layoutItems (splitFirstLast sortedNs))
where where
nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
layoutItems FirstLastEmpty = docSetBaseY $ docLines layoutItems FirstLastEmpty = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR]
@ -208,9 +208,9 @@ lieToText = \case
-- Need to check, and either put them at the top (for module) or do some -- Need to check, and either put them at the top (for module) or do some
-- other clever thing. -- other clever thing.
L _ (IEModuleContents _ n) -> moduleNameToText n L _ (IEModuleContents _ n) -> moduleNameToText n
L _ (IEGroup _ _ _ ) -> Text.pack "@IEGroup" L _ IEGroup{} -> Text.pack "@IEGroup"
L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" L _ IEDoc{} -> Text.pack "@IEDoc"
L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where where
moduleNameToText :: Located ModuleName -> Text moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)

View File

@ -645,7 +645,7 @@ getBinders x = case x of
XHsForAllTelescope _ -> [] XHsForAllTelescope _ -> []
withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass
withoutSpecificity = fmap $ \ x -> case x of withoutSpecificity = fmap $ \case
UserTyVar a _ c -> UserTyVar a () c UserTyVar a _ c -> UserTyVar a () c
KindedTyVar a _ c d -> KindedTyVar a () c d KindedTyVar a _ c d -> KindedTyVar a () c d
XTyVarBndr a -> XTyVarBndr a XTyVarBndr a -> XTyVarBndr a

View File

@ -14,44 +14,22 @@ import GHC.Types.Name.Reader as E ( RdrName )
import Data.Functor.Identity as E ( Identity(..) ) import Data.Functor.Identity as E ( Identity(..) )
import Control.Concurrent.Chan as E ( Chan ) import Control.Concurrent.Chan as E ( Chan )
import Control.Concurrent.MVar as E ( MVar ) import Control.Concurrent.MVar as E ( MVar
, newEmptyMVar
, newMVar
, putMVar
, readMVar
, takeMVar
, swapMVar
)
import Data.Int as E ( Int ) import Data.Int as E ( Int )
import Data.Word as E ( Word ) import Data.Word as E ( Word
, Word32
)
import Prelude as E ( Integer import Prelude as E ( Integer
, Float , Float
, Double , Double
) , undefined
import Control.Monad.ST as E ( ST )
import Data.Bool as E ( Bool(..) )
import Data.Char as E ( Char )
import Data.Either as E ( Either(..) )
import Data.IORef as E ( IORef )
import Data.Maybe as E ( Maybe(..) )
import Data.Monoid as E ( Endo(..)
, All(..)
, Any(..)
, Sum(..)
, Product(..)
, Alt(..)
)
import Data.Ord as E ( Ordering(..)
, Down(..)
)
import Data.Ratio as E ( Ratio
, Rational
)
import Data.String as E ( String )
import Data.Void as E ( Void )
import System.IO as E ( IO )
import Data.Proxy as E ( Proxy(..) )
import Data.Sequence as E ( Seq )
import Data.Map as E ( Map )
import Data.Set as E ( Set )
import Data.Text as E ( Text )
import Prelude as E ( undefined
, Eq (..) , Eq (..)
, Ord (..) , Ord (..)
, Enum (..) , Enum (..)
@ -101,8 +79,58 @@ import Prelude as E ( undefined
, Foldable , Foldable
, Traversable , Traversable
) )
import Control.Monad.ST as E ( ST )
import Data.Bool as E ( Bool(..) )
import Data.Char as E ( Char
, ord
, chr
)
import Data.Either as E ( Either(..)
, either
)
import Data.IORef as E ( IORef )
import Data.Maybe as E ( Maybe(..)
, fromMaybe
, maybe
, listToMaybe
, maybeToList
, catMaybes
)
import Data.Monoid as E ( Endo(..)
, All(..)
, Any(..)
, Sum(..)
, Product(..)
, Alt(..)
, mconcat
, Monoid (..)
)
import Data.Ord as E ( Ordering(..)
, Down(..)
, comparing
)
import Data.Ratio as E ( Ratio
, Rational
, (%)
, numerator
, denominator
)
import Data.String as E ( String )
import Data.Void as E ( Void )
import System.IO as E ( IO
, hFlush
, stdout
)
import Data.Proxy as E ( Proxy(..) )
import Data.Sequence as E ( Seq )
import Data.Map as E ( Map )
import Data.Set as E ( Set )
import Data.Text as E ( Text )
import Data.Function as E ( fix import Data.Function as E ( fix
, (&)
) )
import Data.Foldable as E ( foldl' import Data.Foldable as E ( foldl'
@ -153,31 +181,6 @@ import Data.List.NonEmpty as E ( NonEmpty(..)
import Data.Tuple as E ( swap import Data.Tuple as E ( swap
) )
import Data.Char as E ( ord
, chr
)
import Data.Maybe as E ( fromMaybe
, maybe
, listToMaybe
, maybeToList
, catMaybes
)
import Data.Word as E ( Word32
)
import Data.Ord as E ( comparing
)
import Data.Either as E ( either
)
import Data.Ratio as E ( (%)
, numerator
, denominator
)
import Text.Read as E ( readMaybe import Text.Read as E ( readMaybe
) )
@ -222,14 +225,6 @@ import Control.Concurrent as E ( threadDelay
, forkOS , forkOS
) )
import Control.Concurrent.MVar as E ( newEmptyMVar
, newMVar
, putMVar
, readMVar
, takeMVar
, swapMVar
)
import Control.Exception as E ( evaluate import Control.Exception as E ( evaluate
, bracket , bracket
, assert , assert
@ -249,19 +244,11 @@ import Debug.Trace as E ( trace
import Foreign.ForeignPtr as E ( ForeignPtr import Foreign.ForeignPtr as E ( ForeignPtr
) )
import Data.Monoid as E ( mconcat
, Monoid (..)
)
import Data.Bifunctor as E ( bimap ) import Data.Bifunctor as E ( bimap )
import Data.Functor as E ( ($>) ) import Data.Functor as E ( ($>) )
import Data.Function as E ( (&) )
import Data.Semigroup as E ( (<>) import Data.Semigroup as E ( (<>)
, Semigroup(..) , Semigroup(..)
) )
import System.IO as E ( hFlush
, stdout
)
import Data.Typeable as E ( Typeable import Data.Typeable as E ( Typeable
) )

View File

@ -206,8 +206,7 @@ transformAlts =
(zip spacings alts (zip spacings alts
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
( hasSpace1 lconf acp vs && lineCheck vs, bd)) ( hasSpace1 lconf acp vs && lineCheck vs, bd))
id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) rec
$ rec
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
$ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) ->
@ -233,8 +232,7 @@ transformAlts =
&& any lineCheck vs, bd)) && any lineCheck vs, bd))
let checkedOptions :: [Maybe (Int, BriDocNumbered)] = let checkedOptions :: [Maybe (Int, BriDocNumbered)] =
zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ])
id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) rec
$ rec
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
$ Data.List.Extra.firstJust (fmap snd) checkedOptions $ Data.List.Extra.firstJust (fmap snd) checkedOptions
@ -325,7 +323,7 @@ transformAlts =
LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do
acp <- mGet acp <- mGet
mSet $ acp { _acp_line = _acp_line acp + i } mSet $ acp { _acp_line = _acp_line acp + i }
LineModeValid (VerticalSpacing _ _ _) -> error "processSpacingSimple par" LineModeValid VerticalSpacing{} -> error "processSpacingSimple par"
_ -> error "ghc exhaustive check is insufficient" _ -> error "ghc exhaustive check is insufficient"
hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool
hasSpace1 _ _ LineModeInvalid = False hasSpace1 _ _ LineModeInvalid = False
@ -630,9 +628,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDFLit t -> BDFLit t ->
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
BDFSeq list -> BDFSeq list ->
fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDFCols _sig list -> BDFCols _sig list ->
fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDFSeparator -> BDFSeparator ->
return $ [VerticalSpacing 1 VerticalSpacingParNone False] return $ [VerticalSpacing 1 VerticalSpacingParNone False]
BDFAddBaseY indent bd -> do BDFAddBaseY indent bd -> do

View File

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
@ -19,7 +18,7 @@ import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.Data import qualified Data.Data
import qualified Data.Strict.Maybe as Strict import qualified Data.Strict.Maybe as Strict
import qualified Safe as Safe import qualified Safe
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
@ -423,7 +422,7 @@ briDocSeqSpine = \case
BDIndentLevelPushCur bd -> briDocSeqSpine bd BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> () BDExternal{} -> ()
BDPlain{} -> () BDPlain{} -> ()
@ -431,7 +430,7 @@ briDocSeqSpine = \case
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd BDForceSingleline bd -> briDocSeqSpine bd

View File

@ -240,7 +240,7 @@ mainCmdParser helpDesc = do
outputPaths outputPaths
if checkMode if checkMode
then when (any (== Changes) (Data.Either.rights results)) then when (Changes `elem` (Data.Either.rights results))
$ System.Exit.exitWith (System.Exit.ExitFailure 1) $ System.Exit.exitWith (System.Exit.ExitFailure 1)
else case results of else case results of
xs | all Data.Either.isRight xs -> pure () xs | all Data.Either.isRight xs -> pure ()
@ -310,7 +310,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let hackTransform = if hackAroundIncludes && not exactprintOnly let hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines' then List.intercalate "\n" . fmap hackF . lines'
else id else id
inputString <- liftIO $ System.IO.hGetContents System.IO.stdin inputString <- liftIO System.IO.getContents
parseRes <- liftIO $ parseModuleFromString ghcOptions parseRes <- liftIO $ parseModuleFromString ghcOptions
"stdin" "stdin"
cppCheckFunc cppCheckFunc
@ -376,8 +376,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let out = TextL.toStrict $ if hackAroundIncludes let out = TextL.toStrict $ if hackAroundIncludes
then then
TextL.intercalate (TextL.pack "\n") TextL.intercalate (TextL.pack "\n")
$ fmap hackF $ hackF
$ TextL.splitOn (TextL.pack "\n") outRaw <$> TextL.splitOn (TextL.pack "\n") outRaw
else outRaw else outRaw
out' <- if moduleConf & _conf_obfuscate & confUnpack out' <- if moduleConf & _conf_obfuscate & confUnpack
then lift $ obfuscate out then lift $ obfuscate out
@ -389,7 +389,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorMacroConfig{} = 5
when (not $ null errsWarns) $ do unless (null errsWarns) $ do
let groupedErrsWarns = let groupedErrsWarns =
Data.List.Extra.groupOn customErrOrder Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder $ List.sortOn customErrOrder
@ -442,9 +442,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
-- adds some override? -- adds some override?
let let
hasErrors = hasErrors =
case config & _conf_errorHandling & _econf_Werror & confUnpack of if config & _conf_errorHandling & _econf_Werror & confUnpack
False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) then not $ null errsWarns
True -> not $ null errsWarns else 0 < maximum (-1 : fmap customErrOrder errsWarns)
outputOnErrs = outputOnErrs =
config config
& _conf_errorHandling & _conf_errorHandling