hlint 2.1.17 → 2.1.18

raw patch · 12 files changed

+165/−38 lines, 12 filesdep +ghc-lib-parserdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ghc-lib-parser

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.txt +5/−0
• data/hlint.yaml +7/−0
• hlint.cabal +5/−3
• src/Apply.hs +2/−2
• src/Config/Compute.hs +2/−2
• src/Config/Haskell.hs +2/−2
• src/GHC/Util.hs +66/−0
• src/Grep.hs +3/−3
• src/HSE/All.hs +56/−22
• src/HSE/Unify.hs +9/−1
• src/Hint/Match.hs +6/−1
• src/Language/Haskell/HLint3.hs +2/−2

@@ -1,5 +1,10 @@ Changelog for HLint (* = breaking change) +2.1.18, released 2019-05-13+    #633, don't suggest changes inside RULES+    #631, suggest typeOf ==> typeRep+    Add matching on type variables+    #627, restrict to GHC 8.4 and above 2.1.17, released 2019-04-17     #626, add operator wildcards with ?, ??, ??? etc     #625, fix an rnf/rhs typo

@@ -519,6 +519,10 @@     - hint: {lhs: mapM_ (writeChan a), rhs: writeList2Chan a}     - error: {lhs: atomically (readTVar x), rhs: readTVarIO x} +    # TYPEABLE++    - hint: {lhs: "typeOf (a :: b)", rhs: "typeRep (Proxy :: Proxy b)"}+     # EXCEPTION      - hint: {lhs: flip Control.Exception.catch, rhs: handle}@@ -905,4 +909,7 @@ # no = sort <$> f input `shouldBe` sort <$> x # sortBy (comparing snd) -- sortOn snd # myJoin = on $ child ^. ChildParentId ==. parent ^. ParentId+# foo = typeOf (undefined :: Foo Int) -- typeRep (Proxy :: Proxy (Foo Int))+# foo = typeOf (undefined :: a) -- typeRep (Proxy :: Proxy a)+# {-# RULES "Id-fmap-id" forall (x :: Id a). fmap id x = x #-} # </TEST>

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            2.1.17+version:            2.1.18 license:            BSD3 license-file:       LICENSE category:           Development@@ -27,7 +27,7 @@ extra-doc-files:     README.md     CHANGES.txt-tested-with:        GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3+tested-with:        GHC==8.6.5, GHC==8.4.4  source-repository head     type:     git@@ -59,7 +59,8 @@         ansi-terminal >= 0.6.2,         extra >= 1.6.6,         refact >= 0.3,-        aeson >= 1.1.2.0+        aeson >= 1.1.2.0,+        ghc-lib-parser >= 0.20190423      if flag(gpl)         build-depends: hscolour >= 1.21@@ -91,6 +92,7 @@         Config.Read         Config.Type         Config.Yaml+        GHC.Util         HSE.All         HSE.Match         HSE.Reduce

@@ -79,8 +79,8 @@ parseModuleApply flags s file src = do     res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src     case res of-        Right m -> return $ Right m-        Left (ParseError sl msg ctxt) ->+        Right (ParsedModuleResults (m, c) _)  -> return $ Right (m,c)+        Left (ParseError sl msg ctxt _) ->             return $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing []  

@@ -16,9 +16,9 @@ computeSettings flags file = do     x <- parseModuleEx flags file Nothing     case x of-        Left (ParseError sl msg _) ->+        Left (ParseError sl msg _ _) ->             return ("# Parse error " ++ showSrcLoc sl ++ ": " ++ msg, [])-        Right (m, _) -> do+        Right (ParsedModuleResults (m, _) _) -> do             let xs = concatMap (findSetting $ UnQual an) (moduleDecls m)                 r = concatMap (readSetting mempty) xs                 s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting r ++ ["# no hints found" | null xs]

@@ -29,9 +29,9 @@     let flags = addInfix defaultParseFlags     res <- parseModuleEx flags file contents     case res of-        Left (ParseError sl msg err) ->+        Left (ParseError sl msg err _) ->             error $ "Config parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err-        Right (m, cs) -> return $ readSettings m ++ map SettingClassify (concatMap readComment cs)+        Right (ParsedModuleResults (m, cs) _) -> return $ readSettings m ++ map SettingClassify (concatMap readComment cs)   -- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions.

