diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/data/hlint.yaml b/data/hlint.yaml --- a/data/hlint.yaml +++ b/data/hlint.yaml @@ -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 #-} # 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.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 diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -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 [] diff --git a/src/Config/Compute.hs b/src/Config/Compute.hs --- a/src/Config/Compute.hs +++ b/src/Config/Compute.hs @@ -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] diff --git a/src/Config/Haskell.hs b/src/Config/Haskell.hs --- a/src/Config/Haskell.hs +++ b/src/Config/Haskell.hs @@ -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. diff --git a/src/GHC/Util.hs b/src/GHC/Util.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Util.hs @@ -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 diff --git a/src/Grep.hs b/src/Grep.hs --- a/src/Grep.hs +++ b/src/Grep.hs @@ -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} diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -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 diff --git a/src/HSE/Unify.hs b/src/HSE/Unify.hs --- a/src/HSE/Unify.hs +++ b/src/HSE/Unify.hs @@ -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 diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -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 diff --git a/src/Language/Haskell/HLint3.hs b/src/Language/Haskell/HLint3.hs --- a/src/Language/Haskell/HLint3.hs +++ b/src/Language/Haskell/HLint3.hs @@ -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)]