hlint 3.1.4 → 3.1.5
raw patch · 42 files changed
+571/−454 lines, 42 filesdep +HsYAMLdep +HsYAML-aesondep ~extradep ~ghc-lib-parser-exPVP ok
version bump matches the API change (PVP)
Dependencies added: HsYAML, HsYAML-aeson
Dependency ranges changed: extra, ghc-lib-parser-ex
API changes (from Hackage documentation)
Files
- CHANGES.txt +24/−0
- README.md +5/−17
- data/hlint.yaml +31/−7
- hlint.cabal +18/−7
- src/Apply.hs +6/−5
- src/CmdLine.hs +11/−2
- src/Config/Compute.hs +2/−2
- src/Config/Yaml.hs +30/−4
- src/Extension.hs +3/−0
- src/GHC/All.hs +205/−0
- src/GHC/Util.hs +0/−2
- src/GHC/Util/DynFlags.hs +1/−1
- src/GHC/Util/FreeVars.hs +1/−2
- src/GHC/Util/HsExpr.hs +18/−9
- src/GHC/Util/Module.hs +0/−13
- src/GHC/Util/Scope.hs +2/−3
- src/GHC/Util/SrcLoc.hs +1/−1
- src/GHC/Util/Unify.hs +25/−16
- src/Grep.hs +1/−1
- src/HLint.hs +4/−3
- src/HSE/All.hs +0/−205
- src/Hint/Bracket.hs +11/−11
- src/Hint/Duplicate.hs +11/−5
- src/Hint/Extensions.hs +30/−6
- src/Hint/Import.hs +12/−65
- src/Hint/Lambda.hs +51/−23
- src/Hint/List.hs +15/−13
- src/Hint/ListRec.hs +1/−1
- src/Hint/Match.hs +2/−1
- src/Hint/Monad.hs +1/−1
- src/Hint/Naming.hs +5/−4
- src/Hint/Pattern.hs +5/−4
- src/Hint/Pragma.hs +3/−3
- src/Hint/Restrict.hs +2/−1
- src/Hint/Smell.hs +1/−1
- src/Hint/Type.hs +1/−1
- src/Hint/Unsafe.hs +1/−1
- src/Language/Haskell/HLint.hs +1/−1
- src/Refact.hs +6/−3
- src/Test/All.hs +1/−1
- src/Test/Annotations.hs +19/−4
- src/Util.hs +4/−4
CHANGES.txt view
@@ -1,5 +1,29 @@ Changelog for HLint (* = breaking change) +3.1.5, released 2020-06-19+ #1049, suggest or/and from True `elem` xs and False `notElem` xs+ #1055, avoid incorrect hints with nested (.)'s+ #1054, make isLitString work again+ #1038, make -XNoTemplateHaskell imply -XNoTemplateHaskellQuotes+ #970, require an arg to suggest fromMaybe True ==> (Just True ==)+ #1047, suggest pushing take outside zip+ #1041, fix language/pragma ordering in refactor+ #1040, fix refactoring for "Avoid lambda"+ #1042, fix redundant lambda refactoring+ #1039, don't suggest move map inside list comp repeatedly+ #1035, fix refactoring for "Use fewer imports" in some cases+ #1036, disable refactoring for Use camelCase+ #766, match quasi quotes properly in rules+ Ignore [Char] to String hints by default+ #1034, remove suggestions to use heirarchical module names+ #1032, fix refactoring for "Use :"+ #1028, add hints around sequenceA/traverse+ #1027, pass enabled and disabled extensions to apply-refact+ #1024, make the redundant bracket hints cover just the bracket+ #1024, make redundant $ display more context on the command line+ Suggest removing OverloadedLabels if there are no labels+ #367, suggest removing OverloadedLists if there are no lists+ #1023, speed up checking on large files (up to 12%) 3.1.4, released 2020-05-31 #1018, stop --cross being quadratic #1019, more rules suggesting even/odd
README.md view
@@ -96,26 +96,14 @@ ### Automatically Applying Hints -By supplying the `--refactor` flag hlint can automatically apply most-suggestions. Instead of a list of hints, hlint will instead output the-refactored file on stdout. In order to do this, it is necessary to have the-`refactor` executable on your path. `refactor` is provided by the-[`apply-refact`](https://github.com/mpickering/apply-refact) package,-it uses the GHC API in order to transform source files given a list of-refactorings to apply. Hlint directly calls the executable to apply the-suggestions.--Additional configuration can be passed to `refactor` with the-`--refactor-options` flag. Some useful flags include `-i` which replaces the-original file and `-s` which asks for confirmation before performing a hint.+HLint can automatically apply some suggestions using the `--refactor` flag. If passed, instead of printing out the hints, HLint will output the refactored file on stdout. For `--refactor` to work it is necessary to have the `refactor` executable from the [`apply-refact`](https://github.com/mpickering/apply-refact) package on your `$PATH`. HLint uses that tool to perform the refactoring. -An alternative location for `refactor` can be specified with the-`--with-refactor` flag.+When using `--refactor` you can pass additional options to the `refactor` binary using `--refactor-options` flag. Some useful flags include `-i` (which replaces the original file) and `-s` (which asks for confirmation before performing a hint). The `--with-refactor` flag can be used to specify an alternative location for the `refactor` binary. Simple bindings for [Vim](https://github.com/mpickering/hlint-refactor-vim), [Emacs](https://github.com/mpickering/hlint-refactor-mode) and [Atom](https://github.com/mpickering/hlint-refactor-atom) are available. -Simple bindings for [vim](https://github.com/mpickering/hlint-refactor-vim),-[emacs](https://github.com/mpickering/hlint-refactor-mode) and [atom](https://github.com/mpickering/hlint-refactor-atom) are provided.+While the `--refactor` flag is useful, it is not complete or at the same level of quality as the rest of HLint: -There are no plans to support the duplication nor the renaming hints.+* Some hints don't generate refactorings. Examples include excess duplication, renaming hints and eta reduction hints.+* There are bugs in the underlying `refactor` tool which cause the resultant file to be incorrect. For example, `[1,2..3]` comes out as `[12..3]` ([#389](https://github.com/ndmitchell/hlint/issues/389)), even if there isn't a hint that touches it. ### Reports
data/hlint.yaml view
@@ -204,6 +204,8 @@ - warn: {lhs: all (a /=), rhs: notElem a, note: ValidInstance Eq a} - warn: {lhs: elem True, rhs: or} - warn: {lhs: notElem False, rhs: and}+ - warn: {lhs: True `elem` l, rhs: or l}+ - warn: {lhs: False `notElem` l, rhs: and l} - warn: {lhs: findIndex ((==) a), rhs: elemIndex a} - warn: {lhs: findIndex (a ==), rhs: elemIndex a} - warn: {lhs: findIndex (== a), rhs: elemIndex a}@@ -227,6 +229,8 @@ - warn: {lhs: zipWith f (repeat x), rhs: map (f x)} - warn: {lhs: zipWith f y (repeat z), rhs: map (\x -> f x z) y} - warn: {lhs: listToMaybe (filter p x), rhs: find p x}+ - warn: {lhs: zip (take n x) (take n y), rhs: take n (zip x y)}+ - warn: {lhs: zip (take n x) (take m y), rhs: take (min n m) (zip x y), side: notEq n m, note: IncreasesLaziness, name: Redundant take} # MONOIDS @@ -241,7 +245,6 @@ - warn: {lhs: sequenceA (map f x), rhs: traverse f x} - warn: {lhs: sequenceA (fmap f x), rhs: traverse f x}- - warn: {lhs: sequence (fmap f x), rhs: traverse f x} - 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}@@ -485,6 +488,10 @@ - warn: {lhs: sequence_ (zipWith f x y), rhs: Control.Monad.zipWithM_ f x y} - warn: {lhs: sequence (replicate n x), rhs: Control.Monad.replicateM n x} - warn: {lhs: sequence_ (replicate n x), rhs: Control.Monad.replicateM_ n x}+ - warn: {lhs: sequenceA (zipWith f x y), rhs: Control.Monad.zipWithM f x y}+ - warn: {lhs: sequenceA_ (zipWith f x y), rhs: Control.Monad.zipWithM_ f x y}+ - warn: {lhs: sequenceA (replicate n x), rhs: Control.Monad.replicateM n x}+ - warn: {lhs: sequenceA_ (replicate n x), rhs: Control.Monad.replicateM_ n x} - warn: {lhs: mapM f (replicate n x), rhs: Control.Monad.replicateM n (f x)} - warn: {lhs: mapM_ f (replicate n x), rhs: Control.Monad.replicateM_ n (f x)} - warn: {lhs: mapM f (map g x), rhs: mapM (f . g) x, name: Fuse mapM/map}@@ -511,6 +518,8 @@ - hint: {lhs: pure . f =<< m, rhs: f <$> m} - warn: {lhs: empty <|> x, rhs: x, name: "Alternative law, left identity"} - warn: {lhs: x <|> empty, rhs: x, name: "Alternative law, right identity"}+ - warn: {lhs: traverse id, rhs: sequenceA}+ - warn: {lhs: traverse_ id, rhs: sequenceA_} # LIST COMP@@ -544,8 +553,8 @@ - warn: {lhs: maybe True (x /=), rhs: (Just x /=)} - warn: {lhs: maybe False (== x), rhs: (Just x ==), note: ValidInstance Eq x} - warn: {lhs: maybe True (/= x), rhs: (Just x /=), note: ValidInstance Eq x}- - warn: {lhs: fromMaybe False, rhs: (Just True ==)}- - warn: {lhs: fromMaybe True, rhs: (Just False /=)}+ - warn: {lhs: fromMaybe False x, rhs: Just True == x} # Eta expanded, see https://github.com/ndmitchell/hlint/issues/970#issuecomment-643645053+ - warn: {lhs: fromMaybe True x, rhs: Just False /= x} - warn: {lhs: not (isNothing x), rhs: isJust x} - warn: {lhs: not (isJust x), rhs: isNothing x} - warn: {lhs: "maybe [] (:[])", rhs: maybeToList}@@ -987,6 +996,13 @@ - hint: {lhs: "not (x && y)", rhs: "not x || not y", name: Apply De Morgan law} - hint: {lhs: "[ f x | x <- l ]", rhs: map f l} +- group:+ # used for tests, enabled when testing this file+ name: testing+ enabled: false+ rules:+ - warn: {lhs: "[issue766| |]", rhs: "mempty", name: "Use mempty"}+ # <TEST> # yes = concat . map f -- concatMap f # yes = foo . bar . concat . map f . baz . bar -- concatMap f . baz . bar@@ -1039,6 +1055,8 @@ # no = foo $ \(a, b) -> (a, a + b) # yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (curry (uncurry (+))) [1 .. 5] [6 .. 10] # yes = curry (uncurry (+)) -- (+)+# yes = fst foo .= snd foo -- uncurry (.=) foo+# yes = fst foo `_ba__'r''` snd foo -- uncurry _ba__'r'' foo # no = do iter <- textBufferGetTextIter tb ; textBufferSelectRange tb iter iter # no = flip f x $ \y -> y*y+y # no = \x -> f x (g x)@@ -1100,8 +1118,7 @@ # main = let (first, rest) = (take n l, drop n l) in rest -- splitAt n l # main = fst (splitAt n l) -- take n l # main = snd $ splitAt n l -- drop n l-# main = map $ \ d -> ([| $d |], [| $d |]) @NoRefactor: apply-refact requires TemplateHaskell pragma-# {-# LANGUAGE TemplateHaskell #-}; main = map $ \ d -> ([| $d |], [| $d |])+# main = map $ \ d -> ([| $d |], [| $d |]) # pairs (x:xs) = map (x,) xs ++ pairs xs # {-# ANN foo "HLint: ignore" #-};foo = map f (map g x) -- @Ignore ??? # {-# HLINT ignore foo #-};foo = map f (map g x) -- @Ignore ???@@ -1152,6 +1169,9 @@ # yes = f ((,) (2 + 3)) -- (2 + 3,) # instance Class X where method = map f (map g x) -- map (f . g) x # instance Eq X where x == y = compare x y == EQ+# issue1055 = map f ((sort . map g) xs)+# issue1049 = True `elem` xs -- or xs+# issue1049 = elem True -- or # import Prelude \ # yes = flip mapM -- Control.Monad.forM@@ -1194,10 +1214,14 @@ # fromList [] -- Data.Map.Lazy.empty # import Data.Map.Strict (fromList) \ # fromList [] -- Data.Map.Strict.empty-# test953 = for [] $ \n -> bar n >>= \case {Just n -> pure (); Nothing -> baz n} @NoRefactor+# test953 = for [] $ \n -> bar n >>= \case {Just n -> pure (); Nothing -> baz n} # f = map (flip (,) "a") "123" -- (,"a") # f = map ((,) "a") "123" -- ("a",)-# test979 = flip Map.traverseWithKey blocks \k v -> lots_of_code_goes_here @NoRefactor+# test979 = flip Map.traverseWithKey blocks \k v -> lots_of_code_goes_here # infixl 4 <*! \ # test993 = f =<< g <$> x <*! y+# {-# LANGUAGE QuasiQuotes #-} \+# test = [issue766| |] -- mempty+# {-# LANGUAGE QuasiQuotes #-} \+# test = [issue766| x |] # </TEST>
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hlint-version: 3.1.4+version: 3.1.5 license: BSD3 license-file: LICENSE category: Development@@ -48,6 +48,11 @@ manual: True description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported +flag hsyaml+ default: False+ manual: True+ description: Use HsYAML instead of yaml+ library default-language: Haskell2010 build-depends:@@ -59,10 +64,9 @@ data-default >= 0.3, cpphs >= 1.20.1, cmdargs >= 0.10,- yaml >= 0.5.0, uniplate >= 1.5, ansi-terminal >= 0.6.2,- extra >= 1.7.1,+ extra >= 1.7.3, refact >= 0.3, aeson >= 1.1.2.0, filepattern >= 0.1.1@@ -76,13 +80,21 @@ build-depends: ghc-lib-parser == 8.10.* build-depends:- ghc-lib-parser-ex >= 8.10.0.11 && < 8.10.1+ ghc-lib-parser-ex >= 8.10.0.14 && < 8.10.1 if flag(gpl) build-depends: hscolour >= 1.21 else cpp-options: -DGPL_SCARES_ME + if flag(hsyaml)+ build-depends:+ HsYAML >= 0.2,+ HsYAML-aeson >= 0.2+ cpp-options: -DHS_YAML+ else+ build-depends: yaml >= 0.5.0+ hs-source-dirs: src exposed-modules: Language.Haskell.HLint@@ -109,20 +121,19 @@ Config.Type Config.Yaml + GHC.All GHC.Util GHC.Util.ApiAnnotation GHC.Util.View GHC.Util.Brackets+ GHC.Util.DynFlags GHC.Util.FreeVars GHC.Util.HsDecl GHC.Util.HsExpr- GHC.Util.Module GHC.Util.SrcLoc- GHC.Util.DynFlags GHC.Util.Scope GHC.Util.Unify - HSE.All Hint.All Hint.Bracket Hint.Comment
src/Apply.hs view
@@ -3,10 +3,10 @@ import Control.Applicative import Data.Monoid-import HSE.All+import GHC.All import Hint.All import GHC.Util-import Data.Generics.Uniplate.Data+import Data.Generics.Uniplate.DataOnly import Idea import Data.Tuple.Extra import Data.Either@@ -15,8 +15,9 @@ import Data.Ord import Config.Type import Config.Haskell+import SrcLoc import GHC.Hs-import qualified SrcLoc as GHC+import Language.Haskell.GhclibParserEx.GHC.Hs import qualified Data.HashSet as Set import Prelude @@ -51,7 +52,7 @@ applyHintsReal settings hints_ ms = concat $ [ map (classify classifiers . removeRequiresExtensionNotes m) $ order [] (hintModule hints settings nm m) `merge`- concat [order (maybeToList $ declName d) $ decHints d | d <- hsmodDecls $ GHC.unLoc $ ghcModule m]+ concat [order (maybeToList $ declName d) $ decHints d | d <- hsmodDecls $ unLoc $ ghcModule m] | (nm,m) <- mns , let classifiers = cls ++ mapMaybe readPragma (universeBi (ghcModule m)) ++ concatMap readComment (ghcComments m) , seq (length classifiers) True -- to force any errors from readPragma or readComment@@ -62,7 +63,7 @@ where f = nubOrd . filter (/= "") cls = [x | SettingClassify x <- settings]- mns = map (\x -> (scopeCreate (GHC.unLoc $ ghcModule x), x)) ms+ mns = map (\x -> (scopeCreate (unLoc $ ghcModule x), x)) ms hints = (if length ms <= 1 then noModules else id) hints_ noModules h = h{hintModules = \_ _ -> []} `mappend` mempty{hintModule = \s a b -> hintModules h s [(a,b)]}
src/CmdLine.hs view
@@ -14,7 +14,7 @@ import Data.List.Extra import Data.Maybe import Data.Functor-import HSE.All(CppFlags(..))+import GHC.All(CppFlags(..)) import GHC.LanguageExtensions.Type import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx import DynFlags hiding (verbosity)@@ -323,6 +323,15 @@ ls = [(show x, x) | x <- [Haskell98, Haskell2010]] f (a, e) "Haskell98" = ([], [])- f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x = (delete x a, x : delete x e)+ f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x =+ (deletes xs a, xs ++ deletes xs e) f (a, e) x | Just x <- GhclibParserEx.readExtension x = (x : delete x a, delete x e) f (a, e) x = (a, e) -- Ignore unknown extension.++ deletes [] ys = ys+ deletes (x:xs) ys = deletes xs $ delete x ys++ -- if you disable a feature that implies another feature, sometimes we should disable both+ -- e.g. no one knows what TemplateHaskellQuotes is https://github.com/ndmitchell/hlint/issues/1038+ expandDisable TemplateHaskell = [TemplateHaskell, TemplateHaskellQuotes]+ expandDisable x = [x]
src/Config/Compute.hs view
@@ -4,11 +4,11 @@ -- | Given a file, guess settings from it by looking at the hints. module Config.Compute(computeSettings) where -import HSE.All+import GHC.All import GHC.Util import Config.Type import Fixity-import Data.Generics.Uniplate.Data+import Data.Generics.Uniplate.DataOnly import GHC.Hs hiding (Warning) import RdrName import Name
src/Config/Yaml.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, GeneralizedNewtypeDeriving, TupleSections #-}+{-# LANGUAGE CPP #-} module Config.Yaml( ConfigYaml,@@ -8,19 +9,17 @@ ) where import Config.Type-import Data.Yaml import Data.Either import Data.Maybe import Data.List.Extra import Data.Tuple.Extra import Control.Monad.Extra-import Control.Exception.Extra import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.ByteString.Char8 as BS import qualified Data.HashMap.Strict as Map-import Data.Generics.Uniplate.Data-import HSE.All+import Data.Generics.Uniplate.DataOnly+import GHC.All import Fixity import Extension import Module@@ -41,6 +40,33 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Data.Char++#ifdef HS_YAML++import Data.YAML (Pos)+import Data.YAML.Aeson (encode1Strict, decode1Strict)+import Data.Aeson hiding (encode)+import Data.Aeson.Types (Parser)+import qualified Data.ByteString as BSS++decodeFileEither :: FilePath -> IO (Either (Pos, String) ConfigYaml)+decodeFileEither path = decode1Strict <$> BSS.readFile path++decodeEither' :: BSS.ByteString -> Either (Pos, String) ConfigYaml+decodeEither' = decode1Strict++displayException :: (Pos, String) -> String+displayException = show++encode :: Value -> BSS.ByteString+encode = encode1Strict++#else++import Data.Yaml+import Control.Exception.Extra++#endif -- | Read a config file in YAML format. Takes a filename, and optionally the contents.
src/Extension.hs view
@@ -24,6 +24,9 @@ {- , XmlSyntax , RegularPatterns -} -- steals a-b and < operators , AlternativeLayoutRule -- Does not play well with 'MultiWayIf' , NegativeLiterals -- Was not enabled by HSE and enabling breaks tests.+ , StarIsType -- conflicts with TypeOperators. StarIsType is currently enabled by default,+ -- so adding it here has no effect except avoiding passing it to apply-refact.+ -- See https://github.com/mpickering/apply-refact/issues/58 ] -- | Extensions we turn on by default when parsing. Aim to parse as
+ src/GHC/All.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++module GHC.All(+ CppFlags(..), ParseFlags(..), defaultParseFlags,+ parseFlagsAddFixities, parseFlagsSetLanguage,+ ParseError(..), ModuleEx(..),+ parseModuleEx, createModuleEx, ghcComments,+ parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,+ ) where++import Util+import Data.Char+import Data.List.Extra+import Timing+import Language.Preprocessor.Cpphs+import qualified Data.Map as Map+import System.IO.Extra+import Fixity+import Extension+import FastString++import GHC.Hs+import SrcLoc+import ErrUtils+import Outputable+import Lexer hiding (context)+import GHC.LanguageExtensions.Type+import ApiAnnotation+import DynFlags hiding (extensions)+import Bag++import Language.Haskell.GhclibParserEx.GHC.Parser+import Language.Haskell.GhclibParserEx.Fixity+import GHC.Util++-- | What C pre processor should be used.+data CppFlags+ = NoCpp -- ^ No pre processing is done.+ | CppSimple -- ^ Lines prefixed with @#@ are stripped.+ | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.++-- | Created with 'defaultParseFlags', used by 'parseModuleEx'.+data ParseFlags = ParseFlags+ {cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').+ ,baseLanguage :: Maybe Language -- ^ Base language (e.g. Haskell98, Haskell2010), defaults to 'Nothing'.+ ,enabledExtensions :: [Extension] -- ^ List of extensions enabled for parsing, defaults to many non-conflicting extensions.+ ,disabledExtensions :: [Extension] -- ^ List of extensions disabled for parsing, usually empty.+ ,fixities :: [FixityInfo] -- ^ List of fixities to be aware of, defaults to those defined in @base@.+ }++-- | Default value for 'ParseFlags'.+defaultParseFlags :: ParseFlags+defaultParseFlags = ParseFlags NoCpp Nothing defaultExtensions [] defaultFixities++-- | Given some fixities, add them to the existing fixities in 'ParseFlags'.+parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags+parseFlagsAddFixities fx x = x{fixities = fx ++ fixities x}++parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension])) -> ParseFlags -> ParseFlags+parseFlagsSetLanguage (l, (es, ds)) x = x{baseLanguage = l, enabledExtensions = es, disabledExtensions = ds}+++runCpp :: CppFlags -> FilePath -> String -> IO String+runCpp NoCpp _ x = pure x+runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]+runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x+ where+ -- LINE pragmas always inserted when locations=True+ dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b+ dropLine x = x++---------------------------------------------------------------------+-- PARSING++-- | A parse error.+data ParseError = ParseError+ { parseErrorLocation :: SrcSpan -- ^ Location of the error.+ , parseErrorMessage :: String -- ^ Message about the cause of the error.+ , parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line.+ }++-- | Result of 'parseModuleEx', representing a parsed module.+data ModuleEx = ModuleEx {+ ghcModule :: Located (HsModule GhcPs)+ , ghcAnnotations :: ApiAnns+}++-- | Extract a list of all of a parsed module's comments.+ghcComments :: ModuleEx -> [Located AnnotationComment]+ghcComments m = concat (Map.elems $ snd (ghcAnnotations m))+++-- | The error handler invoked when GHC parsing has failed.+ghcFailOpParseModuleEx :: String+ -> FilePath+ -> String+ -> (SrcSpan, ErrUtils.MsgDoc)+ -> IO (Either ParseError ModuleEx)+ghcFailOpParseModuleEx ppstr file str (loc, err) = do+ let pe = case loc of+ RealSrcSpan r -> context (srcSpanStartLine r) ppstr+ _ -> ""+ msg = Outputable.showSDoc baseDynFlags err+ pure $ Left $ ParseError loc msg pe++-- GHC extensions to enable/disable given HSE parse flags.+ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])+ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds)++-- GHC fixities given HSE parse flags.+ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]+ghcFixitiesFromParseFlags = map toFixity . fixities++-- These next two functions get called frorm 'Config/Yaml.hs' for user+-- defined hint rules.++parseModeToFlags :: ParseFlags -> DynFlags+parseModeToFlags parseMode =+ flip lang_set (baseLanguage parseMode) $ foldl' xopt_unset (foldl' xopt_set baseDynFlags enable) disable+ where+ (enable, disable) = ghcExtensionsFromParseFlags parseMode++parseExpGhcWithMode :: ParseFlags -> String -> ParseResult (LHsExpr GhcPs)+parseExpGhcWithMode parseMode s =+ let fixities = ghcFixitiesFromParseFlags parseMode+ in case parseExpression s $ parseModeToFlags parseMode of+ POk pst a -> POk pst $ applyFixities fixities a+ f@PFailed{} -> f++parseImportDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LImportDecl GhcPs)+parseImportDeclGhcWithMode parseMode s =+ parseImport s $ parseModeToFlags parseMode++parseDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LHsDecl GhcPs)+parseDeclGhcWithMode parseMode s =+ let fixities = ghcFixitiesFromParseFlags parseMode+ in case parseDeclaration s $ parseModeToFlags parseMode of+ POk pst a -> POk pst $ applyFixities fixities a+ f@PFailed{} -> f++-- | Create a 'ModuleEx' from GHC annotations and module tree. It+-- is assumed the incoming parse module has not been adjusted to+-- account for operator fixities (it uses the HLint default fixities).+createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx+createModuleEx anns ast =+ ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns++-- | Parse a Haskell module. Applies the C pre processor, and uses+-- best-guess fixity resolution if there are ambiguities. The+-- filename @-@ is treated as @stdin@. Requires some flags (often+-- 'defaultParseFlags'), the filename, and optionally the contents of+-- that file.+--+-- Note that certain programs, e.g. @main = do@ successfully parse with GHC, but then+-- fail with an error in the renamer. These programs will return a successful parse.+parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)+parseModuleEx flags file str = timedIO "Parse" file $ do+ str <- case str of+ Just x -> pure x+ Nothing | file == "-" -> getContentsUTF8+ | otherwise -> readFileUTF8' file+ str <- pure $ dropPrefix "\65279" str -- remove the BOM if it exists, see #130+ ppstr <- runCpp (cppFlags flags) file str+ let enableDisableExts = ghcExtensionsFromParseFlags flags+ dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr+ case dynFlags of+ Right ghcFlags -> do+ ghcFlags <- pure $ lang_set ghcFlags $ baseLanguage flags+ case fileToModule file ppstr ghcFlags of+ POk s a -> do+ let errs = bagToList . snd $ getMessages s ghcFlags+ if not $ null errs then+ handleParseFailure ghcFlags ppstr file str errs+ else do+ let anns =+ ( Map.fromListWith (++) $ annotations s+ , Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)+ )+ let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags+ pure $ Right (ModuleEx (applyFixities fixes a) anns)+ PFailed s ->+ handleParseFailure ghcFlags ppstr file str $ bagToList . snd $ getMessages s ghcFlags+ Left msg -> do+ -- Parsing GHC flags from dynamic pragmas in the source+ -- has failed. When this happens, it's reported by+ -- exception. It's impossible or at least fiddly getting a+ -- location so we skip that for now. Synthesize a parse+ -- error.+ let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)+ pure $ Left (ParseError (mkSrcSpan loc loc) msg ppstr)+ where+ handleParseFailure ghcFlags ppstr file str errs =+ let errMsg = head errs+ loc = errMsgSpan errMsg+ doc = formatErrDoc ghcFlags (errMsgDoc errMsg)+ in ghcFailOpParseModuleEx ppstr file str (loc, doc)+++-- | Given a line number, and some source code, put bird ticks around the appropriate bit.+context :: Int -> String -> String+context lineNo src =+ unlines $ dropWhileEnd (all isSpace) $ dropWhile (all isSpace) $+ zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ ["","","","",""]+ where ticks = drop (3 - lineNo) [" "," ","> "," "," "]
src/GHC/Util.hs view
@@ -7,7 +7,6 @@ , module GHC.Util.ApiAnnotation , module GHC.Util.HsDecl , module GHC.Util.HsExpr- , module GHC.Util.Module , module GHC.Util.SrcLoc , module GHC.Util.DynFlags , module GHC.Util.Scope@@ -24,7 +23,6 @@ import GHC.Util.ApiAnnotation import GHC.Util.HsExpr import GHC.Util.HsDecl-import GHC.Util.Module import GHC.Util.SrcLoc import GHC.Util.DynFlags import GHC.Util.Scope
src/GHC/Util/DynFlags.hs view
@@ -3,7 +3,7 @@ import DynFlags import GHC.LanguageExtensions.Type import Data.List.Extra-import Language.Haskell.GhclibParserEx.Config+import Language.Haskell.GhclibParserEx.GHC.Settings.Config baseDynFlags :: DynFlags baseDynFlags =
src/GHC/Util/FreeVars.hs view
@@ -15,8 +15,7 @@ import SrcLoc import Bag (bagToList) -import Data.Generics.Uniplate.Data ()-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Data.Monoid import Data.Semigroup import Data.List.Extra
src/GHC/Util/HsExpr.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns, MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} module GHC.Util.HsExpr (@@ -22,14 +23,14 @@ import Bag(bagToList) import GHC.Util.Brackets-import GHC.Util.View import GHC.Util.FreeVars+import GHC.Util.View import Control.Applicative import Control.Monad.Trans.State import Data.Data-import Data.Generics.Uniplate.Data+import Data.Generics.Uniplate.DataOnly import Data.List.Extra import Data.Tuple.Extra @@ -148,9 +149,8 @@ -- Implementation. Try to produce special forms (e.g. sections, -- compositions) where we can. niceLambdaR :: [String]- -> LHsExpr GhcPs- -> (LHsExpr GhcPs, R.SrcSpan- -> [Refactoring R.SrcSpan])+ -> LHsExpr GhcPs+ -> (LHsExpr GhcPs, R.SrcSpan -> [Refactoring R.SrcSpan]) -- Rewrite @\ -> e@ as @e@ -- These are encountered as recursive calls. niceLambdaR xs (SimpleLambda [] x) = niceLambdaR xs x@@ -174,7 +174,8 @@ , vars e `disjoint` [v] , L _ (HsVar _ (L _ fname)) <- f , isSymOcc $ rdrNameOcc fname- = (noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f, \s -> [Replace Expr s [] (unsafePrettyPrint e)])+ = let res = noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f+ in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)]) -- @\vs v -> f x v@ ==> @\vs -> f x@ niceLambdaR (unsnoc -> Just (vs, v)) (L _ (HsApp _ f (view -> Var_ v')))@@ -290,12 +291,20 @@ g1 = (fst .) . g g2 = (snd .) . g - f i (L _ (HsPar _ y)) z | not $ needBracketOld i x y = (y, z)- f i y z | needBracketOld i x y = (addParen y, addParen z)+ f i (L _ (HsPar _ y)) z+ | not $ needBracketOld i x y = (y, z)+ f i y z+ | needBracketOld i x y = (addParen y, addParen z)+ -- https://github.com/mpickering/apply-refact/issues/7+ | isOp y = (y, addParen z) f _ y z = (y, z) f1 = ((fst .) .) . f f2 = ((snd .) .) . f++ isOp = \case+ L _ (HsVar _ (L _ name)) -> isSymbolRdrName name+ _ -> False fromParen1 :: LHsExpr GhcPs -> LHsExpr GhcPs fromParen1 (L _ (HsPar _ x)) = x
− src/GHC/Util/Module.hs
@@ -1,13 +0,0 @@--module GHC.Util.Module (modName, fromModuleName') where--import GHC.Hs-import Module-import SrcLoc--modName :: Located (HsModule GhcPs) -> String-modName (L _ HsModule {hsmodName=Nothing}) = "Main"-modName (L _ HsModule {hsmodName=Just (L _ n)}) = moduleNameString n--fromModuleName' :: Located ModuleName -> String-fromModuleName' (L _ n) = moduleNameString n
src/GHC/Util/Scope.hs view
@@ -15,7 +15,6 @@ import RdrName import OccName -import GHC.Util.Module import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable @@ -47,7 +46,7 @@ -- Predicate to test for a 'Prelude' import declaration. isPrelude :: LImportDecl GhcPs -> Bool- isPrelude (L _ x) = fromModuleName' (ideclName x) == "Prelude"+ isPrelude (L _ x) = moduleNameString (unLoc (ideclName x)) == "Prelude" -- Test if two names in two scopes may be referring to the same -- thing. This is the case if the names are equal and (1) denote a@@ -58,7 +57,7 @@ | isSpecial x && isSpecial y = rdrNameStr x == rdrNameStr y | isSpecial x || isSpecial y = False | otherwise =- rdrNameStr (unqual x) == rdrNameStr (unqual y) && not (possModules a x `disjoint` possModules b y)+ rdrNameStr (unqual x) == rdrNameStr (unqual y) && not (possModules a x `disjointOrd` possModules b y) -- Given a name in a scope, and a new scope, create a name for the new -- scope that will refer to the same thing. If the resulting name is
src/GHC/Util/SrcLoc.hs view
@@ -10,7 +10,7 @@ import Data.Default import Data.Data-import Data.Generics.Uniplate.Data+import Data.Generics.Uniplate.DataOnly -- 'stripLocs x' is 'x' with all contained source locs replaced by -- 'noSrcSpan'.
src/GHC/Util/Unify.hs view
@@ -9,7 +9,7 @@ import Control.Applicative import Control.Monad-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Data.Char import Data.Data import Data.List.Extra@@ -26,6 +26,7 @@ import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import GHC.Util.HsExpr import GHC.Util.View+import FastString isUnifyVar :: String -> Bool isUnifyVar [x] = x == '?' || isAlpha x@@ -105,6 +106,7 @@ | Just (x, y) <- cast (x, y) = unifyExp' nm root x y | Just (x, y) <- cast (x, y) = unifyPat' nm x y | Just (x, y) <- cast (x, y) = unifyType' nm x y+ | Just (x, y) <- cast (x, y) = if (x :: FastString) == y then Just mempty else Nothing | Just (x :: SrcSpan) <- cast x = Just mempty | otherwise = unifyDef' nm x y @@ -149,17 +151,19 @@ -- Unify a function application where the function is a composition of functions. unifyComposed | (L _ (OpApp _ y11 dot y12)) <- fromParen y1, isDot dot =- -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'.- -- The guard ensures that you don't get duplicate matches because the matching engine- -- auto-generates hints in dot-form.- (guard (not root) >> (, Nothing) <$> unifyExp' nm root x (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2)))))- -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg',- -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',- -- and so on, unify the rhs of '$' with 'x', and store the lhs of '$' into 'extra'.- <|> do- rhs <- unifyExp' nm False x2 y2- (lhs, extra) <- unifyComposed' nm x1 y11 dot y12- pure (lhs <> rhs, extra)+ if not root then+ -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'.+ -- The guard ensures that you don't get duplicate matches because the matching engine+ -- auto-generates hints in dot-form.+ (, Nothing) <$> unifyExp' nm root x (noLoc (HsApp noExtField y11 (noLoc (HsApp noExtField y12 y2))))+ else do+ -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg',+ -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',+ -- and so on, unify the rhs of '$' with 'x', and store the lhs of '$' into 'extra'.+ -- You can only add to extra if you are at the root (otherwise 'extra' has nowhere to go).+ rhs <- unifyExp' nm False x2 y2+ (lhs, extra) <- unifyComposed' nm x1 y11 dot y12+ pure (lhs <> rhs, extra) | otherwise = Nothing -- Options: match directly, then expand through '$', then desugar infix.@@ -170,11 +174,16 @@ | otherwise = unifyExp nm root x $ noLoc (HsApp noExtField (noLoc (HsApp noExtField op2 lhs2)) rhs2) unifyExp nm root x y = (, Nothing) <$> unifyExp' nm root x y +-- | If we "throw away" the extra than we have no where to put it, and the substitution is wrong+noExtra :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) -> Maybe (Subst (LHsExpr GhcPs))+noExtra (Just (x, Nothing)) = Just x+noExtra _ = Nothing+ -- App/InfixApp are analysed specially for performance reasons. If -- 'root = True', this is the outside of the expr. Do not expand out a -- dot at the root, since otherwise you get two matches because of -- 'readRule' (Bug #570).-unifyExp' :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs) )+unifyExp' :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs)) -- Brackets are not added when expanding '$' in user code, so tolerate -- them in the match even if they aren't in the user code. unifyExp' nm root x y | not root, isPar x, not $ isPar y = unifyExp' nm root (fromParen x) y@@ -185,7 +194,7 @@ unifyExp' nm root x@(L _ (OpApp _ lhs1 (L _ (HsVar _ (rdrNameStr -> v))) rhs1)) y@(L _ (OpApp _ lhs2 (L _ (HsVar _ op2)) rhs2)) =- fst <$> unifyExp nm root x y+ noExtra $ unifyExp nm root x y unifyExp' nm root (L _ (SectionL _ exp1 (L _ (HsVar _ (rdrNameStr -> v))))) (L _ (SectionL _ exp2 (L _ (HsVar _ (rdrNameStr -> op2))))) | isUnifyVar v = (Subst [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2@@ -194,10 +203,10 @@ | isUnifyVar v = (Subst [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2 unifyExp' nm root x@(L _ (HsApp _ x1 x2)) y@(L _ (HsApp _ y1 y2)) =- fst <$> unifyExp nm root x y+ noExtra $ unifyExp nm root x y unifyExp' nm root x y@(L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) =- fst <$> unifyExp nm root x y+ noExtra $ unifyExp nm root x y unifyExp' nm root x y | isOther x, isOther y = unifyDef' nm x y where
src/Grep.hs view
@@ -4,7 +4,7 @@ import Hint.All import Apply import Config.Type-import HSE.All+import GHC.All import Control.Monad import Data.List import Util
src/HLint.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} @@ -31,7 +32,7 @@ import Timing import Test.Proof import Parallel-import HSE.All+import GHC.All import CC import EmbedData @@ -194,9 +195,9 @@ let hints = show $ map (show &&& ideaRefactoring) ideas withTempFile $ \f -> do writeFile f hints- exitWith =<< runRefactoring path file f cmdRefactorOptions+ let ParseFlags{enabledExtensions, disabledExtensions} = cmdParseFlags cmd+ exitWith =<< runRefactoring path file f enabledExtensions disabledExtensions cmdRefactorOptions _ -> errorIO "Refactor flag can only be used with an individual file"- handleReporting :: [Idea] -> Cmd -> IO () handleReporting showideas cmd@CmdMain{..} = do
− src/HSE/All.hs
@@ -1,205 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}--module HSE.All(- CppFlags(..), ParseFlags(..), defaultParseFlags,- parseFlagsAddFixities, parseFlagsSetLanguage,- ParseError(..), ModuleEx(..),- parseModuleEx, createModuleEx, ghcComments,- parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,- ) where--import Util-import Data.Char-import Data.List.Extra-import Timing-import Language.Preprocessor.Cpphs-import qualified Data.Map as Map-import System.IO.Extra-import Fixity-import Extension-import FastString--import GHC.Hs-import SrcLoc-import ErrUtils-import Outputable-import Lexer hiding (context)-import GHC.LanguageExtensions.Type-import ApiAnnotation-import DynFlags hiding (extensions)-import Bag--import Language.Haskell.GhclibParserEx.GHC.Parser-import Language.Haskell.GhclibParserEx.Fixity-import GHC.Util---- | What C pre processor should be used.-data CppFlags- = NoCpp -- ^ No pre processing is done.- | CppSimple -- ^ Lines prefixed with @#@ are stripped.- | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.---- | Created with 'defaultParseFlags', used by 'parseModuleEx'.-data ParseFlags = ParseFlags- {cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').- ,baseLanguage :: Maybe Language -- ^ Base language (e.g. Haskell98, Haskell2010), defaults to 'Nothing'.- ,enabledExtensions :: [Extension] -- ^ List of extensions enabled for parsing, defaults to many non-conflicting extensions.- ,disabledExtensions :: [Extension] -- ^ List of extensions disabled for parsing, usually empty.- ,fixities :: [FixityInfo] -- ^ List of fixities to be aware of, defaults to those defined in @base@.- }---- | Default value for 'ParseFlags'.-defaultParseFlags :: ParseFlags-defaultParseFlags = ParseFlags NoCpp Nothing defaultExtensions [] defaultFixities---- | Given some fixities, add them to the existing fixities in 'ParseFlags'.-parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags-parseFlagsAddFixities fx x = x{fixities = fx ++ fixities x}--parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension])) -> ParseFlags -> ParseFlags-parseFlagsSetLanguage (l, (es, ds)) x = x{baseLanguage = l, enabledExtensions = es, disabledExtensions = ds}---runCpp :: CppFlags -> FilePath -> String -> IO String-runCpp NoCpp _ x = pure x-runCpp CppSimple _ x = pure $ unlines [if "#" `isPrefixOf` trimStart x then "" else x | x <- lines x]-runCpp (Cpphs o) file x = dropLine <$> runCpphs o file x- where- -- LINE pragmas always inserted when locations=True- dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b- dropLine x = x-------------------------------------------------------------------------- PARSING---- | A parse error.-data ParseError = ParseError- { parseErrorLocation :: SrcSpan -- ^ Location of the error.- , parseErrorMessage :: String -- ^ Message about the cause of the error.- , parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line.- }---- | Result of 'parseModuleEx', representing a parsed module.-data ModuleEx = ModuleEx {- ghcModule :: Located (HsModule GhcPs)- , ghcAnnotations :: ApiAnns-}---- | Extract a list of all of a parsed module's comments.-ghcComments :: ModuleEx -> [Located AnnotationComment]-ghcComments m = concat (Map.elems $ snd (ghcAnnotations m))----- | The error handler invoked when GHC parsing has failed.-ghcFailOpParseModuleEx :: String- -> FilePath- -> String- -> (SrcSpan, ErrUtils.MsgDoc)- -> IO (Either ParseError ModuleEx)-ghcFailOpParseModuleEx ppstr file str (loc, err) = do- let pe = case loc of- RealSrcSpan r -> context (srcSpanStartLine r) ppstr- _ -> ""- msg = Outputable.showSDoc baseDynFlags err- pure $ Left $ ParseError loc msg pe---- GHC extensions to enable/disable given HSE parse flags.-ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])-ghcExtensionsFromParseFlags ParseFlags{enabledExtensions=es, disabledExtensions=ds}= (es, ds)---- GHC fixities given HSE parse flags.-ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]-ghcFixitiesFromParseFlags = map toFixity . fixities---- These next two functions get called frorm 'Config/Yaml.hs' for user--- defined hint rules.--parseModeToFlags :: ParseFlags -> DynFlags-parseModeToFlags parseMode =- flip lang_set (baseLanguage parseMode) $ foldl' xopt_unset (foldl' xopt_set baseDynFlags enable) disable- where- (enable, disable) = ghcExtensionsFromParseFlags parseMode--parseExpGhcWithMode :: ParseFlags -> String -> ParseResult (LHsExpr GhcPs)-parseExpGhcWithMode parseMode s =- let fixities = ghcFixitiesFromParseFlags parseMode- in case parseExpression s $ parseModeToFlags parseMode of- POk pst a -> POk pst $ applyFixities fixities a- f@PFailed{} -> f--parseImportDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LImportDecl GhcPs)-parseImportDeclGhcWithMode parseMode s =- parseImport s $ parseModeToFlags parseMode--parseDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LHsDecl GhcPs)-parseDeclGhcWithMode parseMode s =- let fixities = ghcFixitiesFromParseFlags parseMode- in case parseDeclaration s $ parseModeToFlags parseMode of- POk pst a -> POk pst $ applyFixities fixities a- f@PFailed{} -> f---- | Create a 'ModuleEx' from GHC annotations and module tree. It--- is assumed the incoming parse module has not been adjusted to--- account for operator fixities (it uses the HLint default fixities).-createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx-createModuleEx anns ast =- ModuleEx (applyFixities (fixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns---- | Parse a Haskell module. Applies the C pre processor, and uses--- best-guess fixity resolution if there are ambiguities. The--- filename @-@ is treated as @stdin@. Requires some flags (often--- 'defaultParseFlags'), the filename, and optionally the contents of--- that file.------ Note that certain programs, e.g. @main = do@ successfully parse with GHC, but then--- fail with an error in the renamer. These programs will return a successful parse.-parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)-parseModuleEx flags file str = timedIO "Parse" file $ do- str <- case str of- Just x -> pure x- Nothing | file == "-" -> getContentsUTF8- | otherwise -> readFileUTF8' file- str <- pure $ dropPrefix "\65279" str -- remove the BOM if it exists, see #130- ppstr <- runCpp (cppFlags flags) file str- let enableDisableExts = ghcExtensionsFromParseFlags flags- dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr- case dynFlags of- Right ghcFlags -> do- ghcFlags <- pure $ lang_set ghcFlags $ baseLanguage flags- case fileToModule file ppstr ghcFlags of- POk s a -> do- let errs = bagToList . snd $ getMessages s ghcFlags- if not $ null errs then- handleParseFailure ghcFlags ppstr file str errs- else do- let anns =- ( Map.fromListWith (++) $ annotations s- , Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)- )- let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags- pure $ Right (ModuleEx (applyFixities fixes a) anns)- PFailed s ->- handleParseFailure ghcFlags ppstr file str $ bagToList . snd $ getMessages s ghcFlags- Left msg -> do- -- Parsing GHC flags from dynamic pragmas in the source- -- has failed. When this happens, it's reported by- -- exception. It's impossible or at least fiddly getting a- -- location so we skip that for now. Synthesize a parse- -- error.- let loc = mkSrcLoc (mkFastString file) (1 :: Int) (1 :: Int)- pure $ Left (ParseError (mkSrcSpan loc loc) msg ppstr)- where- handleParseFailure ghcFlags ppstr file str errs =- let errMsg = head errs- loc = errMsgSpan errMsg- doc = formatErrDoc ghcFlags (errMsgDoc errMsg)- in ghcFailOpParseModuleEx ppstr file str (loc, doc)----- | Given a line number, and some source code, put bird ticks around the appropriate bit.-context :: Int -> String -> String-context lineNo src =- unlines $ dropWhileEnd (all isSpace) $ dropWhile (all isSpace) $- zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ ["","","","",""]- where ticks = drop (3 - lineNo) [" "," ","> "," "," "]
src/Hint/Bracket.hs view
@@ -41,7 +41,7 @@ issue909 = let ((x:: y) -> z) = q in q issue909 = do {((x :: y) -> z) <- e; return 1} issue970 = (f x +) (g x) -- f x + (g x) @NoRefactor-issue969 = (Just \x -> x || x) *> Just True @NoRefactor+issue969 = (Just \x -> x || x) *> Just True -- type bracket reduction foo :: (Int -> Int) -> Int@@ -58,12 +58,12 @@ -- dollar reduction tests no = groupFsts . sortFst $ mr-yes = split "to" $ names ---yes = white $ keysymbol ---yes = operator foo $ operator --+yes = split "to" $ names -- split "to" names+yes = white $ keysymbol -- white keysymbol+yes = operator foo $ operator -- operator foo operator no = operator foo $ operator bar yes = return $ Record{a=b}-no = f $ [1,2..5] -- @NoRefactor: apply-refact bug; see apply-refact #51+no = f $ [1,2..5] -- f [1,2..5] @NoRefactor: apply-refact bug; see apply-refact #51 -- $/bracket rotation tests yes = (b $ c d) ++ e -- b (c d) ++ e@@ -98,10 +98,10 @@ module Hint.Bracket(bracketHint) where -import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,suggestRemove,Severity(..),toRefactSrcSpan,toSS)+import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSS) import Data.Data import Data.List.Extra-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Refact.Types import GHC.Hs@@ -183,7 +183,7 @@ -- 'x' actually need bracketing in this context? f (Just (i, o, gen)) v@(remParens' -> Just x) | not $ needBracket i o x, not $ isPartialAtom x =- rawIdea Suggestion msg (getLoc o) (pretty o) (Just (pretty (gen x))) [] [r] : g x+ rawIdea Suggestion msg (getLoc v) (pretty o) (Just (pretty (gen x))) [] [r] : g x where typ = findType (unLoc v) r = Replace typ (toSS v) [("x", toSS x)] "x"@@ -207,7 +207,7 @@ fieldDecl :: LConDeclField GhcPs -> [Idea] fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) = let r = L loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in- [rawIdea Suggestion "Redundant bracket" loc+ [rawIdea Suggestion "Redundant bracket" l (showSDocUnsafe $ ppr_fld o) -- Note this custom printer! (Just (showSDocUnsafe $ ppr_fld r)) []@@ -230,7 +230,7 @@ dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe where- f x = [ suggestRemove "Redundant $" (getLoc d) "$" [r]| (L _ (OpApp _ a d b)) <- [x], isDol d+ f x = [ (suggest "Redundant $" x y [r]){ideaSpan = getLoc d} | o@(L _ (OpApp _ a d b)) <- [x], isDol d , let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs , not $ needBracket 0 y a , not $ needBracket 1 y b@@ -245,7 +245,7 @@ , let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2)) , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ] ++ -- Special case of (v1 . v2) <$> v3- [ suggest "Redundant bracket" x y [r]+ [ (suggest "Redundant bracket" x y [r]){ideaSpan = locPar} | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x], varToStr o2 == "<$>" , let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs , let r = Replace Expr (toRefactSrcSpan locPar) [("a", toRefactSrcSpan locNoPar)] "a"]
src/Hint/Duplicate.hs view
@@ -24,11 +24,12 @@ import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN,Severity(Suggestion,Warning)) import Data.Data-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Data.Default import Data.Maybe import Data.Tuple.Extra import Data.List hiding (find)+import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import SrcLoc@@ -36,6 +37,7 @@ import Outputable import Bag import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable @@ -94,19 +96,23 @@ duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe def Map.empty) xs where f :: Dupe pos val -> [(pos, val)] -> (Dupe pos val, [[(pos, pos, [val])]])- f d xs = second overlaps $ mapAccumL (g pos) d $ takeWhile ((>= threshold) . length) $ tails xs+ f d xs = second overlaps $ mapAccumL (g pos) d $ onlyAtLeast threshold $ tails xs where pos = Map.fromList $ zip (map fst xs) [0..] - g :: Map.Map pos Int -> Dupe pos val -> [(pos, val)] -> (Dupe pos val, [(pos, pos, [val])])+ g :: Map.Map pos Int -> Dupe pos val -> NE.NonEmpty (pos, val) -> (Dupe pos val, [(pos, pos, [val])]) g pos d xs = (d2, res) where res = [(p,pme,take mx vs) | i >= threshold ,let mx = maybe i (\x -> min i $ (pos Map.! pme) - x) $ Map.lookup p pos ,mx >= threshold]- vs = map snd xs+ vs = NE.toList $ snd <$> xs (p,i) = find vs d- pme = fst $ head xs+ pme = fst $ NE.head xs d2 = add pme vs d++ onlyAtLeast n = mapMaybe $ \l -> case l of+ x:xs | length l >= n -> Just (x NE.:| xs)+ _ -> Nothing overlaps (x@((_,_,n):_):xs) = x : overlaps (drop (length n - 1) xs) overlaps (x:xs) = x : overlaps xs
src/Hint/Extensions.hs view
@@ -138,6 +138,16 @@ main = "test" {-# LANGUAGE OverloadedStrings #-} \ main = id --+{-# LANGUAGE OverloadedLists #-} \+main = [1]+{-# LANGUAGE OverloadedLists #-} \+main [1] = True+{-# LANGUAGE OverloadedLists #-} \+main = id --+{-# LANGUAGE OverloadedLabels #-} \+main = #foo+{-# LANGUAGE OverloadedLabels #-} \+main = id -- {-# LANGUAGE DeriveAnyClass #-} \ main = id -- {-# LANGUAGE DeriveAnyClass #-} \@@ -215,9 +225,8 @@ import Hint.Type(ModuHint, rawIdea,Severity(Warning),Note(..),toSS,ghcAnnotations,ghcModule) import Extension -import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Control.Monad.Extra-import Data.Char import Data.Maybe import Data.List.Extra import Data.Data@@ -379,10 +388,8 @@ (TyClD _ ClassDecl{tcdLName, tcdATs}) -> any isOp (tcdLName : [fdLName famDecl | L _ famDecl <- tcdATs]) _ -> False - isOp :: LIdP GhcPs -> Bool- isOp name = case rdrNameStr name of- (c:_) -> not $ isAlpha c || c == '_'- _ -> False+ isOp (L _ name) = isSymbolRdrName name+ used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot used RecordPuns = hasS isPFieldPun ||^ hasS isFieldPun ||^ hasS isFieldPunUpdate used UnboxedTuples = hasS isUnboxedTuple ||^ hasS (== Unboxed) ||^ hasS isDeriving@@ -422,6 +429,23 @@ used LambdaCase = hasS isLCase used TupleSections = hasS isTupleSection used OverloadedStrings = hasS isString+used OverloadedLists = hasS isListExpr ||^ hasS isListPat+ where+ isListExpr :: HsExpr GhcPs -> Bool+ isListExpr ExplicitList{} = True+ isListExpr ArithSeq{} = True+ isListExpr _ = False++ isListPat :: Pat GhcPs -> Bool+ isListPat ListPat{} = True+ isListPat _ = False++used OverloadedLabels = hasS isLabel+ where+ isLabel :: HsExpr GhcPs -> Bool+ isLabel HsOverLabel{} = True+ isLabel _ = False+ used Arrows = hasS isProc used TransformListComp = hasS isTransStmt used MagicHash = hasS f ||^ hasS isPrimLiteral
src/Hint/Import.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, RecordWildCards #-}+{-# LANGUAGE LambdaCase, PatternGuards, RecordWildCards #-} {- Reduce the number of import declarations. Two import declarations can be combined if:@@ -28,31 +28,27 @@ import qualified A; import A import B; import A; import A -- import A import A hiding(Foo); import A hiding(Bar)-import List -- import Data.List @NoRefactor: apply-refact bug-import qualified List -- import qualified Data.List as List @NoRefactor-import Char(foo) -- import Data.Char(foo) @NoRefactor-import IO(foo)-import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception as X (bracket,bracket_) @NoRefactor+import A (foo) \+import A (bar) \+import A (baz) -- import A ( foo, bar, baz ) </TEST> -} module Hint.Import(importHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSS,rawIdea,rawIdeaN)+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSS,rawIdea) import Refact.Types hiding (ModuleName) import qualified Refact.Types as R import Data.Tuple.Extra import Data.List.Extra-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Data.Maybe import Control.Applicative import Prelude import FastString import BasicTypes-import RdrName-import Module import GHC.Hs import SrcLoc @@ -69,10 +65,7 @@ , let n = unLoc $ ideclName i' , let pkg = unpackFS . sl_fs <$> ideclPkgQual i']) ++ -- Ideas for removing redundant 'as' clauses.- concatMap stripRedundantAlias ms ++- -- Ideas for replacing deprecated imports by their preferred- -- equivalents.- concatMap preferHierarchicalImports ms+ concatMap stripRedundantAlias ms reduceImports :: [LImportDecl GhcPs] -> [Idea] reduceImports [] = []@@ -86,7 +79,9 @@ simplify [] = Nothing simplify (x : xs) = case simplifyHead x xs of Nothing -> first (x:) <$> simplify xs- Just (xs, rs) -> Just $ maybe (xs, rs) (second (++ rs)) $ simplify xs+ Just (xs, rs) ->+ let deletions = filter (\case Delete{} -> True; _ -> False) rs+ in Just $ maybe (xs, rs) (second (++ deletions)) $ simplify xs simplifyHead :: LImportDecl GhcPs -> [LImportDecl GhcPs]@@ -99,7 +94,7 @@ combine :: LImportDecl GhcPs -> LImportDecl GhcPs -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan])-combine x@(L _ x') y@(L _ y')+combine x@(L loc x') y@(L _ y') -- Both (un/)qualified, common 'as', same names : Delete the second. | qual, as, specs = Just (x, [Delete Import (toSS y)]) -- Both (un/)qualified, common 'as', different names : Merge the@@ -107,7 +102,7 @@ | qual, as , Just (False, xs) <- ideclHiding x' , Just (False, ys) <- ideclHiding y' =- let newImp = noLoc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))}+ let newImp = L loc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))} in Just (newImp, [Replace Import (toSS x) [] (unsafePrettyPrint (unLoc newImp)) , Delete Import (toSS y)]) -- Both (un/qualified), common 'as', one has names the other doesn't@@ -140,51 +135,3 @@ | Just (unLoc ideclName) == fmap unLoc ideclAs = [suggest "Redundant as" x (cL loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS x)]] stripRedundantAlias _ = []--preferHierarchicalImports :: LImportDecl GhcPs -> [Idea]-preferHierarchicalImports x@(L loc i@ImportDecl{ideclName=L _ n,ideclPkgQual=Nothing})- -- Suggest 'import IO' be rewritten 'import System.IO, import- -- System.IO.Error, import Control.Exception(bracket, bracket_)'.- | n == mkModuleName "IO" && isNothing (ideclHiding i) =- [rawIdeaN Suggestion "Use hierarchical imports" loc- (trimStart $ unsafePrettyPrint i) (- Just $ unlines $ map (trimStart . unsafePrettyPrint)- [ f "System.IO" Nothing, f "System.IO.Error" Nothing- , f "Control.Exception" $ Just (False, noLoc [mkLIE x | x <- ["bracket","bracket_"]])]) []]- -- Suggest that a module import like 'Monad' should be rewritten with- -- its hiearchical equivalent e.g. 'Control.Monad'.- | Just y <- lookup (moduleNameString n) newNames =- let newModuleName = y ++ "." ++ moduleNameString n- r = [Replace R.ModuleName (toSS x) [] newModuleName] in- [suggest "Use hierarchical imports"- x (noLoc (desugarQual i){ideclName=noLoc (mkModuleName newModuleName)} :: LImportDecl GhcPs) r]- where- -- Substitute a new module name.- f a b = (desugarQual i){ideclName=noLoc (mkModuleName a), ideclHiding=b}- -- Wrap a literal name into an 'IE' (import/export) value.- mkLIE :: String -> LIE GhcPs- mkLIE n = noLoc $ IEVar noExtField (noLoc (IEName (noLoc (mkVarUnqual (fsLit n)))))- -- Rewrite 'import qualified X' as 'import qualified X as X'.- desugarQual :: ImportDecl GhcPs -> ImportDecl GhcPs- desugarQual i- | ideclQualified i /= NotQualified && isNothing (ideclAs i) = i{ideclAs = Just (ideclName i)}- | otherwise = i--preferHierarchicalImports _ = []--newNames :: [(String, String)]-newNames = let (*) = flip (,) in- ["Control" * "Monad"- ,"Data" * "Char"- ,"Data" * "List"- ,"Data" * "Maybe"- ,"Data" * "Ratio"- ,"System" * "Directory"-- -- Special, see bug https://code.google.com/archive/p/ndmitchell/issues/393- -- ,"System" * "IO"-- -- Do not encourage use of old-locale/old-time over haskell98- -- ,"System" * "Locale"- -- ,"System" * "Time"- ]
src/Hint/Lambda.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns, PatternGuards #-}+{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-} {- Concept:@@ -22,7 +22,9 @@ <TEST> f a = \x -> x + x -- f a x = x + x f a = \a -> a + a -- f _ a = a + a-f (Just a) = \a -> a + a -- f (Just _) a = a + a @NoRefactor+a = \x -> x + x -- a x = x + x+f (Just a) = \a -> a + a -- f (Just _) a = a + a+f (Foo a b c) = \c -> c + c -- f (Foo a b _) c = c + c f a = \x -> x + x where _ = test f (test -> a) = \x -> x + x f = \x -> x + x -- f x = x + x@@ -84,7 +86,7 @@ yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file @NoRefactor yes = blah (\ x -> (y, x, z+x)) tmp = map (\ x -> runST $ action x)-yes = map (\f -> dataDir </> f) dataFiles -- (dataDir </>) @NoRefactor+yes = map (\f -> dataDir </> f) dataFiles -- (dataDir </>) {-# LANGUAGE TypeApplications #-}; noBug545 = coerce ((<>) @[a]) {-# LANGUAGE QuasiQuotes #-}; authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name {-# LANGUAGE QuasiQuotes #-}; authOAuth2 = foo (\name -> authOAuth2Widget [whamlet|Login via #{name}|] name)@@ -100,9 +102,10 @@ import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote) import Util import Data.List.Extra+import Data.Set (Set) import qualified Data.Set as Set import Refact.Types hiding (RType(Match))-import Data.Generics.Uniplate.Operations (universe, universeBi, transformBi)+import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi) import BasicTypes import GHC.Hs@@ -125,18 +128,18 @@ lambdaDecl :: LHsDecl GhcPs -> [Idea] lambdaDecl o@(L _ (ValD _- origBind@FunBind {fun_id = L loc1 _, fun_matches =+ origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches = MG {mg_alts = L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}})) | L _ (EmptyLocalBinds noExtField) <- bind , isLambda $ fromParen origBody , null (universeBi pats :: [HsExpr GhcPs])- = [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) s1 t1]]+ = [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) subts template]] | length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind = [warn "Eta reduce" (reform pats origBody) (reform pats2 bod2) [ -- Disabled, see apply-refact #3- -- Replace Decl (toSS $ reform' pats origBody) s2 t2]]- ]]+ ]+ ] where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs reform ps b = L loc $ ValD noExtField $ origBind@@ -149,12 +152,9 @@ (finalpats, body) = fromLambda . lambda pats $ origBody (pats2, bod2) = etaReduce pats origBody- template fps = unsafePrettyPrint $ reform (zipWith munge ['a'..'z'] fps) varBody- subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps)- s1 = subts finalpats body- --s2 = subts pats2 bod2- t1 = template finalpats- --t2 = template pats2 bod2+ (origPats, subtsVars) = mkOrigPats (Just (rdrNameStr funName)) finalpats+ subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) subtsVars (map toSS finalpats)+ template = unsafePrettyPrint (reform origPats varBody) lambdaDecl _ = [] @@ -186,10 +186,15 @@ , not $ any isQuasiQuote $ universe res , not $ "runST" `Set.member` Set.map occNameString (freeVars o) , let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "")- = [(if isVar res then warn else suggest) name o res (refact $ toSS o)]+ -- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses.+ , let from = case (p, res) of+ (Just p@(L _ (HsPar _ (L _ HsLam{}))), L _ HsPar{}) -> p+ _ -> o+ = [(if isVar res then warn else suggest) name from res (refact $ toSS from)] where countRightSections :: LHsExpr GhcPs -> Int countRightSections x = length [() | L _ (SectionR _ (view -> Var_ _) _) <- universe x]+ lambdaExp p o@(SimpleLambda origPats origBody) | isLambda (fromParen origBody) , null (universeBi origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that?@@ -197,10 +202,9 @@ [suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]] where (pats, body) = fromLambda o-- template = unsafePrettyPrint $ lambda (zipWith munge ['a'..'z'] pats) varBody-- subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats)+ (oPats, subtsVars) = mkOrigPats Nothing pats+ subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) subtsVars (map toSS pats)+ template = unsafePrettyPrint (lambda oPats varBody) -- match a lambda with a variable pattern, with no guards and no where clauses lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) =@@ -268,7 +272,31 @@ f bad x = x fromLambda x = ([], x) --- | Replaces all non-wildcard patterns with a variable pattern with the given identifier.-munge :: Char -> LPat GhcPs -> LPat GhcPs-munge ident p@(L _ (WildPat _)) = p-munge ident (L ploc p) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc [ident]))+-- | For each pattern, if it does not contain wildcards, replace it with a variable pattern.+--+-- The second component of the result is a list of substitution variables, which is ['a'..'z'],+-- excluding variables that occur in the function name or patterns with wildcards. For example, given+-- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are removed.+mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [Char])+mkOrigPats funName pats = (zipWith munge subtsVars pats', subtsVars)+ where+ (Set.unions -> used, pats') = unzip (map f pats)++ -- Remove variables that occur in the function name or patterns with wildcards+ subtsVars = filter (\c -> c `Set.notMember` used && Just [c] /= funName) ['a'..'z']++ -- Returns (chars in the pattern if the pattern contains wildcards, (whether the pattern contains wildcards, the pattern))+ f :: LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))+ f p+ | any isWildPat (universe p) =+ let used = Set.fromList [c | (L _ (VarPat _ (rdrNameStr -> [c]))) <- universe p]+ in (used, (True, p))+ | otherwise = (mempty, (False, p))++ isWildPat :: LPat GhcPs -> Bool+ isWildPat = \case (L _ (WildPat _)) -> True; _ -> False++ -- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards.+ munge :: Char -> (Bool, LPat GhcPs) -> LPat GhcPs+ munge _ (True, p) = p+ munge ident (False, L ploc _) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc [ident]))
src/Hint/List.hs view
@@ -13,7 +13,7 @@ no = "x" ++ xs no = [x] ++ xs ++ ys no = xs ++ [x] ++ ys-yes = [if a then b else c] ++ xs -- (if a then b else c) : xs @NoRefactor: hlint bug, missing brackets in refactoring template+yes = [if a then b else c] ++ xs -- (if a then b else c) : xs yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]] yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs data Yes = Yes (Maybe [Char]) -- Maybe String@@ -33,18 +33,19 @@ {-# LANGUAGE MonadComprehensions #-}\ foo = [x | False, x <- [1 .. 10]] -- [] foo = [_ | x <- _, let _ = A{x}]+issue1039 = foo (map f [1 | _ <- []]) -- [f 1 | _ <- []] </TEST> -} module Hint.List(listHint) where import Control.Applicative-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Data.List.Extra import Data.Maybe import Prelude -import Hint.Type(DeclHint,Idea,suggest,toRefactSrcSpan,toSS)+import Hint.Type(DeclHint,Idea,suggest,ignore,toRefactSrcSpan,toSS) import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R@@ -84,6 +85,7 @@ listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) = listCompCheckGuards o MonadComp stmts +listComp (L _ HsPar{}) = [] -- App2 "sees through" paren, which causes duplicate hints with universeBi listComp o@(view -> App2 mp f (L _ (HsDo _ ListComp (L _ stmts)))) = listCompCheckMap o mp f ListComp stmts listComp o@(view -> App2 mp f (L _ (HsDo _ MonadComp (L _ stmts)))) =@@ -230,17 +232,17 @@ useCons :: View a App2 => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useCons False (view -> App2 op x y) | varToStr op == "++"- , Just (x2, build) <- f x- , not $ isAppend y =- Just (gen (build x2) y- , [("x", toSS x2), ("xs", toSS y)]- , unsafePrettyPrint $ gen (build $ strToVar "x") (strToVar "xs")+ , Just (newX, tplX, spanX) <- f x+ , not $ isAppend y =+ Just (gen newX y+ , [("x", spanX), ("xs", toSS y)]+ , unsafePrettyPrint $ gen tplX (strToVar "xs") ) where- f :: LHsExpr GhcPs ->- Maybe (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)- f (L _ (ExplicitList _ _ [x]))=- Just (x, \v -> if isApp x then v else paren v)+ f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, R.SrcSpan)+ f (L _ (ExplicitList _ _ [x]))+ | isAtom x || isApp x = Just (x, strToVar "x", toSS x)+ | otherwise = Just (addParen x, addParen (strToVar "x"), toSS x) f _ = Nothing gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs@@ -267,7 +269,7 @@ f x = concatMap g $ childrenBi x g :: LHsType GhcPs -> [Idea]- g e@(fromTyParen -> x) = [suggest "Use String" x (transform f x)+ g e@(fromTyParen -> x) = [ignore "Use String" x (transform f x) rs | not . null $ rs] where f x = if astEq x typeListChar then typeString else x rs = [Replace Type (toSS t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]
src/Hint/ListRec.hs view
@@ -33,7 +33,7 @@ import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSS) -import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Data.List.Extra import Data.Maybe import Data.Either.Extra
src/Hint/Match.hs view
@@ -49,7 +49,7 @@ import Data.Tuple.Extra import Data.Maybe import Config.Type-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Bag import GHC.Hs@@ -201,6 +201,7 @@ isType "NegZero" (asInt -> Just x) | x <= 0 = True isType "LitInt" (L _ (HsLit _ HsInt{})) = True isType "LitInt" (L _ (HsOverLit _ (OverLit _ HsIntegral{} _))) = True+ isType "LitString" (L _ (HsLit _ HsString{})) = True isType "Var" (L _ HsVar{}) = True isType "App" (L _ HsApp{}) = True isType "InfixApp" (L _ x@OpApp{}) = True
src/Hint/Monad.hs view
@@ -75,7 +75,7 @@ import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import GHC.Util -import Data.Generics.Uniplate.Data+import Data.Generics.Uniplate.DataOnly import Data.Tuple.Extra import Data.Maybe import Data.List.Extra
src/Hint/Naming.hs view
@@ -41,13 +41,12 @@ module Hint.Naming(namingHint) where -import Hint.Type (Idea,DeclHint,suggest,toSS,ghcModule)-import Data.Generics.Uniplate.Operations+import Hint.Type (Idea,DeclHint,suggest,ghcModule)+import Data.Generics.Uniplate.DataOnly import Data.List.Extra (nubOrd, isPrefixOf) import Data.Data import Data.Char import Data.Maybe-import Refact.Types hiding (RType(Match)) import qualified Data.Set as Set import BasicTypes@@ -70,7 +69,8 @@ [ suggest "Use camelCase" (shorten originalDecl) (shorten replacedDecl)- [Replace Bind (toSS originalDecl) [] (unsafePrettyPrint replacedDecl)]+ [ -- https://github.com/mpickering/apply-refact/issues/39+ ] | not $ null suggestedNames ] where@@ -111,6 +111,7 @@ concatMap (map unsafePrettyPrint . getConNames . unLoc) cons getConstructorNames _ = [] +isSym :: String -> Bool isSym (x:_) = not $ isAlpha x || x `elem` "_'" isSym _ = False
src/Hint/Pattern.hs view
@@ -26,17 +26,17 @@ foo = case v of z -> z foo = case v of _ | False -> x foo x | x < -2 * 3 = 4 @NoRefactor: ghc-exactprint bug; -2 becomes 2.-foo = case v of !True -> x -- True @NoRefactor: apply-refact requires BangPatterns pragma+foo = case v of !True -> x -- True {-# LANGUAGE BangPatterns #-}; foo = case v of !True -> x -- True {-# LANGUAGE BangPatterns #-}; foo = case v of !(Just x) -> x -- (Just x) {-# LANGUAGE BangPatterns #-}; foo = case v of !(x : xs) -> x -- (x:xs) {-# LANGUAGE BangPatterns #-}; foo = case v of !1 -> x -- 1 {-# LANGUAGE BangPatterns #-}; foo = case v of !x -> x-{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x) @NoRefactor+{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x) foo = let ~x = 1 in y -- x foo = let ~(x:xs) = y in z {-# LANGUAGE BangPatterns #-}; foo = let !x = undefined in y-{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x @NoRefactor+{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x {-# LANGUAGE BangPatterns #-}; foo = let !(Just x) = Nothing in 3 {-# LANGUAGE BangPatterns #-}; foo = 1 where f !False = 2 -- False {-# LANGUAGE BangPatterns #-}; foo = 1 where !False = True@@ -51,6 +51,7 @@ {-# LANGUAGE BangPatterns #-}; l !(() :: ()) = x -- (() :: ()) foo x@_ = x -- x foo x@Foo = x+otherwise = True </TEST> -} @@ -58,7 +59,7 @@ module Hint.Pattern(patternHint) where import Hint.Type(DeclHint,Idea,ghcAnnotations,ideaTo,toSS,toRefactSrcSpan,suggest,suggestRemove,warn)-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Data.Function import Data.List.Extra import Data.Tuple
src/Hint/Pragma.hs view
@@ -18,9 +18,9 @@ {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} @NoRefactor -foo is not a valid flag-{-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-} @NoRefactor: the two pragmas are switched in the refactoring output+{-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-} {-# OPTIONS_GHC -cpp #-} \-{-# LANGUAGE CPP, Text #-} -- @NoRefactor+{-# LANGUAGE CPP, Text #-} -- {-# LANGUAGE RebindableSyntax #-} \ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RebindableSyntax #-} \@@ -72,7 +72,7 @@ -> Refactoring R.SrcSpan mkRefact old (maybe "" comment -> new) ns = let ns' = map (\n -> comment (mkLanguagePragmas noSrcSpan [n])) ns- in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (new : ns')))+ in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new))) data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment) | MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)
src/Hint/Restrict.hs view
@@ -24,7 +24,7 @@ import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea) import Config.Type -import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set import qualified Data.Map as Map@@ -42,6 +42,7 @@ import Module import SrcLoc import OccName+import Language.Haskell.GhclibParserEx.GHC.Hs import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import GHC.Util
src/Hint/Smell.hs view
@@ -81,7 +81,7 @@ import Hint.Type(ModuHint,ModuleEx(..),DeclHint,Idea(..),rawIdea,warn) import Config.Type -import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import Data.List.Extra import qualified Data.Map as Map
src/Hint/Type.hs view
@@ -6,7 +6,7 @@ import Data.Semigroup import Config.Type-import HSE.All as Export+import GHC.All as Export import Idea as Export import Prelude import Refact as Export
src/Hint/Unsafe.hs view
@@ -21,7 +21,7 @@ import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSS) import Data.List.Extra import Refact.Types hiding(Match)-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly import GHC.Hs import OccName
src/Language/Haskell/HLint.hs view
@@ -38,7 +38,7 @@ import HLint import Fixity import FastString-import HSE.All+import GHC.All import Hint.All hiding (resolveHints) import qualified Hint.All as H import SrcLoc
src/Refact.hs view
@@ -10,6 +10,7 @@ import Control.Monad import Data.Maybe import Data.Version.Extra+import GHC.LanguageExtensions.Type import System.Directory.Extra import System.Exit import System.IO.Extra@@ -43,7 +44,7 @@ case mexc of Just exc -> do ver <- readVersion . tail <$> readProcess exc ["--version"] ""- pure $ if versionBranch ver >= [0,1,0,0]+ pure $ if versionBranch ver >= [0,7,0,0] then Right exc else Left "Your version of refactor is too old, please upgrade to the latest version" Nothing -> pure $ Left $ unlines@@ -53,9 +54,11 @@ , "<https://github.com/mpickering/apply-refact>" ] -runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode-runRefactoring rpath fin hints opts = do+runRefactoring :: FilePath -> FilePath -> FilePath -> [Extension] -> [Extension] -> String -> IO ExitCode+runRefactoring rpath fin hints enabled disabled opts = do let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]+ ++ [arg | e <- enabled, arg <- ["-X", show e]]+ ++ [arg | e <- disabled, arg <- ["-X", "No" ++ show e]] (_, _, _, phand) <- createProcess $ proc rpath args try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ()) hSetBuffering stdout LineBuffering
src/Test/All.hs view
@@ -39,7 +39,7 @@ xs <- liftIO $ getDirectoryContents dataDir pure [dataDir </> x | x <- xs, takeExtension x `elem` [".yml",".yaml"]] testFiles <- liftIO $ forM testFiles $ \file -> do- hints <- readFilesConfig [(file, Nothing)]+ hints <- readFilesConfig [(file, Nothing),("CommandLine.yaml", Just "- group: {name: testing, enabled: true}")] pure (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints)) let wrap msg act = do liftIO $ putStr (msg ++ " "); act; liftIO $ putStrLn ""
src/Test/Annotations.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, RecordWildCards, ViewPatterns #-}+{-# LANGUAGE CPP, PatternGuards, RecordWildCards, ViewPatterns #-} -- | Check the <TEST> annotations within source and hint files. module Test.Annotations(testAnnotations) where@@ -13,16 +13,16 @@ import Data.List.Extra import Data.Maybe import Data.Tuple.Extra-import Data.Yaml import System.Exit import System.FilePath import System.IO.Extra-import HSE.All+import GHC.All import qualified Data.ByteString.Char8 as BS import Config.Type import Idea import Apply+import Extension import Refact import Test.Util import Prelude@@ -33,6 +33,21 @@ import SrcLoc import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable +#ifdef HS_YAML++import Data.YAML.Aeson (decode1Strict)+import Data.YAML (Pos)+import Data.ByteString (ByteString)++decodeEither' :: ByteString -> Either (Pos, String) ConfigYaml+decodeEither' = decode1Strict++#else++import Data.Yaml++#endif+ -- Input, Output -- Output = Nothing, should not match -- Output = Just xs, should match xs@@ -161,7 +176,7 @@ x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y writeFile tempInp inp writeFile tempHints (show refacts)- exitCode <- runRefactoring rpath tempInp tempHints "--inplace"+ exitCode <- runRefactoring rpath tempInp tempHints defaultExtensions [] "--inplace" refactored <- readFile tempInp pure $ case exitCode of ExitFailure ec -> ["Refactoring failed: exit code " ++ show ec]
src/Util.hs view
@@ -12,7 +12,7 @@ import System.IO.Unsafe import Unsafe.Coerce import Data.Data-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.DataOnly ---------------------------------------------------------------------@@ -56,11 +56,11 @@ --------------------------------------------------------------------- -- DATA.GENERICS.UNIPLATE.OPERATIONS -universeParent :: Uniplate a => a -> [(Maybe a, a)]+universeParent :: Data a => a -> [(Maybe a, a)] universeParent x = (Nothing,x) : f x where- f :: Uniplate a => a -> [(Maybe a, a)]+ f :: Data a => a -> [(Maybe a, a)] f x = concat [(Just x, y) : f y | y <- children x] -universeParentBi :: Biplate a b => a -> [(Maybe b, b)]+universeParentBi :: (Data a, Data b) => a -> [(Maybe b, b)] universeParentBi = concatMap universeParent . childrenBi