@@ -0,0 +1,66 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module GHC.Util (+    dynFlags+  , parseFileGhcLib+  , ParseResult (..)+  , pprErrMsgBagWithLoc+  , getMessages+  , SDoc+  , Located+  ) where++import "ghc-lib-parser" HsSyn+import "ghc-lib-parser" DynFlags+import "ghc-lib-parser" Platform+import "ghc-lib-parser" Fingerprint+import "ghc-lib-parser" Config+import "ghc-lib-parser" Lexer+import "ghc-lib-parser" Parser+import "ghc-lib-parser" SrcLoc+import "ghc-lib-parser" FastString+import "ghc-lib-parser" StringBuffer+import "ghc-lib-parser" ErrUtils+import "ghc-lib-parser" Outputable+import "ghc-lib-parser" GHC.LanguageExtensions.Type++import Data.List+import System.FilePath+import Language.Preprocessor.Unlit+++fakeSettings :: Settings+fakeSettings = Settings+  { sTargetPlatform=platform+  , sPlatformConstants=platformConstants+  , sProjectVersion=Config.cProjectVersion+  , sProgramName="ghc"+  , sOpt_P_fingerprint=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 = ([], [])++enabledExtensions :: [Extension]+enabledExtensions = [Cpp .. StarIsType] -- First and last extension in ghc-boot-th/GHC/LanguageExtensions/Type.hs 'data Extension'.++dynFlags :: DynFlags+dynFlags = foldl' xopt_set+             (defaultDynFlags fakeSettings fakeLlvmConfig) enabledExtensions++parseFileGhcLib :: FilePath -> String -> ParseResult (Located (HsModule GhcPs))+parseFileGhcLib filename str =+  Lexer.unP Parser.parseModule parseState+  where+    location = mkRealSrcLoc (mkFastString filename) 1 1+    buffer = stringToStringBuffer $+              if takeExtension filename /= ".lhs" then str else unlit filename str+    parseState = mkPState dynFlags buffer location

@@ -24,8 +24,8 @@     forM_ files $ \file -> do         res <- parseModuleEx flags file Nothing         case res of-            Left (ParseError sl msg ctxt) ->+            Left (ParseError sl msg ctxt _) ->                 print $ rawIdeaN Error (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing []-            Right m ->-                forM_ (applyHints [] rule [m]) $ \i ->+            Right (ParsedModuleResults (m, c) _) ->+                forM_ (applyHints [] rule [(m, c)]) $ \i ->                     print i{ideaHint="", ideaTo=Nothing}

@@ -1,11 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PackageImports #-}  module HSE.All(     module X,     CppFlags(..), ParseFlags(..), defaultParseFlags,     parseFlagsAddFixities, parseFlagsSetLanguage,-    parseModuleEx, ParseError(..),+    parseModuleEx, ParseError(..), ParsedModuleResults(..),     freeVars, vars, varss, pvars     ) where @@ -29,6 +30,10 @@ import Data.Functor import Prelude +import GHC.Util+import qualified "ghc-lib-parser" Lexer+import qualified "ghc-lib-parser" HsSyn+ vars :: FreeVars a => a -> [String] freeVars :: FreeVars a => a -> Set String varss, pvars :: AllVars a => a -> [String]@@ -139,20 +144,54 @@         dropLine (line1 -> (a,b)) | "{-# LINE " `isPrefixOf` a = b         dropLine x = x - --------------------------------------------------------------------- -- PARSING --- | A parse error from 'parseModuleEx'.+-- | A parse error. data ParseError = ParseError     {parseErrorLocation :: SrcLoc -- ^ Location of the error.-    ,parseErrorMessage :: String -- ^ Message about the cause 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.+    ,parseErrorSDocs :: [SDoc]    -- ^ Parse error messages as reported by ghc-lib.     } +-- | Combined 'hs-src-ext' and 'ghc-lib-parser' parse trees.+data ParsedModuleResults = ParsedModuleResults {+    pm_hsext  :: (Module SrcSpanInfo, [Comment]) -- hs-src-ext result.+  , pm_ghclib :: Maybe (Located (HsSyn.HsModule HsSyn.GhcPs)) -- ghc-lib-parser result.+}++-- | Utility called from 'parseModuleEx' and 'failOpModuleEx'.+mkMode :: ParseFlags -> String -> ParseMode+mkMode flags file = (hseFlags flags){parseFilename = file,fixities = Nothing }++-- | Error handler called on HSE parse failure.+failOpParseModuleEx :: String+                   -> ParseFlags+                   -> FilePath+                   -> String+                   -> SrcLoc+                   -> String+                   -> Maybe Lexer.PState+                   -> IO (Either ParseError ParsedModuleResults)+failOpParseModuleEx ppstr flags file str sl msg maybePFailed = do+    flags <- return $ parseFlagsNoLocations flags+    ppstr2 <- runCpp (cppFlags flags) file str+    let pe = case parseFileContentsWithMode (mkMode flags file) ppstr2 of+               ParseFailed sl2 _ -> context (srcLine sl2) ppstr2+               _ -> context (srcLine sl) ppstr+    return $ Left $ ParseError sl msg pe+                            (case maybePFailed of+                              Just ps  ->+                                pprErrMsgBagWithLoc $ snd $ getMessages ps dynFlags+                              Nothing -> []+                            )+ -- | 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.-parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment]))+-- The filename @-@ is treated as @stdin@. Requires some flags (often 'defaultParseFlags'), the filename, and optionally the contents of that file.+-- This version uses both hs-src-exts AND ghc-lib. It's considered to be an unrecoverable error if one+-- parsing method succeeds whilst the other fails.+parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ParsedModuleResults) parseModuleEx flags file str = timedIO "Parse" file $ do         str <- case str of             Just x -> return x@@ -160,24 +199,19 @@                     | otherwise -> readFileUTF8' file         str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130         ppstr <- runCpp (cppFlags flags) file str-        case parseFileContentsWithComments (mode flags) ppstr of-            ParseOk (x, cs) -> return $ Right (applyFixity fixity x, cs)-            ParseFailed sl msg -> do-                -- figure out the best line number to grab context from, by reparsing-                -- but not generating {-# LINE #-} pragmas-                flags <- return $ parseFlagsNoLocations flags-                ppstr2 <- runCpp (cppFlags flags) file str-                let pe = case parseFileContentsWithMode (mode flags) ppstr2 of-                        ParseFailed sl2 _ -> context (srcLine sl2) ppstr2-                        _ -> context (srcLine sl) ppstr-                return $ Left $ ParseError sl msg pe+        case (parseFileContentsWithComments (mkMode flags file) ppstr, parseFileGhcLib file ppstr) of+            (ParseOk (x, cs), ghc) ->+                return $ Right (ParsedModuleResults (applyFixity fixity x, cs) $ fromPOk ghc)+            (ParseFailed sl msg, pfailed) ->+                failOpParseModuleEx ppstr flags file str sl msg $ fromPFailed pfailed     where-        fixity = fromMaybe [] $ fixities $ hseFlags flags-        mode flags = (hseFlags flags)-            {parseFilename = file-            ,fixities = Nothing-            }+        fromPFailed (PFailed x) = Just x+        fromPFailed _ = Nothing +        fromPOk (POk _ x) = Just x+        fromPOk _ = Nothing++        fixity = fromMaybe [] $ fixities $ hseFlags flags  -- | Given a line number, and some source code, put bird ticks around the appropriate bit. context :: Int -> String -> String

@@ -48,7 +48,7 @@  -- | Perform a substitution substitute :: Subst Exp_ -> Exp_ -> Exp_-substitute (Subst bind) = transformBracketOld exp . transformBi pat+substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformBi typ     where         exp (Var _ (fromNamed -> x)) = lookup x bind         exp (InfixApp s lhs (fromNamed -> x) rhs) =@@ -65,6 +65,8 @@         pat (PVar _ (fromNamed -> x)) | Just y <- lookup x bind = toNamed $ fromNamed y         pat x = x :: Pat_ +        typ (TyVar _ (fromNamed -> x)) | Just (TypeApp _ y) <- lookup x bind = y+        typ x = x :: Type_  --------------------------------------------------------------------- -- UNIFICATION@@ -82,6 +84,7 @@ unify nm root x y     | 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 :: S) <- cast x = Just mempty     | otherwise = unifyDef nm x y @@ -147,3 +150,8 @@ unifyPat nm (PVar _ x) (PVar _ y) = Just $ Subst [(fromNamed x, toNamed $ fromNamed y)] unifyPat nm (PVar _ x) PWildCard{} = Just $ Subst [(fromNamed x, toNamed $ "_" ++ fromNamed x)] unifyPat nm x y = unifyDef nm x y+++unifyType :: NameMatch -> Type_ -> Type_ -> Maybe (Subst Exp_)+unifyType nm (TyVar a x) y = Just $ Subst [(fromNamed x, TypeApp a y)]+unifyType nm x y = unifyDef nm x y

@@ -94,10 +94,15 @@ findIdeas :: [HintRule] -> Scope -> Module S -> Decl_ -> [Idea] findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList     [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}-    | decl <- case decl of InstDecl{} -> children decl; _ -> [decl]+    | decl <- findDecls decl     , (parent,x) <- universeParentExp decl, not $ isParen x     , m <- matches, Just (y,notes, subst) <- [matchIdea s decl m parent x]     , let r = R.Replace R.Expr (toSS x) subst (prettyPrint $ hintRuleRHS m) ]++findDecls :: Decl_ -> [Decl_]+findDecls x@InstDecl{} = children x+findDecls RulePragmaDecl{} = [] -- often rules contain things that HLint would rewrite+findDecls x = [x]  matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_, [Note], [(String, R.SrcSpan)]) matchIdea s decl HintRule{..} parent x = do

@@ -120,5 +120,5 @@ _docs :: IO () _docs = do     (flags, classify, hint) <- autoSettings-    Right m <- parseModuleEx flags "MyFile.hs" Nothing-    print $ applyHints classify hint [m]+    Right (ParsedModuleResults (m, c) _) <- parseModuleEx flags "MyFile.hs" Nothing+    print $ applyHints classify hint [(m, c)]