hlint 2.2.7 → 2.2.8
raw patch · 16 files changed
+115/−846 lines, 16 filesdep +file-embeddep +ghc-lib-parser-exdep +utf8-stringdep −mtldep −sybPVP ok
version bump matches the API change (PVP)
Dependencies added: file-embed, ghc-lib-parser-ex, utf8-string
Dependencies removed: mtl, syb
API changes (from Hackage documentation)
Files
- CHANGES.txt +12/−0
- data/hlint.yaml +29/−12
- hlint.cabal +5/−6
- src/CmdLine.hs +7/−5
- src/EmbedData.hs +20/−0
- src/GHC/Util.hs +17/−30
- src/GHC/Util/DynFlags.hs +1/−25
- src/GHC/Util/Language/Haskell/GHC/ExactPrint/Types.hs +0/−377
- src/GHC/Util/Refact/Fixity.hs +0/−204
- src/GHC/Util/Refact/Utils.hs +0/−166
- src/HLint.hs +6/−7
- src/HSE/All.hs +3/−3
- src/Hint/Extensions.hs +5/−0
- src/Hint/Lambda.hs +4/−1
- src/Language/Haskell/HLint4.hs +3/−5
- src/Report.hs +3/−5
CHANGES.txt view
@@ -1,5 +1,17 @@ Changelog for HLint (* = breaking change) +2.2.8, released 2020-01-22+ #802, suggest lambda instead of lambda-case for single alts+ #811, add some foldMap/map hints+ #822, generalise the map/zipWith hint+ #824, embed HLint data files using TemplateHaskell+ #826, remove curry/uncurry on lambdas+ #820, make some hints work in more situations+ Reenable PackageImport unused extension detectection+ #821, warn on unless/not+ #821, avoid curry/uncurry and vice versa+ #819, fix a lot of bifunctor hints+ #812, add some rules for generalised and/or/any/all 2.2.7, released 2020-01-11 #818, fix incorrect unused LANGUAGE BangPatterns hint 2.2.6, released 2020-01-09
data/hlint.yaml view
@@ -169,8 +169,7 @@ - hint: {lhs: length x /= 0, rhs: not (null x), note: IncreasesLaziness, name: Use null} - hint: {lhs: 0 /= length x, rhs: not (null x), note: IncreasesLaziness, name: Use null} - hint: {lhs: "\\x -> [x]", rhs: "(:[])", name: "Use :"}- - warn: {lhs: map (uncurry f) (zip x y), rhs: zipWith f x y}- - hint: {lhs: map f (zip x y), rhs: zipWith (curry f) x y, side: isVar f}+ - hint: {lhs: map f (zip x y), rhs: zipWith (curry f) x y, side: not (isApp f)} - warn: {lhs: not (elem x y), rhs: notElem x y} - hint: {lhs: foldr f z (map g x), rhs: foldr (f . g) z x, name: Fuse foldr/map} - warn: {lhs: "x ++ concatMap (' ':) y", rhs: "unwords (x:y)"}@@ -231,6 +230,10 @@ - warn: {lhs: sequenceA_ (map f x), rhs: traverse_ f x} - warn: {lhs: sequenceA_ (fmap f x), rhs: traverse_ f x} - warn: {lhs: foldMap id, rhs: fold}+ - warn: {lhs: fold (fmap f x), rhs: foldMap f x}+ - warn: {lhs: fold (map f x), rhs: foldMap f x}+ - warn: {lhs: foldMap f (fmap g x), rhs: foldMap (f . g) x}+ - warn: {lhs: foldMap f (map g x), rhs: foldMap (f . g) x} # BY @@ -278,7 +281,11 @@ - hint: {lhs: "\\x y -> f (x,y)", rhs: curry f} - hint: {lhs: "\\(x,y) -> f x y", rhs: uncurry f, note: IncreasesLaziness} - warn: {lhs: f (fst p) (snd p), rhs: uncurry f p}- - warn: {lhs: ($) . f, rhs: f, name: Redundant $}+ - warn: {lhs: "uncurry (\\x y -> z)", rhs: "\\(x,y) -> z"}+ - warn: {lhs: "curry (\\(x,y) -> z)", rhs: "\\x y -> z"}+ - warn: {lhs: uncurry (curry f), rhs: f}+ - warn: {lhs: curry (uncurry f), rhs: f}+ - warn: {lhs: ($) (f x), rhs: f x, name: Redundant $} - warn: {lhs: (f $), rhs: f, name: Redundant $} - warn: {lhs: (Data.Function.& f), rhs: f, name: Redundant Data.Function.&} - hint: {lhs: \x -> y, rhs: const y, side: isAtom y && not (isWildcard y)}@@ -351,13 +358,13 @@ - warn: {lhs: bimap id id, rhs: id} - warn: {lhs: first f (second g x), rhs: bimap f g x} - warn: {lhs: second g (first f x), rhs: bimap f g x}- - warn: {lhs: first f1 (first f2 x), rhs: first (f1 . f2) x}- - warn: {lhs: second g1 (second g2 x), rhs: second (g1 . g2) x}- - warn: {lhs: bimap f1 f2 (bimap g1 g2 x), rhs: bimap (f1 . f2) (g1 . g2) x}- - warn: {lhs: first f1 (bimap f2 g x), rhs: bimap (f1 . f2) g x}- - warn: {lhs: second g1 (bimap f g2 x), rhs: bimap f (g1 . g2) x}- - warn: {lhs: bimap f1 g (first f2 x), rhs: bimap (f1 . f2) g x}- - warn: {lhs: bimap f g1 (second g2 x), rhs: bimap f (g1 . g2) x}+ - warn: {lhs: first f (first g x), rhs: first (f . g) x}+ - warn: {lhs: second f (second g x), rhs: second (f . g) x}+ - warn: {lhs: bimap f h (bimap g i x), rhs: bimap (f . g) (h . i) x}+ - warn: {lhs: first f (bimap g h x), rhs: bimap (f . g) h x}+ - warn: {lhs: second g (bimap f h x), rhs: bimap f (g . h) x}+ - warn: {lhs: bimap f h (first g x), rhs: bimap (f . g) h x}+ - warn: {lhs: bimap f g (second h x), rhs: bimap f (g . h) x} - hint: {lhs: "\\(x,y) -> (f x, g y)", rhs: Data.Bifunctor.bimap f g, note: IncreasesLaziness} - hint: {lhs: "\\(x,y) -> (f x,y)", rhs: Data.Bifunctor.first f, note: IncreasesLaziness} - hint: {lhs: "\\(x,y) -> (x,f y)", rhs: Data.Bifunctor.second f, note: IncreasesLaziness}@@ -414,6 +421,7 @@ - hint: {lhs: flip forM, rhs: mapM} - hint: {lhs: flip forM_, rhs: mapM_} - warn: {lhs: when (not x), rhs: unless x}+ - warn: {lhs: unless (not x), rhs: when x} - warn: {lhs: x >>= id, rhs: Control.Monad.join x} - warn: {lhs: id =<< x, rhs: Control.Monad.join x} - warn: {lhs: id =<< x, rhs: Control.Monad.join x}@@ -517,7 +525,7 @@ - warn: {lhs: if isNothing x then y else f (fromJust x), rhs: maybe y f x} - warn: {lhs: if isJust x then f (fromJust x) else y, rhs: maybe y f x} - warn: {lhs: maybe Nothing (Just . f), rhs: fmap f}- - hint: {lhs: map fromJust . filter isJust , rhs: Data.Maybe.catMaybes}+ - hint: {lhs: map fromJust (filter isJust x), rhs: Data.Maybe.catMaybes x} - warn: {lhs: x == Nothing , rhs: isNothing x} - warn: {lhs: Nothing == x , rhs: isNothing x} - warn: {lhs: x /= Nothing , rhs: Data.Maybe.isJust x}@@ -789,9 +797,17 @@ - package base rules: - warn: {lhs: maybe mempty, rhs: foldMap}+ - warn: {lhs: maybe False, rhs: any}+ - warn: {lhs: maybe True, rhs: all} - warn: {lhs: either (const mempty), rhs: foldMap}+ - warn: {lhs: either (const False), rhs: any}+ - warn: {lhs: either (const True), rhs: all} - warn: {lhs: Data.Maybe.fromMaybe mempty, rhs: Data.Foldable.fold}+ - warn: {lhs: Data.Maybe.fromMaybe False, rhs: or}+ - warn: {lhs: Data.Maybe.fromMaybe True, rhs: and} - warn: {lhs: Data.Either.fromRight mempty, rhs: Data.Foldable.fold}+ - warn: {lhs: Data.Either.fromRight False, rhs: or}+ - warn: {lhs: Data.Either.fromRight True, rhs: and} - warn: {lhs: if f x then Just x else Nothing, rhs: mfilter f (Just x)} - hint: {lhs: maybe (pure ()), rhs: traverse_, note: IncreasesLaziness} - hint: {lhs: fromMaybe (pure ()), rhs: sequenceA_, note: IncreasesLaziness}@@ -866,7 +882,8 @@ # yes = if foo then stuff else return () -- Control.Monad.when foo stuff # yes = foo $ \(a, b) -> (a, y + b) -- Data.Bifunctor.second ((+) y) # no = foo $ \(a, b) -> (a, a + b)-# yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (+) [1 .. 5] [6 .. 10]+# yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (curry (uncurry (+))) [1 .. 5] [6 .. 10]+# yes = curry (uncurry (+)) -- (+) # no = do iter <- textBufferGetTextIter tb ; textBufferSelectRange tb iter iter # no = flip f x $ \y -> y*y+y # no = \x -> f x (g x)
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hlint-version: 2.2.7+version: 2.2.8 license: BSD3 license-file: LICENSE category: Development@@ -54,6 +54,8 @@ base == 4.*, process, filepath, directory, containers, unordered-containers, vector, text, bytestring, transformers,+ file-embed,+ utf8-string, data-default >= 0.3, cpphs >= 1.20.1, cmdargs >= 0.10,@@ -66,8 +68,7 @@ refact >= 0.3, aeson >= 1.1.2.0, filepattern >= 0.1.1,- syb >= 0.7,- mtl >= 2.2.2+ ghc-lib-parser-ex == 8.8.2 if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0) build-depends: ghc == 8.8.*,@@ -100,6 +101,7 @@ Refact Timing CC+ EmbedData Config.Compute Config.Haskell Config.Read@@ -121,9 +123,6 @@ GHC.Util.SrcLoc GHC.Util.W GHC.Util.DynFlags- GHC.Util.Language.Haskell.GHC.ExactPrint.Types- GHC.Util.Refact.Utils- GHC.Util.Refact.Fixity GHC.Util.RdrName GHC.Util.Scope GHC.Util.Unify
src/CmdLine.hs view
@@ -30,6 +30,7 @@ import System.Process import System.FilePattern +import EmbedData import Util import Paths_hlint import Data.Version@@ -215,14 +216,15 @@ -- * If someone passes cmdWithHints, only look at files they explicitly request -- * If someone passes an explicit hint name, automatically merge in data/hlint.yaml -- We want more important hints to go last, since they override-cmdHintFiles :: Cmd -> IO [FilePath]+cmdHintFiles :: Cmd -> IO [(FilePath, Maybe String)] cmdHintFiles cmd = do- let explicit1 = [cmdDataDir cmd </> "hlint.yaml" | null $ cmdWithHints cmd]+ let explicit1 = [hlintYaml | null $ cmdWithHints cmd] let explicit2 = cmdGivenHints cmd- bad <- filterM (notM . doesFileExist) $ explicit1 ++ explicit2+ bad <- filterM (notM . doesFileExist) explicit2+ let explicit2' = map (,Nothing) explicit2 when (bad /= []) $ fail $ unlines $ "Failed to find requested hint files:" : map (" "++) bad- if cmdWithHints cmd /= [] then return $ explicit1 ++ explicit2 else do+ if cmdWithHints cmd /= [] then return $ explicit1 ++ explicit2' else do -- we follow the stylish-haskell config file search policy -- 1) current directory or its ancestors; 2) home directory curdir <- getCurrentDirectory@@ -231,7 +233,7 @@ implicit <- findM doesFileExist $ map (</> ".hlint.yaml") (ancestors curdir ++ home) -- to match Stylish Haskell ++ ["HLint.hs"] -- the default in HLint 1.*- return $ explicit1 ++ maybeToList implicit ++ explicit2+ return $ explicit1 ++ map (,Nothing) (maybeToList implicit) ++ explicit2' where ancestors = init . map joinPath . reverse . inits . splitPath
+ src/EmbedData.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TemplateHaskell #-}++module EmbedData+ ( hlintYaml,+ defaultYaml,+ reportTemplate,+ )+where++import Data.ByteString.UTF8+import Data.FileEmbed++hlintYaml :: (FilePath, Maybe String)+hlintYaml = ("data/hlint.yaml", Just $ toString $(embedFile "data/hlint.yaml"))++defaultYaml :: String+defaultYaml = toString $(embedFile "data/default.yaml")++reportTemplate :: String+reportTemplate = toString $(embedFile "data/report_template.html")
src/GHC/Util.hs view
@@ -37,6 +37,8 @@ import GHC.Util.Scope import GHC.Util.Unify +import qualified Language.Haskell.GhclibParserEx.Parse as GhclibParserEx+ import HsSyn import Lexer import Parser@@ -44,33 +46,21 @@ import FastString import StringBuffer import GHC.LanguageExtensions.Type-import Panic-import HscTypes-import HeaderInfo import DynFlags import Data.List.Extra import System.FilePath import Language.Preprocessor.Unlit -parseGhcLib :: P a -> String -> DynFlags -> ParseResult a-parseGhcLib p str flags =- Lexer.unP p parseState- where- location = mkRealSrcLoc (mkFastString "<string>") 1 1- buffer = stringToStringBuffer str- parseState = mkPState flags buffer location- parseExpGhcLib :: String -> DynFlags -> ParseResult (LHsExpr GhcPs)-parseExpGhcLib = parseGhcLib Parser.parseExpression+parseExpGhcLib = GhclibParserEx.parseExpr parseImportGhcLib :: String -> DynFlags -> ParseResult (LImportDecl GhcPs)-parseImportGhcLib = parseGhcLib Parser.parseImport+parseImportGhcLib = GhclibParserEx.parseImport -parseFileGhcLib :: FilePath- -> String- -> DynFlags- -> ParseResult (Located (HsModule GhcPs))+-- TODO(SF): GhclibParserEx.parseFile doesn't take 'unlit' into+-- consideration yet.+parseFileGhcLib :: FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) parseFileGhcLib filename str flags = Lexer.unP Parser.parseModule parseState where@@ -79,21 +69,18 @@ if takeExtension filename /= ".lhs" then str else unlit filename str parseState = mkPState flags buffer location +-- TODO(SF): GhclibParserEx.parsePragmasIntoDynFlags doesn't take+-- enabled/disabled extensions into consideration yet. parsePragmasIntoDynFlags :: DynFlags -> ([Extension], [Extension]) -> FilePath -> String -> IO (Either String DynFlags)-parsePragmasIntoDynFlags flags (enable, disable) filepath str =- catchErrors $ do- let opts = getOptions flags (stringToStringBuffer str) filepath- (flags, _, _) <- parseDynamicFilePragma flags opts- let flags' = foldl' xopt_set flags enable- let flags'' = foldl' xopt_unset flags' disable- let flags''' = flags'' `gopt_set` Opt_KeepRawTokenStream- return $ Right flags'''- where- catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)- catchErrors act = handleGhcException reportErr- (handleSourceError reportErr act)- reportErr e = return $ Left (show e)+parsePragmasIntoDynFlags flags (enable, disable) filepath str = do+ flags <- GhclibParserEx.parsePragmasIntoDynFlags flags filepath str+ case flags of+ Right flags -> do+ let flags' = foldl' xopt_set flags enable+ let flags'' = foldl' xopt_unset flags' disable+ return $ Right flags''+ err -> return err
src/GHC/Util/DynFlags.hs view
@@ -1,33 +1,9 @@-{-# OPTIONS_GHC -fno-warn-missing-fields #-}- module GHC.Util.DynFlags (baseDynFlags) where import DynFlags-import Platform-import Config-import Fingerprint import GHC.LanguageExtensions.Type- import Data.List.Extra--fakeSettings :: Settings-fakeSettings = Settings- { sTargetPlatform=platform- , sPlatformConstants=platformConstants- , sProjectVersion=cProjectVersion- , sProgramName="ghc"- , sOpt_P_fingerprint=fingerprint0- }- where- platform =- Platform{platformWordSize=8- , platformOS=OSUnknown- , platformUnregisterised=True}- platformConstants =- PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}--fakeLlvmConfig :: (LlvmTargets, LlvmPasses)-fakeLlvmConfig = ([], [])+import Language.Haskell.GhclibParserEx.Parse baseDynFlags :: DynFlags baseDynFlags =
− src/GHC/Util/Language/Haskell/GHC/ExactPrint/Types.hs
@@ -1,377 +0,0 @@--- Adapted from https://github.com/alanz/ghc-exactprint.git.--{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-module GHC.Util.Language.Haskell.GHC.ExactPrint.Types- ( -- * Core Types- Anns- , emptyAnns- , Annotation(..)- , annNone-- , KeywordId(..)- , Comment(..)- -- * Positions- , Pos- , DeltaPos(..)- , deltaRow, deltaColumn- -- * AnnKey- , AnnKey(..)- , mkAnnKey- , AnnConName(..)- , annGetConstr-- -- * Other-- , Rigidity(..)- , AstContext(..),AstContextSet,defaultACS- , ACS'(..)- , ListContexts(..)-- -- * For managing compatibility- , Constraints-- -- * GHC version compatibility- , GhcPs- , GhcRn- , GhcTc-- -- * Internal Types- , LayoutStartCol(..)- , declFun-- ) where--import Data.Data (Data, Typeable, toConstr,cast)--import qualified DynFlags as GHC-import qualified HsSyn as GHC-import qualified Outputable as GHC-import SrcLoc as GHC-import ApiAnnotation as GHC--import qualified Data.Map as Map-import qualified Data.Set as Set---- -----------------------------------------------------------------------type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a)---- ------------------------------------------------------------------------- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted--- from an @AnnKeywordId@ because the annotation must be interleaved into the--- stream and does not have a well-defined position-data Comment = Comment- {- commentContents :: !String -- ^ The contents of the comment including separators-- -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is- -- the thing we use to decide where in the output stream the comment should- -- go.- , commentIdentifier :: !GHC.SrcSpan -- ^ Needed to uniquely identify two comments with the same contents- , commentOrigin :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.- }- deriving (Eq,Typeable,Data,Ord)-instance Show Comment where- show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")"--instance GHC.Outputable Comment where- ppr x = GHC.text (show x)--type Pos = (Int,Int)---- | A relative positions, row then column-newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data)--deltaRow, deltaColumn :: DeltaPos -> Int-deltaRow (DP (r, _)) = r-deltaColumn (DP (_, c)) = c----- | Marks the start column of a layout block.-newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int }- deriving (Eq, Num)--instance Show LayoutStartCol where- show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")"---annNone :: Annotation-annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing--data Annotation = Ann- {- -- The first three fields relate to interfacing up into the AST- annEntryDelta :: !DeltaPos- -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior- -- output was, including all annPriorComments (field below).- , annPriorComments :: ![(Comment, DeltaPos)]- -- ^ Comments coming after the last non-comment output of the preceding- -- element but before the SrcSpan being annotated by this Annotation. If- -- these are changed then annEntryDelta (field above) must also change to- -- match.- , annFollowingComments :: ![(Comment, DeltaPos)]- -- ^ Comments coming after the last output for the element subject to this- -- Annotation. These will only be added by AST transformations, and care- -- must be taken not to disturb layout of following elements.-- -- The next three fields relate to interacing down into the AST- , annsDP :: ![(KeywordId, DeltaPos)]- -- ^ Annotations associated with this element.- , annSortKey :: !(Maybe [GHC.SrcSpan])- -- ^ Captures the sort order of sub elements. This is needed when the- -- sub-elements have been split (as in a HsLocalBind which holds separate- -- binds and sigs) or for infix patterns where the order has been- -- re-arranged. It is captured explicitly so that after the Delta phase a- -- SrcSpan is used purely as an index into the annotations, allowing- -- transformations of the AST including the introduction of new Located- -- items or re-arranging existing ones.- , annCapturedSpan :: !(Maybe AnnKey)- -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of- -- elements which we must remember for the Print phase. e.g. the statements- -- in a HsLet or HsDo. These must be managed as a group because they all- -- need eo be vertically aligned for the Haskell layout rules, and this- -- guarantees this property in the presence of AST edits.-- } deriving (Typeable,Eq)--instance Show Annotation where- show (Ann dp comments fcomments ans sk csp)- = "(Ann (" ++ show dp ++ ") " ++ show comments ++ " "- ++ show fcomments ++ " "- ++ show ans ++ " " ++ showGhc sk ++ " "- ++ showGhc csp ++ ")"----- | This structure holds a complete set of annotations for an AST-type Anns = Map.Map AnnKey Annotation--emptyAnns :: Anns-emptyAnns = Map.empty---- | For every @Located a@, use the @SrcSpan@ and constructor name of--- a as the key, to store the standard annotation.--- These are used to maintain context in the AP and EP monads-data AnnKey = AnnKey GHC.SrcSpan AnnConName- deriving (Eq, Ord, Data)---- More compact Show instance-instance Show AnnKey where- show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn---mkAnnKeyPrim :: (Constraints a)- => a -> AnnKey-mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a)--type GhcPs = GHC.GhcPs-type GhcRn = GHC.GhcRn-type GhcTc = GHC.GhcTc---- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.-mkAnnKey :: (Constraints a) => a -> AnnKey-mkAnnKey ld =- case cast ld :: Maybe (GHC.LHsDecl GhcPs) of- Just d -> declFun mkAnnKeyPrim d- Nothing -> mkAnnKeyPrim ld---- Holds the name of a constructor-data AnnConName = CN { unConName :: String }- deriving (Eq, Ord, Data)---- More compact show instance-instance Show AnnConName where- show (CN s) = "CN " ++ show s--annGetConstr :: (Data a) => a -> AnnConName-annGetConstr a = CN (show $ toConstr a)---- | The different syntactic elements which are not represented in the--- AST.-data KeywordId = G GHC.AnnKeywordId -- ^ A normal keyword- | AnnSemiSep -- ^ A separating comma- | AnnTypeApp -- ^ Visible type application annotation- | AnnComment Comment- | AnnString String -- ^ Used to pass information from- -- Delta to Print when we have to work- -- out details from the original- -- SrcSpan.- deriving (Eq, Ord, Data)--instance Show KeywordId where- show (G gc) = "(G " ++ show gc ++ ")"- show AnnSemiSep = "AnnSemiSep"- show AnnTypeApp = "AnnTypeApp"- show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"- show (AnnString s) = "(AnnString " ++ s ++ ")"---- -----------------------------------------------------------------------instance GHC.Outputable KeywordId where- ppr k = GHC.text (show k)--instance GHC.Outputable AnnConName where- ppr tr = GHC.text (show tr)--instance GHC.Outputable Annotation where- ppr a = GHC.text (show a)--instance GHC.Outputable AnnKey where- ppr a = GHC.text (show a)--instance GHC.Outputable DeltaPos where- ppr a = GHC.text (show a)---- --------------------------------------------------------------------------- Flag used to control whether we use rigid or normal layout rules.--- NOTE: check is done via comparison of enumeration order, be careful with any changes-data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)-{---Rigidity logic. The same type is used for two different things--1. As a flag in Annotate to the "SetLayoutFlag" operation, which specifies- NormalLayout - Layout should be captured unconditionally-- RigidLayout - Layout should be captured or not depending on a parameter kept- in the interpreter Read state--2. As the controlling parameter for the optional (Rigid) layout--The nett effect is the following, where flag is the hard-coded flag value in-Annotate, and param is the interpreter param set when the interpreter is run-- flag | param | result- -------------+--------------+--------------------- NormalLayout | either | layout captured- RigidLayout | NormalLayout | layout NOT captured- RigidLayout | RigidLayout | layout captured--The flag is only used on HsIf and HsCase--So-- state | HsCase | HsIf- ----------------------------|-----------+------- before rigidity flag (AZ) | no layout | layout- param NormalLayout | no layout | no layout- param RigidLayout | layout | layout- ----------------------------+-----------+-------- desired future HaRe | no layout | layout- desired future apply-refact | layout | layout--}---- -----------------------------------------------------------------------data ACS' a = ACS- { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should- -- propagate down the AST. Removed when it hits zero- } deriving (Show)--instance Semigroup (ACS' AstContext) where- (<>) = mappend--instance Monoid (ACS' AstContext) where- mempty = ACS mempty- -- ACS a `mappend` ACS b = ACS (a `mappend` b)- ACS a `mappend` ACS b = ACS (Map.unionWith max a b)- -- For Data.Map, mappend == union, which is a left-biased replace for key collisions--type AstContextSet = ACS' AstContext--- data AstContextSet = ACS--- { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should--- -- propagate down the AST. Removed when it--- -- hits zero--- } deriving (Show)--defaultACS :: AstContextSet-defaultACS = ACS Map.empty---- instance GHC.Outputable AstContextSet where-instance (Show a) => GHC.Outputable (ACS' a) where- ppr x = GHC.text $ show x--data AstContext = LambdaExpr- | CaseAlt- | NoPrecedingSpace- | HasHiding- | AdvanceLine- | NoAdvanceLine- | Intercalate -- This item may have a list separator following- | InIE -- possible 'type' or 'pattern'- | PrefixOp- | PrefixOpDollar- | InfixOp -- RdrName may be used as an infix operator- | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently- | ListItem -- Identifies subsequent elements of a list in layout- | TopLevel -- top level declaration- | NoDarrow- | AddVbar- | Deriving- | Parens -- TODO: Not currently used?- | ExplicitNeverActive- | InGadt- | InRecCon- | InClassDecl- | InSpliceDecl- | LeftMost -- Is this the leftmost operator in a chain of OpApps?- | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt- -- TODO:AZ: do we actually need this?-- -- Next four used to identify current list context- | CtxOnly- | CtxFirst- | CtxMiddle- | CtxLast- | CtxPos Int -- 0 for first, increasing for subsequent-- -- Next are used in tellContext to push context up the tree- | FollowingLine- deriving (Eq, Ord, Show)---data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) }- deriving (Eq,Show)---- ------------------------------------------------------------------------- data LayoutContext = FollowingLine -- ^Indicates that an item such as a SigD--- -- should not have blank lines after it--- deriving (Eq, Ord, Show)---- -----------------------------------------------------------------------declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b--declFun f (GHC.L l de) =- case de of- GHC.TyClD _ d -> f (GHC.L l d)- GHC.InstD _ d -> f (GHC.L l d)- GHC.DerivD _ d -> f (GHC.L l d)- GHC.ValD _ d -> f (GHC.L l d)- GHC.SigD _ d -> f (GHC.L l d)- GHC.DefD _ d -> f (GHC.L l d)- GHC.ForD _ d -> f (GHC.L l d)- GHC.WarningD _ d -> f (GHC.L l d)- GHC.AnnD _ d -> f (GHC.L l d)- GHC.RuleD _ d -> f (GHC.L l d)- GHC.SpliceD _ d -> f (GHC.L l d)- GHC.DocD _ d -> f (GHC.L l d)- GHC.RoleAnnotD _ d -> f (GHC.L l d)- GHC.XHsDecl d -> f (GHC.L l d)---- ------------------------------------------------------------------------- Duplicated here so it can be used in show instances-showGhc :: (GHC.Outputable a) => a -> String-showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags---- ---------------------------------------------------------------------
− src/GHC/Util/Refact/Fixity.hs
@@ -1,204 +0,0 @@--- Adapted from https://github.com/mpickering/apply-refact.git.--{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RecordWildCards #-}-module GHC.Util.Refact.Fixity (applyFixities) where--import SrcLoc--import BasicTypes (Fixity(..), defaultFixity, compareFixity, negateFixity, FixityDirection(..), SourceText(..))-import HsExpr-import HsPat-import HsTypes-import RdrName-import HsExtension-import OccName-import Data.Generics hiding (Fixity)-import Data.Maybe--import GHC.Util.Refact.Utils-import GHC.Util.Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn)--import Control.Monad.State-import qualified Data.Map as Map-import Data.Tuple---- | Rearrange infix expressions to account for fixity.--- The set of fixities is wired in and includes all fixities in base.-applyFixities :: (Data a) => Anns -> [(String, Fixity)] -> a -> (Anns, a)-applyFixities as fixities m = let (as', m') = swap $ runState (everywhereM (mkM (expFix fixities)) m) as- (as'', m'') = swap $ runState (everywhereM (mkM (patFix fixities)) m') as'- in (as'', m'') --error (showAnnData as 0 m ++ showAnnData as' 0 m')--getFixities fixities =- if null fixities then baseFixities else fixities--expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> M (LHsExpr GhcPs)-expFix fixities (L loc (OpApp _ l op r)) =- mkOpAppRn (getFixities fixities) loc l op (findFixity (getFixities fixities) op) r--expFix _ e = return e--patFix :: [(String, Fixity)] -> LPat GhcPs -> M (LPat GhcPs)-patFix fixities (dL -> L _ (ConPatIn op (InfixCon pat1 pat2))) =- mkConOpPatRn (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2--patFix _ p = return p--getIdent :: Expr -> String-getIdent (unLoc -> HsVar _ (L _ n)) = occNameString . rdrNameOcc $ n-getIdent _ = error "Must be HsVar"---moveDelta :: AnnKey -> AnnKey -> M ()-moveDelta old new = do- a@Ann{..} <- gets (fromMaybe annNone . Map.lookup old)- modify (Map.insert new (annNone { annEntryDelta = annEntryDelta, annPriorComments = annPriorComments }))- modify (Map.insert old (a { annEntryDelta = DP (0,0), annPriorComments = []}))-------------------------------- Modified from GHC Renamer--mkConOpPatRn ::- [(String, Fixity)]- -> Located RdrName -> Fixity -- Operator and fixity- -> LPat GhcPs- -> LPat GhcPs- -> M (LPat GhcPs)-mkConOpPatRn fs op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2- | nofix_error- = return (ConPatIn op2 (InfixCon p1 p2))-- | associate_right = do- new_p <- mkConOpPatRn fs op2 fix2 p12 p2- return (ConPatIn op1 (InfixCon p11 (cL loc new_p)))-- | otherwise = return (ConPatIn op2 (InfixCon p1 p2))-- where- fix1 = findFixity' fs op1- (nofix_error, associate_right) = compareFixity fix1 fix2--mkConOpPatRn _ op _ p1 p2 -- Default case, no rearrangment- = return (ConPatIn op (InfixCon p1 p2))--mkOpAppRn ::- [(String, Fixity)]- -> SrcSpan- -> LHsExpr GhcPs -- Left operand; already rearrange- -> LHsExpr GhcPs -> Fixity -- Operator and fixity- -> LHsExpr GhcPs -- Right operand (not an OpApp, but might- -- be a NegApp)- -> M (LHsExpr GhcPs)---- (e11 `op1` e12) `op2` e2-mkOpAppRn fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2- | nofix_error- = return $ L loc (OpApp noExt e1 op2 e2)-- | associate_right = do- new_e <- mkOpAppRn fs loc' e12 op2 fix2 e2- moveDelta (mkAnnKey e12) (mkAnnKey new_e)- return $ L loc (OpApp x1 e11 op1 new_e)- where- loc'= combineLocs e12 e2- fix1 = findFixity fs op1- (nofix_error, associate_right) = compareFixity fix1 fix2-------------------------------- (- neg_arg) `op` e2-mkOpAppRn fs loc e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2- | nofix_error- = return (L loc (OpApp noExt e1 op2 e2))-- | associate_right- = do- new_e <- mkOpAppRn fs loc' neg_arg op2 fix2 e2- moveDelta (mkAnnKey neg_arg) (mkAnnKey new_e)- let res = L loc (NegApp noExt new_e neg_name)- key = mkAnnKey res- ak = AnnKey loc (CN "OpApp")- opAnn <- gets (fromMaybe annNone . Map.lookup ak)- negAnns <- gets (fromMaybe annNone . Map.lookup (mkAnnKey e1))- modify (Map.insert key (annNone { annEntryDelta = annEntryDelta opAnn, annsDP = annsDP negAnns }))- return res-- where- loc' = combineLocs neg_arg e2- (nofix_error, associate_right) = compareFixity negateFixity fix2-------------------------------- e1 `op` - neg_arg-mkOpAppRn _ loc e1 op1 fix1 e2@(L _ NegApp {}) -- NegApp can occur on the right- | not associate_right -- We *want* right association- = return $ L loc (OpApp noExt e1 op1 e2)- where- (_, associate_right) = compareFixity fix1 negateFixity-------------------------------- Default case-mkOpAppRn _ loc e1 op _fix e2 -- Default case, no rearrangment- = return $ L loc (OpApp noExt e1 op e2)--findFixity :: [(String, Fixity)] -> Expr -> Fixity-findFixity fs r = askFix fs (getIdent r)--findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity-findFixity' fs r = askFix fs (occNameString . rdrNameOcc . unLoc $ r)--askFix :: [(String, Fixity)] -> String -> Fixity-askFix xs = \k -> lookupWithDefault defaultFixity k xs- where- lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1---- | All fixities defined in the Prelude.-preludeFixities :: [(String, Fixity)]-preludeFixities = concat- [infixr_ 9 ["."]- ,infixl_ 9 ["!!"]- ,infixr_ 8 ["^","^^","**"]- ,infixl_ 7 ["*","/","quot","rem","div","mod",":%","%"]- ,infixl_ 6 ["+","-"]- ,infixr_ 5 [":","++"]- ,infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"]- ,infixr_ 3 ["&&"]- ,infixr_ 2 ["||"]- ,infixl_ 1 [">>",">>="]- ,infixr_ 1 ["=<<"]- ,infixr_ 0 ["$","$!","seq"]- ]---- | All fixities defined in the base package.------ Note that the @+++@ operator appears in both Control.Arrows and--- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in--- this list is that of Control.Arrows.-baseFixities :: [(String, Fixity)]-baseFixities = preludeFixities ++ concat- [infixl_ 9 ["!","//","!:"]- ,infixl_ 8 ["shift","rotate","shiftL","shiftR","rotateL","rotateR"]- ,infixl_ 7 [".&."]- ,infixl_ 6 ["xor"]- ,infix_ 6 [":+"]- ,infixl_ 5 [".|."]- ,infixr_ 5 ["+:+","<++","<+>"] -- fixity conflict for +++ between ReadP and Arrow- ,infix_ 5 ["\\\\"]- ,infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"]- ,infix_ 4 ["elemP","notElemP"]- ,infixl_ 3 ["<|>"]- ,infixr_ 3 ["&&&","***"]- ,infixr_ 2 ["+++","|||"]- ,infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"]- ,infixl_ 0 ["on"]- ,infixr_ 0 ["par","pseq"]- ]--infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)]-infixr_ = fixity InfixR-infixl_ = fixity InfixL-infix_ = fixity InfixN---- Internal: help function for the above definitions.-fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)]-fixity a p = map (,Fixity (SourceText "") p a)
− src/GHC/Util/Refact/Utils.hs
@@ -1,166 +0,0 @@--- Adapted from https://github.com/mpickering/apply-refact.git.--{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--module GHC.Util.Refact.Utils ( -- * Synonyms- Module- , Stmt- , Expr- , Decl- , Name- , Pat- , Type- , Import- , FunBind- -- * Monad- , M- -- * Utility-- , mergeAnns- , modifyAnnKey- , replaceAnnKey- , toGhcSrcSpan- , findParent-- ) where--import HsSyn as GHC hiding (Stmt, Pat)-import SrcLoc-import qualified SrcLoc as GHC-import qualified RdrName as GHC-import qualified ApiAnnotation as GHC-import qualified FastString as GHC--import GHC.Util.Language.Haskell.GHC.ExactPrint.Types--import Data.Data--import Control.Monad.State--import qualified Data.Map as Map-import Data.Maybe---import qualified Refact.Types as R--import Data.Generics.Schemes-import Unsafe.Coerce---- | Left bias pair union-mergeAnns :: Anns -> Anns -> Anns-mergeAnns- = Map.union---- Types----type M a = State Anns a--type Module = (GHC.Located (GHC.HsModule GHC.GhcPs))--type Expr = GHC.Located (GHC.HsExpr GHC.GhcPs)--type Type = GHC.Located (GHC.HsType GHC.GhcPs)--type Decl = GHC.Located (GHC.HsDecl GHC.GhcPs)--type Pat = GHC.LPat GHC.GhcPs--type Name = GHC.Located GHC.RdrName--type Stmt = ExprLStmt GHC.GhcPs--type Import = LImportDecl GHC.GhcPs--type FunBind = HsMatchContext GHC.RdrName---- | Replaces an old expression with a new expression------ Note that usually, new, inp and parent are all the same.-replace :: AnnKey -- The thing we are replacing- -> AnnKey -- The thing which has the annotations we need for the new thing- -> AnnKey -- The thing which is going to be inserted- -> AnnKey -- The "parent", the largest thing which has he same SrcSpan- -- Usually the same as inp and new- -> Anns -> Maybe Anns-replace old new inp parent anns = do- oldan <- Map.lookup old anns- newan <- Map.lookup new anns- oldDelta <- annEntryDelta <$> Map.lookup parent anns- return $ Map.insert inp (combine oldDelta oldan newan) anns--combine :: DeltaPos -> Annotation -> Annotation -> Annotation-combine oldDelta oldann newann =- Ann { annEntryDelta = newEntryDelta- , annPriorComments = annPriorComments oldann ++ annPriorComments newann- , annFollowingComments = annFollowingComments oldann ++ annFollowingComments newann- , annsDP = removeComma (annsDP newann) ++ extraComma (annsDP oldann)- , annSortKey = annSortKey newann- , annCapturedSpan = annCapturedSpan newann}- where- -- Get rid of structural information when replacing, we assume that the- -- structural information is already there in the new expression.- removeComma = filter (\(kw, _) -> case kw of- G GHC.AnnComma -> False- AnnSemiSep -> False- _ -> True)-- -- Make sure to keep structural information in the template.- extraComma [] = []- extraComma (last -> x) = case fst x of- G GHC.AnnComma -> [x]- AnnSemiSep -> [x]- G GHC.AnnSemi -> [x]- _ -> []-- -- Keep the same delta if moving onto a new row- newEntryDelta | deltaRow oldDelta > 0 = oldDelta- | otherwise = annEntryDelta oldann----- | A parent in this case is an element which has the same SrcSpan-findParent :: Data a => GHC.SrcSpan -> Anns -> a -> Maybe AnnKey-findParent ss as = something (findParentWorker ss as)---- Note that a parent must also have an annotation.-findParentWorker :: forall a . (Data a)- => GHC.SrcSpan -> Anns -> a -> Maybe AnnKey-findParentWorker oldSS as a- | con == typeRepTyCon (typeRep (Proxy :: Proxy (GHC.Located GHC.RdrName))) && x == typeRep (Proxy :: Proxy GHC.SrcSpan)- = if ss == oldSS- && isJust (Map.lookup (AnnKey ss cn) as)- then Just $ AnnKey ss cn- else Nothing- | otherwise = Nothing- where- (con, ~[x, _]) = splitTyConApp (typeOf a)- ss :: GHC.SrcSpan- ss = gmapQi 0 unsafeCoerce a- cn = gmapQi 1 (CN . show . toConstr) a----- | Perform the necessary adjustments to annotations when replacing--- one Located thing with another Located thing.------ For example, this function will ensure the correct relative position and--- make sure that any trailing semi colons or commas are transferred.-modifyAnnKey :: (Data old, Data new, Data mod) => mod -> Located old -> Located new -> M (Located new)-modifyAnnKey m e1 e2 = do- as <- get- let parentKey = fromMaybe (mkAnnKey e2) (findParent (getLoc e2) as m)- e2 <$ modify (\m' -> replaceAnnKey m' (mkAnnKey e1) (mkAnnKey e2) (mkAnnKey e2) parentKey)----- | Lower level version of @modifyAnnKey@-replaceAnnKey ::- Anns -> AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns-replaceAnnKey a old new inp deltainfo =- fromMaybe a (replace old new inp deltainfo a)----- | Convert a @Refact.Types.SrcSpan@ to a @SrcLoc.SrcSpan@-toGhcSrcSpan :: FilePath -> R.SrcSpan -> SrcSpan-toGhcSrcSpan file R.SrcSpan{..} = mkSrcSpan (f startLine startCol) (f endLine endCol)- where- f = mkSrcLoc (GHC.mkFastString file)
src/HLint.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, TupleSections #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module HLint(hlint, readAllSettings) where@@ -20,7 +20,6 @@ import System.Process.Extra import Data.Maybe import System.Directory-import System.FilePath import CmdLine import Config.Read@@ -37,6 +36,7 @@ import Parallel import HSE.All import CC+import EmbedData -- | This function takes a list of command line arguments, and returns the given hints.@@ -87,7 +87,7 @@ hlintTest cmd@CmdTest{..} = if not $ null cmdProof then do files <- cmdHintFiles cmd- s <- readFilesConfig $ map (,Nothing) files+ s <- readFilesConfig files let reps = if cmdReports == ["report.html"] then ["report.txt"] else cmdReports mapM_ (proof reps s) cmdProof else do@@ -119,9 +119,8 @@ ideas <- if null cmdFiles then return [] else withVerbosity Quiet $ runHlintMain args cmd{cmdJson=False,cmdSerialise=False,cmdRefactor=False} Nothing let bad = nubOrd $ map ideaHint ideas- src <- readFile $ cmdDataDir </> "default.yaml"- if null bad then putStr src else do- let group1:groups = splitOn ["",""] $ lines src+ if null bad then putStr defaultYaml else do+ let group1:groups = splitOn ["",""] $ lines defaultYaml let group2 = "# Warnings currently triggered by your code" : ["- ignore: {name: " ++ show x ++ "}" | x <- bad] putStr $ unlines $ intercalate ["",""] $ group1:group2:groups@@ -154,7 +153,7 @@ files <- cmdHintFiles cmd settings1 <- readFilesConfig $- map (,Nothing) files+ files ++ [("CommandLine.hs",Just x) | x <- cmdWithHints] ++ [("CommandLine.yaml",Just (enableGroup x)) | x <- cmdWithGroups] let args2 = [x | SettingArgument x <- settings1]
src/HSE/All.hs view
@@ -45,7 +45,7 @@ import qualified DynFlags as GHC import GHC.Util-import qualified GHC.Util.Refact.Fixity as GHC+import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx -- | Convert a GHC source loc into an HSE equivalent. ghcSrcLocToHSE :: GHC.SrcLoc -> SrcLoc@@ -321,7 +321,7 @@ flags = foldl' GHC.xopt_unset (foldl' GHC.xopt_set baseDynFlags enable) disable fixities = ghcFixitiesFromParseMode parseMode in case parseExpGhcLib s flags of- GHC.POk pst a -> GHC.POk pst a' where (_, a') = GHC.applyFixities Map.empty fixities a+ GHC.POk pst a -> GHC.POk pst (GhclibParserEx.applyFixities fixities a) f@GHC.PFailed{} -> f parseImportDeclGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LImportDecl HsSyn.GhcPs)@@ -354,7 +354,7 @@ ( Map.fromListWith (++) $ GHC.annotations pst , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pst) : GHC.annotations_comments pst) ) in- let (_, a') = GHC.applyFixities Map.empty fixities a in+ let a' = GhclibParserEx.applyFixities fixities a in return $ Right (ModuleEx (applyFixity fixity x) cs a' anns) -- Parse error if GHC parsing fails (see -- https://github.com/ndmitchell/hlint/issues/645).
src/Hint/Extensions.hs view
@@ -286,6 +286,11 @@ used RecordPuns = hasS isPFieldPun' ||^ hasS isFieldPun' used NamedFieldPuns = hasS isPFieldPun' ||^ hasS isFieldPun' used UnboxedTuples = has isUnboxedTuple' ||^ has (== Unboxed)+used PackageImports = hasS f+ where+ f :: ImportDecl GhcPs -> Bool+ f ImportDecl{ideclPkgQual=Just _} = True+ f _ = False used QuasiQuotes = hasS isQuasiQuote' ||^ hasS isTyQuasiQuote' used ViewPatterns = hasS isPViewPat' used DefaultSignatures = hasS isClsDefSig'
src/Hint/Lambda.hs view
@@ -70,6 +70,7 @@ yes = foo (\x -> Just x) -- @Warning Just foo = bar (\x -> (x `f`)) -- f baz = bar (\x -> (x +)) -- (+)+foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b no = blah (\ x -> case x of A -> a x; B -> b x) yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q)@@ -162,7 +163,9 @@ munge ident p = PVar (ann p) (Ident (ann p) [ident]) subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats) lambdaExp p o@(Lambda _ [view -> PVar_ u] (Case _ (view -> Var_ v) alts))- | u == v, u `notElem` vars alts = [(suggestN "Use lambda-case" o $ LCase an alts){ideaNote=[RequiresExtension "LambdaCase"]}]+ | u == v, u `notElem` vars alts = case alts of+ [Alt _ pat (UnGuardedRhs _ bod) Nothing] -> [suggestN "Use lambda" o $ Lambda an [pat] bod]+ _ -> [(suggestN "Use lambda-case" o $ LCase an alts){ideaNote=[RequiresExtension "LambdaCase"]}] lambdaExp p o@(Lambda _ [view -> PVar_ u] (Tuple _ boxed xs)) | ([yes],no) <- partition (~= u) xs, u `notElem` concatMap vars no = [(suggestN "Use tuple-section" o $ TupleSection an boxed [if x ~= u then Nothing else Just x | x <- xs])
src/Language/Haskell/HLint4.hs view
@@ -39,13 +39,12 @@ import SrcLoc import CmdLine import Paths_hlint-import qualified GHC.Util.Refact.Fixity as GHC+import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx import Data.List.Extra import Data.Maybe import System.FilePath import Data.Functor-import qualified Data.Map as Map import Prelude @@ -148,7 +147,6 @@ -- account for operator fixities. createModuleEx:: GHC.ApiAnns -> Located (GHC.HsModule GHC.GhcPs) -> ModuleEx createModuleEx anns ast =- let fixities = [] -- Use builtin fixities.- (_, ast') = GHC.applyFixities Map.empty fixities ast in- ModuleEx empty [] ast' anns+ -- Use builtin fixities.+ ModuleEx empty [] (GhclibParserEx.applyFixities [] ast) anns where empty = Module an Nothing [] [] []
src/Report.hs view
@@ -7,18 +7,16 @@ import Data.List.Extra import Data.Maybe import Data.Version-import System.FilePath-import System.IO.Extra import HSE.All import Timing import Paths_hlint import HsColour+import EmbedData writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO ()-writeTemplate dataDir content to = do- src <- readFile' $ dataDir </> "report_template.html"- writeFile to $ unlines $ concatMap f $ lines src+writeTemplate dataDir content to =+ writeFile to $ unlines $ concatMap f $ lines reportTemplate where f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content f x = [x]