diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/data/hlint.yaml b/data/hlint.yaml --- a/data/hlint.yaml +++ b/data/hlint.yaml @@ -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) diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -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 diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -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 diff --git a/src/EmbedData.hs b/src/EmbedData.hs new file mode 100644 --- /dev/null +++ b/src/EmbedData.hs @@ -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") diff --git a/src/GHC/Util.hs b/src/GHC/Util.hs --- a/src/GHC/Util.hs +++ b/src/GHC/Util.hs @@ -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 "") 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 diff --git a/src/GHC/Util/DynFlags.hs b/src/GHC/Util/DynFlags.hs --- a/src/GHC/Util/DynFlags.hs +++ b/src/GHC/Util/DynFlags.hs @@ -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 = diff --git a/src/GHC/Util/Language/Haskell/GHC/ExactPrint/Types.hs b/src/GHC/Util/Language/Haskell/GHC/ExactPrint/Types.hs deleted file mode 100644 --- a/src/GHC/Util/Language/Haskell/GHC/ExactPrint/Types.hs +++ /dev/null @@ -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 - --- --------------------------------------------------------------------- diff --git a/src/GHC/Util/Refact/Fixity.hs b/src/GHC/Util/Refact/Fixity.hs deleted file mode 100644 --- a/src/GHC/Util/Refact/Fixity.hs +++ /dev/null @@ -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) diff --git a/src/GHC/Util/Refact/Utils.hs b/src/GHC/Util/Refact/Utils.hs deleted file mode 100644 --- a/src/GHC/Util/Refact/Utils.hs +++ /dev/null @@ -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) diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -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] diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -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). diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -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' diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -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]) diff --git a/src/Language/Haskell/HLint4.hs b/src/Language/Haskell/HLint4.hs --- a/src/Language/Haskell/HLint4.hs +++ b/src/Language/Haskell/HLint4.hs @@ -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 [] [] [] diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -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]