hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
.hlint.yaml
View File

@ -5,56 +5,12 @@
# This file contains a template configuration file, which is typically
# 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: Avoid lambda }
- ignore: { name: Eta reduce }
- ignore: { name: Move brackets to avoid $ }
- ignore: { name: Redundant <$> }
- ignore: { name: Redundant $ }
- ignore: { name: Redundant bang pattern }
- 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 record patterns }
- ignore: { name: Use second }
- ignore: { name: Use section }
- ignore: { name: Use sortOn }
- ignore: { name: Use sqrt }
- ignore: { name: Use tuple-section }
- ignore: { name: Use unless }
- ignore: { name: Use when }
- ignore: {name: "Redundant do"}
- ignore: {name: "Redundant return"}
- ignore: {name: "Use camelCase"}

4
src-literatetests/Main.hs
View File

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

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

31
src/Language/Haskell/Brittany/Internal/Backend.hs
View File

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

8
src/Language/Haskell/Brittany/Internal/BackendUtils.hs
View File

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

18
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

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

3
src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
View File

@ -36,11 +36,10 @@ import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.ExactPrintUtils
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 GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Name ( getOccString )
import GHC ( moduleName )
import GHC.Parser.Annotation ( AnnKeywordId(..) )
import Data.Data

10
src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
View File

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

8
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

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

2
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

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

8
src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
View File

@ -55,7 +55,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
(layoutWrapped lie x)
(layoutItems (splitFirstLast sortedNs))
where
nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName
nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
layoutItems FirstLastEmpty = docSetBaseY $ docLines
[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
-- other clever thing.
L _ (IEModuleContents _ n) -> moduleNameToText n
L _ (IEGroup _ _ _ ) -> Text.pack "@IEGroup"
L _ (IEDoc _ _ ) -> Text.pack "@IEDoc"
L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed"
L _ IEGroup{} -> Text.pack "@IEGroup"
L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where
moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)

2
src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

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

137
src/Language/Haskell/Brittany/Internal/Prelude.hs
View File

@ -14,44 +14,22 @@ import GHC.Types.Name.Reader as E ( RdrName )
import Data.Functor.Identity as E ( Identity(..) )
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.Word as E ( Word )
import Data.Word as E ( Word
, Word32
)
import Prelude as E ( Integer
, Float
, Double
)
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
, undefined
, Eq (..)
, Ord (..)
, Enum (..)
@ -101,8 +79,58 @@ import Prelude as E ( undefined
, Foldable
, 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.Foldable as E ( foldl'
@ -153,31 +181,6 @@ import Data.List.NonEmpty as E ( NonEmpty(..)
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
)
@ -222,14 +225,6 @@ import Control.Concurrent as E ( threadDelay
, forkOS
)
import Control.Concurrent.MVar as E ( newEmptyMVar
, newMVar
, putMVar
, readMVar
, takeMVar
, swapMVar
)
import Control.Exception as E ( evaluate
, bracket
, assert
@ -249,19 +244,11 @@ import Debug.Trace as E ( trace
import Foreign.ForeignPtr as E ( ForeignPtr
)
import Data.Monoid as E ( mconcat
, Monoid (..)
)
import Data.Bifunctor as E ( bimap )
import Data.Functor as E ( ($>) )
import Data.Function as E ( (&) )
import Data.Semigroup as E ( (<>)
, Semigroup(..)
)
import System.IO as E ( hFlush
, stdout
)
import Data.Typeable as E ( Typeable
)

12
src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
View File

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

7
src/Language/Haskell/Brittany/Internal/Types.hs
View File

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

16
src/Language/Haskell/Brittany/Main.hs
View File

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