diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,14 @@ Changelog for HLint +1.8.58 + Move the API to Language.Haskell.HLint2 + #638, ensure $! doesn't break strictness with strict fields + #24, don't remove DeriveFunctor even when only on a newtype + #22, turn off UnboxedTuples by default + #21, strip /* C style */ comments + #635 and #18, require cpphs-1.18.1 + Switch to CmdArgs for command line parsing + Remove -x as a synonym for --cross 1.8.57 #6, add a preview of an API #331, improve parse error locations for literate Haskell diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ ### Acknowledgements -This program has only been made possible by the presence of the [haskell-src-exts](http://www.cs.chalmers.se/~d00nibro/haskell-src-exts/) package, and many improvements have been made by [Niklas Broberg](http://www.cs.chalmers.se/~d00nibro/) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy and others. +This program has only been made possible by the presence of the [haskell-src-exts](http://www.cs.chalmers.se/~d00nibro/haskell-src-exts/) package, and many improvements have been made by [Niklas Broberg](http://www.cs.chalmers.se/~d00nibro/) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann and others. ### Bugs and limitations diff --git a/data/Default.hs b/data/Default.hs --- a/data/Default.hs +++ b/data/Default.hs @@ -583,7 +583,13 @@ test = food id xs yes = baz baz >> return () -- Control.Monad.void (baz baz) no = foo >>= bar >>= something >>= elsee >> return () - +no = f (#) x +data Pair = P {a :: !Int}; foo = return $! P{a=undefined} +data Pair = P {a :: !Int}; foo = return $! P undefined +foo = return $! Just undefined -- return (Just undefined) +foo = return $! (a,b) -- return (a,b) +foo = return $! 1 +foo = return $! "test" import Prelude \ yes = flip mapM -- Control.Monad.forM diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: hlint -version: 1.8.57 +version: 1.8.58 license: BSD3 license-file: LICENSE category: Development @@ -41,14 +41,15 @@ base == 4.*, process, filepath, directory, containers, transformers >= 0.0, hscolour >= 1.17, - cpphs >= 1.11, + cpphs >= 1.18.1, + cmdargs >= 0.10, haskell-src-exts >= 1.14 && < 1.15, uniplate >= 1.5 hs-source-dirs: src exposed-modules: - Temporary.API Language.Haskell.HLint + Language.Haskell.HLint2 other-modules: Paths_hlint Apply diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -1,24 +1,38 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, RecordWildCards, DeriveDataTypeable #-} -module CmdLine(Cmd(..), CppFlags(..), getCmd, exitWithHelp) where +module CmdLine(Cmd(..), cmdCpp, CppFlags(..), getCmd, cmdExtensions, cmdHintFiles, exitWithHelp, resolveFile) where -import Control.Applicative -import Control.Monad import Data.Char import Data.List -import Data.Maybe -import System.Console.GetOpt +import System.Console.CmdArgs.Implicit import System.Directory import System.Exit import System.FilePath import Language.Preprocessor.Cpphs import Language.Haskell.Exts.Extension +import System.Environment import Util import Paths_hlint import Data.Version +getCmd :: [String] -> IO Cmd +getCmd args = withArgs args $ automatic =<< cmdArgsRun mode + +automatic :: Cmd -> IO Cmd +automatic Cmd{..} = do + cmdDataDir <- if cmdDataDir == "" then getDataDir else return cmdDataDir + cmdPath <- return $ if null cmdPath then ["."] else cmdPath + return Cmd{..} + + +exitWithHelp :: IO a +exitWithHelp = do + putStr $ show mode + exitSuccess + + -- | What C pre processor should be used. data CppFlags = NoCpp -- ^ No pre processing is done. @@ -26,164 +40,86 @@ | Cpphs CpphsOptions -- ^ The @cpphs@ library is used. --- FIXME: Hints vs GivenHints is horrible data Cmd = Cmd - {cmdTest :: Bool -- ^ run in test mode? - ,cmdFiles :: Maybe [FilePath] -- ^ which files to run it on, nothing = none given - ,cmdHintFiles :: [FilePath] -- ^ which settingsfiles to use + {cmdFiles :: [FilePath] -- ^ which files to run it on, nothing = none given + ,cmdReports :: [FilePath] -- ^ where to generate reports ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given ,cmdWithHints :: [String] -- ^ hints that are given on the command line - ,cmdReports :: [FilePath] -- ^ where to generate reports + ,cmdColor :: Bool -- ^ color the result ,cmdIgnore :: [String] -- ^ the hints to ignore ,cmdShowAll :: Bool -- ^ display all skipped items - ,cmdColor :: Bool -- ^ color the result - ,cmdCpp :: CppFlags -- ^ options for CPP - ,cmdDataDir :: FilePath -- ^ the data directory - ,cmdEncoding :: Encoding -- ^ the text encoding - ,cmdFindHints :: [FilePath] -- ^ source files to look for hints in - ,cmdLanguage :: [Extension] -- ^ the extensions (may be prefixed by "No") - ,cmdQuiet :: Bool -- ^ supress all console output + ,cmdExtension :: [String] -- ^ extensions + ,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No") + ,cmdUtf8 :: Bool + ,cmdEncoding :: String -- ^ the text encoding ,cmdCross :: Bool -- ^ work between source files, applies to hints such as duplicate code between modules + ,cmdFindHints :: [FilePath] -- ^ source files to look for hints in + ,cmdTest :: Bool -- ^ run in test mode? + ,cmdDataDir :: FilePath -- ^ the data directory + ,cmdPath :: [String] ,cmdProof :: [FilePath] -- ^ a proof script to check against - } - + ,cmdCppDefine :: [String] + ,cmdCppInclude :: [FilePath] + ,cmdCppSimple :: Bool + ,cmdCppAnsi :: Bool + } deriving (Data,Typeable,Show) -data Opts = Help - | Ver - | Test - | Hints FilePath - | WithHint String - | Path FilePath - | Report FilePath - | Skip String - | ShowAll - | Color - | Define String - | Include String - | SimpleCpp - | Ext String - | DataDir String - | Encoding String - | FindHints FilePath - | Language String - | Proof FilePath - | Quiet - | Cross - | Ansi - deriving Eq +mode = cmdArgsMode $ Cmd + {cmdFiles = def &= args &= typ "FILE/DIR" + ,cmdReports = nam "report" &= opt "report.html" &= typFile &= help "Generate a report in HTML" + ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use" + ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints to use" + ,cmdColor = nam "colour" &= name "color" &= help "Color output (requires ANSI terminal)" + ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint" + ,cmdShowAll = nam "show" &= help "Show all ignored ideas" + ,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)" + ,cmdLanguage = nam_ "language" &= name "X" &= typ "EXTENSION" &= help "Language extensions (Arrows, NoCPP)" + ,cmdUtf8 = nam "utf8" &= help "Use UTF-8 text encoding" + ,cmdEncoding = nam_ "encoding" &= typ "ENCODING" &= help "Choose the text encoding" + ,cmdCross = nam_ "cross" &= help "Work between modules" + ,cmdFindHints = nam "find" &= typFile &= help "Find hints in a Haskell file" + ,cmdTest = nam "test" &= help "Run in test mode" + ,cmdDataDir = nam "datadir" &= typDir &= help "Override the data directory" + ,cmdPath = nam "path" &= help "Directory in which to search for files" + ,cmdProof = nam_ "proof" &= typFile &= help "Isabelle/HOLCF theory file" + ,cmdCppDefine = nam_ "cpp-define" &= typ "NAME[=VALUE]" &= help "CPP #define" + ,cmdCppInclude = nam_ "cpp-include" &= typDir &= help "CPP include path" + ,cmdCppSimple = nam_ "cpp-simple" &= help "Use a simple CPP (strip # lines)" + ,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode" + } &= explicit &= name "hlint" &= program "hlint" + &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2014") + &= details ["HLint gives hints on how to improve Haskell code." + ,"" + ,"To check all Haskell files in 'src' and generate a report type:" + ," hlint src --report"] + where + nam xs@(x:_) = nam_ xs &= name [x] + nam_ xs = def &= explicit &= name xs +cmdHintFiles :: Cmd -> IO [FilePath] +cmdHintFiles Cmd{..} = mapM (getHintFile cmdDataDir) $ cmdGivenHints ++ ["HLint" | null cmdGivenHints && null cmdWithHints] -opts = [Option "?" ["help"] (NoArg Help) "Display help message" - ,Option "v" ["version"] (NoArg Ver) "Display version information" - ,Option "r" ["report"] (OptArg (Report . fromMaybe "report.html") "file") "Generate a report in HTML" - ,Option "h" ["hint"] (ReqArg Hints "file") "Hint/ignore file to use" - ,Option "w" ["with"] (ReqArg WithHint "hint") "Extra hints to use" - ,Option "c" ["color","colour"] (NoArg Color) "Color output (requires ANSI terminal)" - ,Option "i" ["ignore"] (ReqArg Skip "hint") "Ignore a particular hint" - ,Option "s" ["show"] (NoArg ShowAll) "Show all ignored ideas" - ,Option "e" ["extension"] (ReqArg Ext "ext") "File extensions to search (defaults to hs and lhs)" - ,Option "X" ["language"] (ReqArg Language "lang") "Language extensions (Arrows, NoCPP)" - ,Option "u" ["utf8"] (NoArg $ Encoding "UTF-8") "Use UTF-8 text encoding" - ,Option "" ["encoding"] (ReqArg Encoding "encoding") "Choose the text encoding" - ,Option "x" ["cross"] (NoArg Cross) "Work between modules" - ,Option "f" ["find"] (ReqArg FindHints "file") "Find hints in a Haskell file" - ,Option "t" ["test"] (NoArg Test) "Run in test mode" - ,Option "d" ["datadir"] (ReqArg DataDir "dir") "Override the data directory" - ,Option "p" ["path"] (ReqArg Path "dir") "Directory in which to search for files" - ,Option "q" ["quiet"] (NoArg Quiet) "Supress most console output" - ,Option "" ["proof"] (ReqArg Proof "file") "Isabelle/HOLCF theory file" - ,Option "" ["cpp-define"] (ReqArg Define "name[=value]") "CPP #define" - ,Option "" ["cpp-include"] (ReqArg Include "dir") "CPP include path" - ,Option "" ["cpp-simple"] (NoArg SimpleCpp) "Use a simple CPP (strip # lines)" - ,Option "" ["cpp-ansi"] (NoArg Ansi) "Use CPP in ANSI compatibility mode" - ] +cmdExtensions :: Cmd -> [Extension] +cmdExtensions = getExtensions . cmdLanguage --- | Exit out if you need to display help info -getCmd :: [String] -> IO Cmd -getCmd args = do - let (opt,files,err) = getOpt Permute opts args - unless (null err) $ - error $ unlines $ "Unrecognised arguments:" : err - - when (Ver `elem` opt) $ do - putStr versionText - exitSuccess - - when (Help `elem` opt) exitWithHelp - - let test = Test `elem` opt - - dataDir <- last $ getDataDir : [return x | DataDir x <- opt] - - let exts = [x | Ext x <- opt] - exts2 = if null exts then ["hs","lhs"] else exts - let path = [x | Path x <- opt] ++ ["."] - files <- if null files then return Nothing else Just <$> concatMapM (getFile path exts2) files - findHints <- concatMapM (getFile path exts2) [x | FindHints x <- opt] - - let hintFiles = [x | Hints x <- opt] - let withHints = [x | WithHint x <- opt] - hints <- mapM (getHintFile dataDir) $ hintFiles ++ ["HLint" | null hintFiles && null withHints] - let givenHints = if null hintFiles then [] else hints - - let languages = getExtensions [x | Language x <- opt] - - let cpphs = defaultCpphsOptions - {boolopts=defaultBoolOptions{hashline=False, ansi=Ansi `elem` opt} - ,includes = [x | Include x <- opt] - ,defines = [(a,drop 1 b) | Define x <- opt, let (a,b) = break (== '=') x] - } - let cpp | SimpleCpp `elem` opt = CppSimple -- must be first, so can disable CPP - | EnableExtension CPP `elem` languages = Cpphs cpphs - | otherwise = NoCpp - - encoding <- readEncoding $ last $ "" : [x | Encoding x <- opt] - - return Cmd - {cmdTest = test - ,cmdFiles = files - ,cmdHintFiles = hints - ,cmdGivenHints = givenHints - ,cmdWithHints = withHints - ,cmdReports = [x | Report x <- opt] - ,cmdIgnore = [x | Skip x <- opt] - ,cmdShowAll = ShowAll `elem` opt - ,cmdColor = Color `elem` opt - ,cmdCpp = cpp - ,cmdDataDir = dataDir - ,cmdEncoding = encoding - ,cmdFindHints = findHints - ,cmdLanguage = languages - ,cmdQuiet = Quiet `elem` opt - ,cmdCross = Cross `elem` opt - ,cmdProof = [x | Proof x <- opt] +cmdCpp :: Cmd -> CppFlags +cmdCpp cmd@Cmd{..} + | cmdCppSimple = CppSimple + | EnableExtension CPP `elem` cmdExtensions cmd = Cpphs defaultCpphsOptions + {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi} + ,includes = cmdCppInclude + ,defines = [(a,drop 1 b) | x <- cmdCppDefine, let (a,b) = break (== '=') x] } - - -exitWithHelp :: IO a -exitWithHelp = do - putStr helpText - exitSuccess - - -versionText :: String -versionText = "HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2014\n" + | otherwise = NoCpp -helpText :: String -helpText = unlines - [versionText - ," hlint [files/directories] [options]" - ,usageInfo "" opts - ,"HLint gives hints on how to improve Haskell code." - ,"" - ,"To check all Haskell files in 'src' and generate a report type:" - ," hlint src --report" - ] - "." <\> x = x x <\> y = x y + + +resolveFile :: Cmd -> FilePath -> IO [FilePath] +resolveFile Cmd{..} = getFile cmdPath cmdExtension getFile :: [FilePath] -> [String] -> FilePath -> IO [FilePath] diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -4,8 +4,8 @@ import Control.Applicative import Control.Monad +import System.Console.CmdArgs.Verbosity import Data.List -import Data.Maybe import System.Exit import CmdLine @@ -49,7 +49,9 @@ hlint :: [String] -> IO [Suggestion] hlint args = do cmd@Cmd{..} <- getCmd args - let flags = parseFlagsSetExtensions cmdLanguage $ defaultParseFlags{cppFlags=cmdCpp, encoding=cmdEncoding} + + encoding <- readEncoding cmdEncoding + let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding} if cmdTest then do failed <- test (void . hlint) cmdDataDir cmdGivenHints when (failed > 0) exitFailure @@ -59,18 +61,22 @@ let reps = if cmdReports == ["report.html"] then ["report.txt"] else cmdReports mapM_ (proof reps s) cmdProof return [] - else if isNothing cmdFiles && notNull cmdFindHints then - mapM_ (\x -> putStrLn . fst =<< findSettings2 flags x) cmdFindHints >> return [] - else if isNothing cmdFiles then + else if null cmdFiles && notNull cmdFindHints then do + hints <- concatMapM (resolveFile cmd) cmdFindHints + mapM_ (\x -> putStrLn . fst =<< findSettings2 flags x) hints >> return [] + else if null cmdFiles then exitWithHelp - else if cmdFiles == Just [] then - error "No files found" - else - runHints cmd flags + else do + files <- concatMapM (resolveFile cmd) cmdFiles + if null files then + error "No files found" + else + runHints cmd{cmdFiles=files} flags readAllSettings :: Cmd -> ParseFlags -> IO [Setting] -readAllSettings Cmd{..} flags = do - settings1 <- readSettings2 cmdDataDir cmdHintFiles cmdWithHints +readAllSettings cmd@Cmd{..} flags = do + files <- cmdHintFiles cmd + settings1 <- readSettings2 cmdDataDir files cmdWithHints settings2 <- concatMapM (fmap snd . findSettings2 flags) cmdFindHints settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore] return $ settings1 ++ settings2 ++ settings3 @@ -78,13 +84,12 @@ runHints :: Cmd -> ParseFlags -> IO [Suggestion] runHints cmd@Cmd{..} flags = do - let outStrLn x = unless cmdQuiet $ putStrLn x + let outStrLn = whenNormal . putStrLn settings <- readAllSettings cmd flags - let files = fromMaybe [] cmdFiles ideas <- if cmdCross - then applyHintFiles flags settings files - else concat <$> parallel [listM' =<< applyHintFile flags settings x Nothing | x <- files] + then applyHintFiles flags settings cmdFiles + else concat <$> parallel [listM' =<< applyHintFile flags settings x Nothing | x <- cmdFiles] let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas showItem <- if cmdColor then showANSI else return show mapM_ (outStrLn . showItem) showideas diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -146,13 +146,14 @@ isWHNF :: Exp_ -> Bool isWHNF Con{} = True -isWHNF Lit{} = True +isWHNF (Lit _ x) = case x of String{} -> False; Int{} -> False; Frac{} -> False; _ -> True isWHNF Lambda{} = True isWHNF Tuple{} = True isWHNF List{} = True isWHNF (Paren _ x) = isWHNF x -isWHNF RecConstr{} = True isWHNF (ExpTypeSig _ x _) = isWHNF x +-- other (unknown) constructors may have bang patterns in them, so approximate +isWHNF (App _ c@Con{} _) | prettyPrint c `elem` ["Just","Left","Right"] = True isWHNF _ = False diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -46,7 +46,11 @@ {-# LANGUAGE DeriveFunctor #-} \ data Foo = Foo Int deriving Functor {-# LANGUAGE DeriveFunctor #-} \ -newtype Foo = Foo Int deriving Functor -- +newtype Foo = Foo Int deriving Functor +{-# LANGUAGE GeneralizedNewtypeDeriving #-} \ +newtype Foo = Foo Int deriving Functor +{-# LANGUAGE GeneralizedNewtypeDeriving #-} \ +newtype Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \ deriving instance Functor Bar {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \ @@ -91,8 +95,13 @@ warnings _ _ = [] +-- | Classes that don't work with newtype deriving +noNewtypeDeriving :: [String] +noNewtypeDeriving = ["Read","Show","Data","Typeable","Generic","Generic1"] + + usedExt :: Extension -> Module_ -> Bool -usedExt (UnknownExtension "DeriveGeneric") = hasDerive True ["Generic","Generic1"] +usedExt (UnknownExtension "DeriveGeneric") = hasDerive ["Generic","Generic1"] usedExt (EnableExtension x) = used x usedExt _ = const True @@ -128,13 +137,11 @@ used PackageImports = hasS (isJust . importPkg) used QuasiQuotes = hasS isQuasiQuote used ViewPatterns = hasS isPViewPat -used DeriveDataTypeable = hasDerive True ["Data","Typeable"] -used DeriveFunctor = hasDerive False ["Functor"] -used DeriveFoldable = hasDerive False ["Foldable"] -used DeriveTraversable = hasDerive False ["Traversable"] -used GeneralizedNewtypeDeriving = any (`notElem` special) . fst . derives - where special = ["Read","Show","Data","Typeable","Generic","Generic1"] -- these classes cannot use generalised deriving - -- FIXME: This special list is duplicated here, and as booleans to hasDerive +used DeriveDataTypeable = hasDerive ["Data","Typeable"] +used DeriveFunctor = hasDerive ["Functor"] +used DeriveFoldable = hasDerive ["Foldable"] +used DeriveTraversable = hasDerive ["Traversable"] +used GeneralizedNewtypeDeriving = any (`notElem` noNewtypeDeriving) . fst . derives used Arrows = hasS f where f Proc{} = True f LeftArrApp{} = True @@ -150,14 +157,13 @@ used x = usedExt $ UnknownExtension $ show x - -hasDerive :: Bool -> [String] -> Module_ -> Bool -hasDerive nt want m = not $ null $ intersect want $ if nt then new ++ dat else dat +hasDerive :: [String] -> Module_ -> Bool +hasDerive want m = any (`elem` want) $ new ++ dat where (new,dat) = derives m -- | What is derived on newtype, and on data type --- 'deriving' declarations may be on either, so we approximate +-- 'deriving' declarations may be on either, so we approximate as both newtype and data derives :: Module_ -> ([String],[String]) derives = concatUnzip . map f . childrenBi where diff --git a/src/Language/Haskell/HLint2.hs b/src/Language/Haskell/HLint2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/HLint2.hs @@ -0,0 +1,80 @@ + +-- | /WARNING: This module represents the evolving second version of the HLint API./ +-- /It will be renamed to drop the "2" in the next major version./ +-- +-- This module provides a way to apply HLint hints. As an example of approximating the @hlint@ experience: +-- +-- @ +-- (flags, classify, hint) <- 'autoSettings' +-- Right m <- 'parseModuleEx' flags \"MyFile.hs\" Nothing +-- print $ 'applyHints' classify hint [m] +-- @ +module Language.Haskell.HLint2( + applyHints, + -- * Idea data type + Idea(..), Severity(..), Note(..), + -- * Settings + Classify(..), + getHLintDataDir, + autoSettings, findSettings, readSettings, + -- * Hints + Hint(..), builtinHints, + HintRule(..), hintRules, + -- * Scopes + Scope, scopeCreate, scopeMatch, scopeMove, + -- * Haskell-src-exts + parseModuleEx, defaultParseFlags, ParseError(..), ParseFlags(..), CppFlags(..), + -- * File encodings + Encoding, defaultEncoding, readEncoding, useEncoding + ) where + +import Settings +import Idea +import Apply +import Hint.Type +import Hint.All +import Util +import CmdLine +import Paths_hlint + +import Control.Applicative +import Control.Arrow +import Data.List +import Data.Maybe +import Data.Monoid +import System.FilePath + + +-- | Get the Cabal configured data directory of HLint +getHLintDataDir :: IO FilePath +getHLintDataDir = getDataDir + +-- | The function produces a tuple containg 'ParseFlags' (for 'parseModuleEx'), and 'Classify' and 'Hint' for 'applyHints'. +-- It approximates the normal HLint configuration steps, roughly: +-- +-- 1. Use 'findSettings' to find and load the HLint settings files. +-- +-- 1. Use 'readSettings' to interpret the settings files, producing 'HintRule' values (@LHS ==> RHS@ replacements) +-- and 'Classify' values to assign 'Severity' ratings to hints. +-- +-- 1. Use 'builtinHints' and 'hintRules' to generate a 'Hint' value. +-- +-- 1. Take all fixities from the 'findSettings' modules and put them in the 'ParseFlags'. +autoSettings :: IO (ParseFlags, [Classify], Hint) +autoSettings = do + dataDir <- getHLintDataDir + (builtin, matches) <- first resolveBuiltin <$> findSettings dataDir (dataDir "HLint.hs") Nothing + let (classify, rules) = second hintRules $ concat2 $ map readSettings matches + let fixities = getFixity =<< moduleDecls =<< matches + return (parseFlagsAddFixities fixities defaultParseFlags, classify, mconcat $ rules : builtin) + +resolveBuiltin :: [String] -> [Hint] +resolveBuiltin builtin = map f $ nub $ concat [if x == "All" then map fst builtinHints else [x] | x <- builtin] + where f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x builtinHints + +-- | Snippet from the documentation, if this changes, update the documentation +_docs :: IO () +_docs = do + (flags, classify, hint) <- autoSettings + Right m <- parseModuleEx flags "MyFile.hs" Nothing + print $ applyHints classify hint [m] diff --git a/src/Settings.hs b/src/Settings.hs --- a/src/Settings.hs +++ b/src/Settings.hs @@ -8,7 +8,6 @@ ) where import HSE.All -import Control.Monad import Data.Char import Data.List import Data.Monoid @@ -123,32 +122,31 @@ readHints :: FilePath -> Either String FilePath -> IO [Either String Module_] readHints datadir x = do - (builtin,errs,ms) <- case x of + (builtin,ms) <- case x of Left src -> findSettings datadir "CommandLine" (Just src) Right file -> findSettings datadir file Nothing - forM_ errs $ \(ParseError sl msg _) -> return $! fromParseResult $ ParseFailed sl msg return $ map Left builtin ++ map Right ms --- | Given the data directory (where the @hlint@ data files reside), and a filename to read, and optionally that file's --- contents, produce a triple containing: +-- | Given the data directory (where the @hlint@ data files reside, see 'getHLintDataDir'), +-- and a filename to read, and optionally that file's contents, produce a pair containing: -- -- 1. Builtin hints to use, e.g. @"List"@, which should be resolved using 'builtinHints'. -- --- 1. A list of parse errors produced while parsing settings files. --- -- 1. A list of modules containing hints, suitable for processing with 'readSettings'. -findSettings :: FilePath -> FilePath -> Maybe String -> IO ([String], [ParseError], [Module SrcSpanInfo]) +-- +-- Any parse failures will result in an exception. +findSettings :: FilePath -> FilePath -> Maybe String -> IO ([String], [Module SrcSpanInfo]) findSettings dataDir file contents = do let flags = addInfix defaultParseFlags res <- parseModuleEx flags file contents case res of - Left err -> return ([], [err], []) + Left (ParseError sl msg err) -> exitMessage $ "Parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err Right m -> do ys <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]] - return $ concat3 $ ([],[],[m]) : ys + return $ concat2 $ ([],[m]) : ys where - f x | Just x <- "HLint.Builtin." `stripPrefix` x = return ([x],[],[]) + f x | Just x <- "HLint.Builtin." `stripPrefix` x = return ([x],[]) | Just x <- "HLint." `stripPrefix` x = findSettings dataDir (dataDir x <.> "hs") Nothing | otherwise = findSettings dataDir (x <.> "hs") Nothing diff --git a/src/Temporary/API.hs b/src/Temporary/API.hs deleted file mode 100644 --- a/src/Temporary/API.hs +++ /dev/null @@ -1,40 +0,0 @@ - --- | /WARNING: This module represents the evolving API of HLint, do not use./ --- --- This module provides a way to apply HLint hints. To replicate the full @hlint@ experience you would: --- --- 1. Use 'findSettings' to find and load the HLint settings files. --- --- 1. Use 'readSettings' to interpret the settings files, producing 'HintRule' values (@LHS ==> RHS@ replacements) --- and 'Classify' values to assign 'Severity' ratings to hints. --- --- 1. Use 'builtinHints' and 'hintRules' to generate a 'Hint' value. --- --- 1. Use 'parseModuleEx' to parse the input files, using any fixity declarations from 'findSettings'. --- --- 1. Use 'applyHints' to execute the hints on the modules, generating 'Idea's. -module Temporary.API( - applyHints, - -- * Idea data type - Idea(..), Severity(..), Note(..), - -- * Settings - Classify(..), - findSettings, readSettings, - -- * Hints - Hint(..), builtinHints, - HintRule(..), hintRules, - -- * Scopes - Scope, scopeCreate, scopeMatch, scopeMove, - -- * Haskell-src-exts - parseModuleEx, defaultParseFlags, ParseError(..), ParseFlags(..), CppFlags(..), - -- * File encodings - Encoding, defaultEncoding, readEncoding, useEncoding - ) where - -import Settings -import Idea -import Apply -import Hint.Type -import Hint.All -import Util -import CmdLine diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -133,8 +133,14 @@ thd3 (a,b,c) = c concat3 :: [([a],[b],[c])] -> ([a],[b],[c]) -concat3 xs = (concatMap fst3 xs, concatMap snd3 xs, concatMap thd3 xs) +concat3 xs = (concat a, concat b, concat c) + where (a,b,c) = unzip3 xs +concat2 :: [([a],[b])] -> ([a],[b]) +concat2 xs = (concat a, concat b) + where (a,b) = unzip xs + + --------------------------------------------------------------------- -- SYSTEM.IO @@ -265,4 +271,5 @@ [Arrows -- steals proc ,TransformListComp -- steals the group keyword ,XmlSyntax, RegularPatterns -- steals a-b + ,UnboxedTuples -- breaks (#) lens operator ]