- This program has only been made possible by the presence of the haskell-src-exts package, and many useful improvements have been made by Niklas Broberg 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 and others. + This program has only been made possible by the presence of the haskell-src-exts package, and many improvements have been made by Niklas Broberg 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 and others.
-- A complete bug list is kept at my bug tracker. - Some common issues that I do not intend to fix include: + To report a bug either email me, or add the issue directly to the bug tracker. There are two common issues that I do not intend to fix:
- Installation follows the standard pattern of any Haskell library or program, simply type cabal update to update your local hackage database, then cabal install hlint to install HLint. + Installation follows the standard pattern of any Haskell library or program, type cabal update to update your local hackage database, then cabal install hlint to install HLint.
- Once HLint is installed, simply run hlint source where source is either a Haskell file or a directory containing some Haskell files. Any directory will be searched recursively for any files ending with .hs or .lhs. For example, running HLint over darcs would give: + Once HLint is installed, run hlint source where source is either a Haskell file, or a directory containing Haskell files. A directory will be searched recursively for any files ending with .hs or .lhs. For example, running HLint over darcs would give:
@@ -125,20 +124,26 @@ The first suggestion is marked as an error, because using concatMap in preference to the two separate functions is always desirable. In contrast, the removal of brackets is probably a good idea, but not always. Reasons that a hint might be a warning include requiring an additional import, something not everyone agrees on, and functions only available in more recent versions of the base library.- Disclaimer: While these hints are meant to be correct, they aren't guaranteed to be. Please report any non equivalent hints not listed above in the limitations. + Bug reports: The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations.
Reports
- HLint can generate a lot of information, and often searching for either the errors specific to a file, or a specific class of errors, is difficult. Using the --report flag HLint will produce a report file in HTML, which can be viewed interactively. Reports are recommended when there are more than a handlful of hints. + HLint can generate a lot of information, making it difficult to search for particular types of errors. The --report flag will cause HLint to generate a report file in HTML, which can be viewed interactively. Reports are recommended when there are more than a handlful of hints.
-Emacs Integration
+Language Extensions
- Emacs integration of HLint has been provided by Alex Ott. The integration is similar to compilation-mode, allowing navigation between errors, etc. The script is at hs-lint.el, and a copy is installed locally in the data directory. To use, just add the following code to the Emacs init file: + HLint enables most Haskell extensions, disabling only those which steal too much syntax (currently Arrows, TransformListComp, XmlSyntax and RegularPatterns). Extensions can be enabled with -XArrows, and disabled with -XNoMagicHash. The flag -XHaskell98 selects Haskell 98 compatibility.
+ +Emacs Integration
+ ++ Emacs integration has been provided by Alex Ott. The integration is similar to compilation-mode, allowing navigation between errors. The script is at hs-lint.el, and a copy is installed locally in the data directory. To use, add the following code to the Emacs init file: +
(require 'hs-lint) (defun my-haskell-mode-hook () @@ -149,7 +154,7 @@GHCi Integration
- GHCi integration of HLint has been provided by Gwern Branwen. The integration allows running :hlint from the GHCi prompt. The script is at hlint.ghci, and a copy is installed locally in the data directory. To use, add the contents to your GHCi startup file. + GHCi integration has been provided by Gwern Branwen. The integration allows running :hlint from the GHCi prompt. The script is at hlint.ghci, and a copy is installed locally in the data directory. To use, add the contents to your GHCi startup file.
Parallel Operation
@@ -163,7 +168,7 @@C preprocesor support
- HLint always runs the cpphs C preprocessor over all input files, by default using the current directory as the include path with no defined macros. These settings can be modified using the flags --cpp-include and --cpp-define. There are a number of limitations to the C preprocessor support: + HLint runs the cpphs C preprocessor over all input files, by default using the current directory as the include path with no defined macros. These settings can be modified using the flags --cpp-include and --cpp-define. To disable the C preprocessor use the flag -XNoCPP. There are a number of limitations to the C preprocessor support:
- When compiled with GHC 6.10, HLint only supports ASCII. When compiled with GHC 6.12 or above HLint uses the current locale encoding. The encoding can be overriden with either --utf8 or --encoding=value. For descriptions of some valid encodings see the mkTextEncoding documentation. + When compiled with GHC 6.10, HLint only supports ASCII. When compiled with GHC 6.12 or above, HLint uses the current locale encoding. The encoding can be overriden with either --utf8 or --encoding=value. For descriptions of some valid encodings see the mkTextEncoding documentation.
-- If you want to automatically apply suggestions, the Emacs integration offers such a feature. However, there are a number of reasons that HLint itself doesn't have an option to automatically apply suggestions: + If you want to automatically apply suggestions, the Emacs integration offers such a feature. However, there are a number of reasons that HLint itself doesn't have an option to automatically apply suggestions:
Many of the hints that are applied by HLint are contained in Haskell source files which are installed in the data directory by Cabal. These files may be edited, to add library specific knowledge, to include hints that may have been missed, or to ignore unwanted hints. @@ -279,7 +283,7 @@ error = concat (map f x) ==> concatMap f x
- The line can be read as replace concat (map f x) with concatMap f x. Anything with a 1-letter variable is treated as a substitution parameter. For examples of more complex hints see the supplied hints file. In general, hints should not be given in point free style, as this reduces the power of the matching. Hints may start with error or warn to denote how severe they are by default. If you come up with interesting hints, please submit them for inclusion. + The line can be read as replace concat (map f x) with concatMap f x. All single-letter variables are treated as substitution parameters. For examples of more complex hints see the supplied hints file. In general, hints should not be given in point free style, as this reduces the power of the matching. Hints may start with error or warn to denote how severe they are by default. If you come up with interesting hints, please submit them for inclusion.
You can search for possible hints to add from a source file with the --find flag, for example: diff --git a/src/Apply.hs b/src/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Apply.hs @@ -0,0 +1,73 @@ + +module Apply(applyHint, applyHintStr) where + +import HSE.All +import Hint.All +import Data.Char +import Data.List +import Data.Maybe +import Data.Ord +import Settings +import Idea +import Util + + +applyHint :: ParseFlags -> [Setting] -> FilePath -> IO [Idea] +applyHint flags s file = do + src <- readFileEncoding (encoding flags) file + applyHintStr flags s file src + + +applyHintStr :: ParseFlags -> [Setting] -> FilePath -> String -> IO [Idea] +applyHintStr flags s file src = do + res <- parseString flags{infixes=[x | Infix x <- s]} file src + case snd res of + ParseFailed sl msg -> map (classify s) `fmap` parseFailed flags sl msg src + ParseOk m -> return $ + let settings = mapMaybe readPragma $ moduleDecls m + in map (classify $ s ++ settings) $ parseOk (allHints s) m + + +parseFailed :: ParseFlags -> SrcLoc -> String -> String -> IO [Idea] +parseFailed flags sl msg src = do + -- figure out the best line number to grab context from, by reparsing + (str2,pr2) <- parseString (parseFlagsNoLocations flags) "" src + let ctxt = case pr2 of + ParseFailed sl2 _ -> context (srcLine sl2) str2 + _ -> context (srcLine sl) src + return [ParseError Warning "Parse error" sl msg ctxt] + + +context :: Int -> String -> String +context lineNo src = + unlines $ trimBy (all isSpace) $ + zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ [""] + where ticks = [" "," ","> "," "," "] + + +parseOk :: [Hint] -> Module_ -> [Idea] +parseOk h m = + order "" [i | ModuHint h <- h, i <- h nm m] ++ + concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m] + where + order n = map (\i -> i{func = (moduleName m,n)}) . sortBy (comparing loc) + nm = nameMatch $ moduleImports m + + +allHints :: [Setting] -> [Hint] +allHints xs = dynamicHints xs : map f builtin + where builtin = nub $ concat [if x == "All" then map fst staticHints else [x] | Builtin x <- xs] + f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x staticHints + + +classify :: [Setting] -> Idea -> Idea +classify xs i = if isParseError i then i else i{rank = foldl' (rerank i) (rank i) $ filter isClassify xs} + where + -- figure out if we need to change the rank + rerank :: Idea -> Rank -> Setting -> Rank + rerank i r c | matchHint (hintS c) (hint i) && matchFunc (funcS c) (func i) = rankS c + | otherwise = r + + matchHint = (~=) + matchFunc (x1,x2) (y1,y2) = (x1~=y1) && (x2~=y2) + x ~= y = null x || x == y diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternGuards #-} module CmdLine(Cmd(..), getCmd, exitWithHelp) where @@ -9,6 +10,7 @@ import System.Exit import System.FilePath import Language.Preprocessor.Cpphs +import Language.Haskell.Exts.Extension import Util import Paths_hlint @@ -23,10 +25,11 @@ ,cmdIgnore :: [String] -- ^ the hints to ignore ,cmdShowAll :: Bool -- ^ display all skipped items ,cmdColor :: Bool -- ^ color the result - ,cmdCpphs :: CpphsOptions -- ^ options for cpphs + ,cmdCpphs :: Maybe CpphsOptions -- ^ options for cpphs ,cmdDataDir :: FilePath -- ^ the data directory ,cmdEncoding :: String -- ^ the text encoding ,cmdFindHints :: [FilePath] -- ^ source files to look for hints in + ,cmdLanguage :: [Extension] -- ^ the extensions (may be prefixed by "No") } @@ -41,6 +44,7 @@ | DataDir String | Encoding String | FindHints FilePath + | Language String deriving Eq @@ -52,6 +56,7 @@ ,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 "f" ["find"] (ReqArg FindHints "file") "Find hints in a Haskell file" @@ -96,6 +101,8 @@ let encoding = last $ "" : [x | Encoding x <- opt] when (encoding /= "") $ warnEncoding encoding + let languages = getExtensions [x | Language x <- opt] + return Cmd {cmdTest = test ,cmdFiles = files @@ -104,10 +111,11 @@ ,cmdIgnore = [x | Skip x <- opt] ,cmdShowAll = ShowAll `elem` opt ,cmdColor = Color `elem` opt - ,cmdCpphs = cpphs + ,cmdCpphs = if CPP `elem` languages then Just cpphs else Nothing ,cmdDataDir = dataDir ,cmdEncoding = encoding ,cmdFindHints = findHints + ,cmdLanguage = languages } @@ -156,3 +164,18 @@ f o (x:xs) = do b <- doesFileExist x if b then return x else f o xs + + +getExtensions :: [String] -> [Extension] +getExtensions = foldl f defaultExtensions + where + f a "Haskell98" = [] + f a ('N':'o':x) | Just x <- readExtension x = delete x a + f a x | Just x <- readExtension x = x : delete x a + f a x = error $ "Unknown extension: " ++ x + + +readExtension :: String -> Maybe Extension +readExtension x = case classifyExtension x of + UnknownExtension _ -> Nothing + x -> Just x diff --git a/src/FindHints.hs b/src/FindHints.hs deleted file mode 100644 --- a/src/FindHints.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - -module FindHints(findHints) where - -import Control.Monad -import HSE.All - - --- find definitions in a source file, and write them to std out -findHints :: ParseFlags -> FilePath -> IO () -findHints flags file = do - x <- parseFile_ flags file - let xs = concatMap (findHint $ UnQual an) $ moduleDecls x - putStrLn $ "-- hints found in " ++ file - when (null xs) $ putStrLn "-- no hints found" - putStrLn $ unlines xs - - -findHint :: (Name S -> QName S) -> Decl_ -> [String] -findHint qual (InstDecl _ _ _ (Just xs)) = concatMap (findHint qual) [x | InsDecl _ x <- xs] -findHint qual (PatBind _ (PVar _ name) Nothing (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod -findHint qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findHint qual $ FunBind an [Match an name (p1:ps) rhs bind] -findHint qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod -findHint _ _ = [] - - --- given a result function name, a list of variables, a body expression, give some hints -findExp :: QName S -> [String] -> Exp_ -> [String] -findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod - | otherwise = [] - where ps2 = [x | PVar_ x <- map view ps] -findExp name vs Var{} = [] -findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint") - -findExp name vs bod = ["warn = " ++ prettyPrint lhs ++ " ==> " ++ prettyPrint rhs] - where - lhs = hintParen $ transform f bod - rhs = apps $ Var an name : map snd rep - - rep = zip vs $ map (toNamed . return) ['a'..] - f xx | Var_ x <- view xx, Just y <- lookup x rep = y - f (InfixApp _ x dol y) | isDol dol = App an x (paren y) - f x = x - - -hintParen o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o -hintParen o@App{} = o -hintParen o = paren o diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -1,73 +1,75 @@ {-# LANGUAGE RecordWildCards #-} -module HLint(hlint) where +module HLint(hlint, Suggestion, suggestionLocation) where -import Control.Arrow import Control.Monad import Data.List -import Data.Maybe import CmdLine import Settings import Report -import Type -import Hint +import Idea +import Apply import Test -import FindHints import Util import Parallel -import Hint.All import HSE.All --- | This function takes the command line arguments, and returns the number --- of errors reported. -hlint :: [String] -> IO Int +-- | A suggestion - the @Show@ instance is of particular use. +newtype Suggestion = Suggestion {fromSuggestion :: Idea} + deriving (Eq,Ord) + +instance Show Suggestion where + show = show . fromSuggestion + +-- | From a suggestion, extract the file location it refers to. +suggestionLocation :: Suggestion -> SrcLoc +suggestionLocation = loc . fromSuggestion + + + +-- | This function takes a list of command line arguments, and returns the given suggestions. +-- To see a list of arguments type @hlint --help@ at the console. +-- This function usually writes to the stdout/stderr streams. +-- +-- As an example: +-- +-- > do hints <- hlint ["src", "--ignore=Use map"] +-- > when (length hints > 3) $ error "Too many hints!" +hlint :: [String] -> IO [Suggestion] hlint args = do cmd@Cmd{..} <- getCmd args - let flags = parseFlags{cpphs=Just cmdCpphs, encoding=cmdEncoding} + let flags = parseFlags{cpphs=cmdCpphs, encoding=cmdEncoding, language=cmdLanguage} if cmdTest then - test cmdDataDir - else if not $ null cmdFindHints then - mapM_ (findHints flags) cmdFindHints >> return 0 + test cmdDataDir >> return [] + else if null cmdFiles && notNull cmdFindHints then + mapM_ (\x -> putStrLn . fst =<< findSettings flags x) cmdFindHints >> return [] else if null cmdFiles then exitWithHelp else runHints cmd flags -runHints :: Cmd -> ParseFlags -> IO Int +runHints :: Cmd -> ParseFlags -> IO [Suggestion] runHints Cmd{..} flags = do - settings <- readSettings cmdDataDir cmdHintFiles - let extra = [Classify Ignore x ("","") | x <- cmdIgnore] - let apply :: FilePath -> IO [Idea] - apply = applyHint flags (allHints settings) (filter isClassify settings ++ extra) - ideas <- fmap concat $ parallel [listM' =<< apply x | x <- cmdFiles] - let visideas = filter (\i -> cmdShowAll || rank i /= Ignore) ideas - showItem <- if cmdColor then showANSI else return show - mapM_ (putStrLn . showItem) visideas - - -- figure out statistics - let counts = map (head &&& length) $ group $ sort $ map rank ideas - let [ignore,warn,err] = map (fromMaybe 0 . flip lookup counts) [Ignore,Warning,Error] - let total = ignore + warn + err - let shown = if cmdShowAll then total else total - ignore + settings1 <- readSettings cmdDataDir cmdHintFiles + settings2 <- concatMapM (fmap snd . findSettings flags) cmdFindHints + settings3 <- return [Classify Ignore x ("","") | x <- cmdIgnore] + let settings = settings1 ++ settings2 ++ settings3 - let ignored = [show i ++ " ignored" | let i = total - shown, i /= 0] - let errors = [show err ++ " error" ++ ['s'|err/=1] | err /= 0] + ideas <- fmap concat $ parallel [listM' =<< applyHint flags settings x | x <- cmdFiles] + let (showideas,hideideas) = partition (\i -> cmdShowAll || rank i /= Ignore) ideas + showItem <- if cmdColor then showANSI else return show + mapM_ (putStrLn . showItem) showideas - if shown == 0 then do + if null showideas then when (cmdReports /= []) $ putStrLn "Skipping writing reports" - printMsg "No relevant suggestions" ignored - else do + else forM_ cmdReports $ \x -> do putStrLn $ "Writing report to " ++ x ++ " ..." - writeReport cmdDataDir x visideas - printMsg ("Found " ++ show shown ++ " suggestion" ++ ['s'|shown/=1]) (errors++ignored) - return err - - -printMsg :: String -> [String] -> IO () -printMsg msg xs = - putStrLn $ msg ++ if null xs then "" else - " (" ++ intercalate ", " xs ++ ")" + writeReport cmdDataDir x showideas + putStrLn $ + (let i = length showideas in if i == 0 then "No suggestions" else show i ++ " suggestion" ++ ['s'|i/=1]) ++ + (let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)") + return $ map Suggestion showideas diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -5,11 +5,10 @@ module HSE.Type, module HSE.NameMatch, ParseFlags(..), parseFlags, parseFlagsNoLocations, - parseFile, parseFile_, parseString + parseFile, parseString, parseResult ) where import Util -import Data.List import Data.Maybe import HSE.Util import HSE.Evaluate @@ -18,17 +17,17 @@ import HSE.Match import HSE.NameMatch import Language.Preprocessor.Cpphs -import Language.Haskell.Exts.Annotated.Simplify(sOp, sAssoc) data ParseFlags = ParseFlags {cpphs :: Maybe CpphsOptions - ,implies :: Bool + ,language :: [Extension] ,encoding :: String + ,infixes :: [Fixity] } parseFlags :: ParseFlags -parseFlags = ParseFlags Nothing False "" +parseFlags = ParseFlags Nothing defaultExtensions "" [] parseFlagsNoLocations :: ParseFlags -> ParseFlags parseFlagsNoLocations x = x{cpphs = fmap f $ cpphs x} @@ -41,10 +40,10 @@ ppstr <- maybe return (`runCpphs` file) (cpphs flags) str return (ppstr, fmap (applyFixity fixity) $ parseFileContentsWithMode mode ppstr) where - fixity = concat [infix_ (-1) ["==>"] | implies flags] ++ baseFixities + fixity = infixes flags ++ baseFixities mode = defaultParseMode {parseFilename = file - ,extensions = extension + ,extensions = language flags ,fixities = [] ,ignoreLinePragmas = False } @@ -55,10 +54,8 @@ applyFixity :: [Fixity] -> Module_ -> Module_ applyFixity fixity modu = descendBi f modu where - f x = fromMaybe x $ applyFixities (fixity ++ extra) x :: Decl_ - - -- taken from HSE, Fixity.hs - extra = [Fixity (sAssoc a) p (sOp op) | InfixDecl _ a mp ops <- moduleDecls modu, let p = maybe 9 id mp, op <- ops] + f x = fromMaybe x $ applyFixities (extra ++ fixity) x :: Decl_ + extra = concatMap getFixity $ moduleDecls modu parseFile :: ParseFlags -> FilePath -> IO (String, ParseResult Module_) @@ -68,17 +65,7 @@ -- throw an error if the parse is invalid -parseFile_ :: ParseFlags -> FilePath -> IO Module_ -parseFile_ flags file = do - (_, res) <- parseFile flags file +parseResult :: IO (String, ParseResult Module_) -> IO Module_ +parseResult x = do + (_, res) <- x return $! fromParseResult res - - -extension = knownExtensions \\ badExtensions - -badExtensions = - [CPP - ,Arrows -- steals proc - ,TransformListComp -- steals the group keyword - ,XmlSyntax, RegularPatterns -- steals a-b - ] diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs --- a/src/HSE/Bracket.hs +++ b/src/HSE/Bracket.hs @@ -2,10 +2,9 @@ module HSE.Bracket where -import Control.Monad.State import HSE.Type import HSE.Util - +import Util class Brackets a where @@ -28,9 +27,6 @@ isAtom x = case x of Paren{} -> True - Var{} -> True - Con{} -> True - Lit{} -> True Tuple{} -> True List{} -> True LeftSection{} -> True @@ -41,12 +37,13 @@ EnumFromTo{} -> True EnumFromThen{} -> True EnumFromThenTo{} -> True - _ -> False + _ -> isLexeme x -- note: i is the index in children, not in the AST needBracket i parent child | isAtom child = False | InfixApp{} <- parent, App{} <- child = False + | isSection parent, App{} <- child = False | ListComp{} <- parent = False | List{} <- parent = False | Tuple{} <- parent = False @@ -108,32 +105,35 @@ | otherwise = True +-- | Add a Paren around something if it is not atomic paren :: Exp_ -> Exp_ paren x = if isAtom x then x else addParen x --- True implies I changed this level +-- | Descend, and if something changes then add/remove brackets appropriately descendBracket :: (Exp_ -> (Bool, Exp_)) -> Exp_ -> Exp_ -descendBracket f x = flip evalState 0 $ flip descendM x $ \y -> do - i <- get - modify (+1) - (b,y) <- return $ f y - let p = if b && needBracket i x y then (\x -> Paren (ann x) x) else id - return $ p y +descendBracket op x = descendIndex g x + where + g i y = if a then f i b else b + where (a,b) = op y + f i (Paren _ y) | not $ needBracket i x y = y + f i y | needBracket i x y = addParen y + f i y = y + transformBracket :: (Exp_ -> Maybe Exp_) -> Exp_ -> Exp_ -transformBracket f = snd . g +transformBracket op = snd . g where - g = f2 . descendBracket g - f2 x = maybe (False,x) ((,) True) (f x) + g = f . descendBracket g + f x = maybe (False,x) ((,) True) (op x) --- ensure that all the 1-level children are appropriately bracketed -ensureBracket1 :: Exp_ -> Exp_ -ensureBracket1 = descendBracket ((,) True) +-- | Add/remove brackets as suggested needBracket at 1-level of depth +rebracket1 :: Exp_ -> Exp_ +rebracket1 = descendBracket (\x -> (True,x)) -- a list of application, with any necessary brackets appsBracket :: [Exp_] -> Exp_ -appsBracket = foldl1 (\x -> ensureBracket1 . App an x) +appsBracket = foldl1 (\x -> rebracket1 . App an x) diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -4,7 +4,9 @@ import Control.Monad import Data.List +import Data.Maybe import HSE.Type +import Language.Haskell.Exts.Annotated.Simplify(sOp, sAssoc) --------------------------------------------------------------------- @@ -14,6 +16,10 @@ opExp (QVarOp s op) = Var s op opExp (QConOp s op) = Con s op +expOp :: Exp_ -> Maybe (QOp S) +expOp (Var s op) = Just $ QVarOp s op +expOp (Con s op) = Just $ QConOp s op +expOp _ = Nothing moduleDecls :: Module_ -> [Decl_] moduleDecls (Module _ _ _ _ xs) = xs @@ -25,7 +31,7 @@ moduleImports :: Module_ -> [ImportDecl S] moduleImports (Module _ _ _ x _) = x -modulePragmas :: Module_ -> [OptionPragma S] +modulePragmas :: Module_ -> [ModulePragma S] modulePragmas (Module _ _ x _ _) = x isChar :: Exp_ -> Bool @@ -53,6 +59,10 @@ fromPParen (PParen _ x) = fromPParen x fromPParen x = x +fromTyParen :: Type s -> Type s +fromTyParen (TyParen _ x) = fromTyParen x +fromTyParen x = x + -- is* :: Exp -> Bool isVar Var{} = True; isVar _ = False isApp App{} = True; isApp _ = False @@ -76,6 +86,9 @@ isPatTypeSig PatTypeSig{} = True; isPatTypeSig _ = False isQuasiQuote QuasiQuote{} = True; isQuasiQuote _ = False +isSection LeftSection{} = True +isSection RightSection{} = True +isSection _ = False -- which names are bound by a declaration declBind :: Decl_ -> [String] @@ -113,6 +126,12 @@ dotApps (x:xs) = dotApp x (dotApps xs) +isLexeme Var{} = True +isLexeme Con{} = True +isLexeme Lit{} = True +isLexeme _ = False + + --------------------------------------------------------------------- -- HSE FUNCTIONS @@ -126,7 +145,7 @@ -- case and if both have branches, nothing else does replaceBranches :: Exp s -> ([Exp s], [Exp s] -> Exp s) replaceBranches (If s a b c) = ([b,c], \[b,c] -> If s a b c) -replaceBranches (Case s a bs) = (concatMap f bs, \bs2 -> Case s a (g bs bs2)) +replaceBranches (Case s a bs) = (concatMap f bs, Case s a . g bs) where f (Alt _ _ (UnGuardedAlt _ x) _) = [x] f (Alt _ _ (GuardedAlts _ xs) _) = [x | GuardedAlt _ _ x <- xs] @@ -251,3 +270,10 @@ eqMaybe Nothing Nothing = True eqMaybe _ _ = False + +--------------------------------------------------------------------- +-- FIXITIES + +getFixity :: Decl a -> [Fixity] +getFixity (InfixDecl _ a mp ops) = [Fixity (sAssoc a) (fromMaybe 9 mp) (sOp op) | op <- ops] +getFixity _ = [] diff --git a/src/Hint.hs b/src/Hint.hs deleted file mode 100644 --- a/src/Hint.hs +++ /dev/null @@ -1,59 +0,0 @@ - -module Hint where - -import HSE.All -import Data.Char -import Data.List -import Data.Maybe -import Data.Ord -import Settings -import Type -import Util - - -type DeclHint = NameMatch -> Module_ -> Decl_ -> [Idea] -type ModuHint = NameMatch -> Module_ -> [Idea] - -data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint} - - -applyHint :: ParseFlags -> [Hint] -> [Setting] -> FilePath -> IO [Idea] -applyHint flags h s file = do - src <- readFileEncoding (encoding flags) file - applyHintStr flags h s file src - - -applyHintStr :: ParseFlags -> [Hint] -> [Setting] -> FilePath -> String -> IO [Idea] -applyHintStr flags h s file src = do - res <- parseString flags file src - case snd res of - ParseFailed sl msg -> map (classify s) `fmap` parseFailed flags sl msg src - ParseOk m -> return $ - let settings = mapMaybe readPragma $ moduleDecls m - in map (classify $ s ++ settings) $ parseOk h m - - -parseFailed :: ParseFlags -> SrcLoc -> String -> String -> IO [Idea] -parseFailed flags sl msg src = do - -- figure out the best line number to grab context from, by reparsing - (str2,pr2) <- parseString (parseFlagsNoLocations flags) "" src - let ctxt = case pr2 of - ParseFailed sl2 _ -> context (srcLine sl2) str2 - _ -> context (srcLine sl) src - return [ParseError Warning "Parse error" sl msg ctxt] - - -context :: Int -> String -> String -context lineNo src = - unlines $ trimBy (all isSpace) $ - zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ [""] - where ticks = [" "," ","> "," "," "] - - -parseOk :: [Hint] -> Module_ -> [Idea] -parseOk h m = - order "" [i | ModuHint h <- h, i <- h nm m] ++ - concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m] - where - order n = map (\i -> i{func = (moduleName m,n)}) . sortBy (comparing loc) - nm = nameMatch $ moduleImports m diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -1,10 +1,11 @@ -module Hint.All where +module Hint.All( + Hint(..), DeclHint, ModuHint, + staticHints, dynamicHints + ) where -import Type -import Hint -import Data.List -import Data.Maybe +import Settings +import Hint.Type import Hint.Match import Hint.List @@ -36,9 +37,3 @@ dynamicHints :: [Setting] -> Hint dynamicHints = DeclHint . readMatch - - -allHints :: [Setting] -> [Hint] -allHints xs = dynamicHints xs : map f builtin - where builtin = nub [x | Builtin x <- xs] - f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x staticHints diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -19,6 +19,7 @@ yes = C { f = (e h) } -- @Warning C {f = e h} yes = \ x -> (x && x) -- @Warning \x -> x && x no = \(x -> y) -> z +yes = (`foo` (bar baz)) -- @Warning (`foo` bar baz) -- type bracket reduction foo :: (Int -> Int) -> Int @@ -48,9 +49,7 @@ module Hint.Bracket where -import Type -import Hint -import HSE.All +import Hint.Type bracketHint :: DeclHint @@ -82,12 +81,12 @@ f x = [msg x y | InfixApp _ a d b <- [x], opExp d ~= "$" ,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b] ++ - [msg x (t y) |(t, Paren _ (InfixApp _ a1 op1 a2)) <- infixes x + [msg x (t y) |(t, Paren _ (InfixApp _ a1 op1 a2)) <- splitInfix x ,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2 ,let y = App an a1 (Paren an a2)] -- return both sides, and a way to put them together again -infixes :: Exp_ -> [(Exp_ -> Exp_, Exp_)] -infixes (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)] -infixes _ = [] +splitInfix :: Exp_ -> [(Exp_ -> Exp_, Exp_)] +splitInfix (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)] +splitInfix _ = [] diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -31,10 +31,9 @@ module Hint.Extensions where -import HSE.All -import Type -import Hint +import Hint.Type import Data.Maybe +import Util extensionsHint :: ModuHint @@ -96,7 +95,7 @@ (&) f g x = f x || g x -hasT t x = not $ null (universeBi x `asTypeOf` [t]) +hasT t x = notNull (universeBi x `asTypeOf` [t]) hasT2 ~(t1,t2) = hasT t1 & hasT t2 hasS :: Biplate x (f S) => (f S -> Bool) -> x -> Bool diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs --- a/src/Hint/Import.hs +++ b/src/Hint/Import.hs @@ -26,16 +26,14 @@ import B; import A; import A -- import A import A hiding(Foo); import A hiding(Bar) import List -- import Data.List -import Locale(foo) -- import System.Locale(foo) +import IO(foo) -- import System.IO(foo) -} module Hint.Import where -import HSE.All -import Type -import Hint +import Hint.Type import Util import Data.Maybe @@ -98,8 +96,9 @@ ,"Data" * "Ratio" ,"System" * "Directory" ,"System" * "IO" - ,"System" * "Locale" - ,"System" * "Time" + -- Do not encourage use of old-locale/old-time over haskell98 + -- ,"System" * "Locale" + -- ,"System" * "Time" ] hierarchy :: ImportDecl S -> [Idea] diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -40,16 +40,24 @@ x ! y = fromJust $ lookup x y f = foo (\i -> writeIdea (getClass i) i) f = bar (flip Foo.bar x) -- (`Foo.bar` x) +f = a b (\x -> c x d) -- (`c` d) +yes = \x -> a x -- a +yes = \x y -> op y x -- flip op +f = \y -> nub $ reverse y -- nub . reverse +f = \z -> foo $ bar $ baz z -- foo . bar . baz +f = \z -> foo $ bar x $ baz z -- foo . bar x . baz +f = \z -> foo $ z $ baz z +f = \x -> bar map (filter x) -- bar map . filter +foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] +foo = [\x -> x] -} module Hint.Lambda where -import HSE.All import Hint.Util -import Type -import Hint +import Hint.Type import Util diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -15,7 +15,7 @@ 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) +data Yes = Yes (Maybe [Char]) -- Maybe String yes = y :: [Char] -> a -- String -> a -} @@ -23,9 +23,7 @@ module Hint.List where -import HSE.All -import Type -import Hint +import Hint.Type listHint :: DeclHint @@ -37,7 +35,7 @@ -- boolean = are you in a ++ chain listExp :: Bool -> Exp_ -> [Idea] -listExp b x = +listExp b (fromParen -> x) = if null res then concatMap (listExp $ isAppend x) $ children x else [head res] where res = [warn name x x2 | (name,f) <- checks, Just x2 <- [f b x]] @@ -79,5 +77,5 @@ stringType :: Type_ -> [Idea] -stringType x = [warn "Use String" x (transform f x) | any (=~= typeListChar) $ universe x] +stringType (fromTyParen -> x) = [warn "Use String" x (transform f x) | any (=~= typeListChar) $ universe x] where f x = if x =~= typeListChar then typeString else x diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -18,17 +18,18 @@ f z (x:xs) = f (z*x) xs ; f z [] = z -- f z xs = foldl (*) z xs f a (x:xs) b = x + a + b : f a xs b ; f a [] b = [] -- f a xs b = map (\ x -> x + a + b) xs f [] a = return a ; f (x:xs) a = a + x >>= \fax -> f xs fax -- f xs a = foldM (+) a xs -foos [] x = x; foos (y:ys) x = foo y $ foos ys x -- foos ys x = foldr (foo $) x ys +foos [] x = x; foos (y:ys) x = foo y $ foos ys x -- foos ys x = foldr foo x ys +f [] y = y; f (x:xs) y = f xs $ g x y -- f xs y = foldl (flip g) y xs +f [] y = y; f (x : xs) y = let z = g x y in f xs z -- f xs y = foldl (flip g) y xs +f [] y = y; f (x:xs) y = f xs (f xs z) -} module Hint.ListRec(listRecHint) where -import Type -import Hint +import Hint.Type import Util -import HSE.All import Hint.Util import Data.List import Data.Maybe @@ -44,10 +45,13 @@ let x = o (x, addCase) <- findCase x (use,rank,x) <- matchListRec x - return $ idea rank ("Use " ++ use) o $ addCase x + let y = addCase x + guard $ recursiveStr `notElem` vars y + return $ idea rank ("Use " ++ use) o y -recursive = toNamed "_recursive_" +recursiveStr = "_recursive_" +recursive = toNamed recursiveStr -- recursion parameters, nil-case, (x,xs,cons-case) -- for cons-case delete any recursive calls with xs from them @@ -148,7 +152,7 @@ findBranch x = do Match _ name ps (UnGuardedRhs _ bod) Nothing <- return x (a,b,c) <- findPat ps - return $ Branch (fromNamed name) a b c bod + return $ Branch (fromNamed name) a b c $ simplifyExp bod findPat :: [Pat_] -> Maybe ([String], Int, BList) diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -37,9 +37,8 @@ import Data.Maybe import Data.Data import Unsafe.Coerce -import Type -import Hint -import HSE.All +import Settings +import Hint.Type import Control.Monad import Control.Arrow import Util diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -36,9 +36,7 @@ import Control.Arrow import Data.Maybe import Data.List -import HSE.All -import Type -import Hint +import Hint.Type badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM"] @@ -80,7 +78,7 @@ monadJoin (Generator _ (view -> PVar_ p) x:Qualifier _ (view -> Var_ v):xs) | p == v && v `notElem` vars xs - = Just $ Qualifier an (ensureBracket1 $ App an (toNamed "join") x) : fromMaybe xs (monadJoin xs) + = Just $ Qualifier an (rebracket1 $ App an (toNamed "join") x) : fromMaybe xs (monadJoin xs) monadJoin (x:xs) = fmap (x:) $ monadJoin xs monadJoin [] = Nothing diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -25,12 +25,11 @@ module Hint.Naming(namingHint) where -import HSE.All -import Type -import Hint +import Hint.Type import Data.List import Data.Char import Data.Maybe +import Util import qualified Data.Set as Set @@ -38,7 +37,7 @@ namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu] naming :: Set.Set String -> Decl_ -> [Idea] -naming seen x = [warn "Use camelCase" x2 (replaceNames res x2) | not $ null res] +naming seen x = [warn "Use camelCase" x2 (replaceNames res x2) | notNull res] where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen] x2 = shorten x diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs --- a/src/Hint/Pragma.hs +++ b/src/Hint/Pragma.hs @@ -26,11 +26,10 @@ module Hint.Pragma where -import HSE.All -import Type -import Hint +import Hint.Type import Data.List import Data.Maybe +import Util pragmaHint :: ModuHint @@ -41,17 +40,17 @@ ns2 = nub (concat ns) \\ concat [map fromNamed n | LanguagePragma _ n <- lang] -pragmaIdea :: [OptionPragma S] -> [OptionPragma S] -> Idea +pragmaIdea :: [ModulePragma S] -> [ModulePragma S] -> Idea pragmaIdea xs ys = rawIdea Error "Use better pragmas" (toSrcLoc $ ann $ head xs) (f xs) (f ys) where f = unlines . map prettyPrint -languageDupes :: [OptionPragma S] -> [Idea] +languageDupes :: [ModulePragma S] -> [Idea] languageDupes [] = [] languageDupes (a@(LanguagePragma _ x):xs) = (if nub_ x `neqList` x then [pragmaIdea [a] [LanguagePragma an $ nub_ x]] - else [pragmaIdea [a,b] [LanguagePragma an (nub_ $ x ++ y)] | b@(LanguagePragma _ y) <- xs, not $ null $ intersect_ x y]) ++ + else [pragmaIdea [a,b] [LanguagePragma an (nub_ $ x ++ y)] | b@(LanguagePragma _ y) <- xs, notNull $ intersect_ x y]) ++ languageDupes xs @@ -63,7 +62,7 @@ strToLanguage _ = Nothing -optToLanguage :: OptionPragma S -> Maybe (Maybe (OptionPragma S), [String]) +optToLanguage :: ModulePragma S -> Maybe (Maybe (ModulePragma S), [String]) optToLanguage (OptionsPragma sl tool val) | maybe True (== GHC) tool && any isJust vs = Just (res, concat $ catMaybes vs) where diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs --- a/src/Hint/Structure.hs +++ b/src/Hint/Structure.hs @@ -19,9 +19,7 @@ module Hint.Structure where -import HSE.All -import Type -import Hint +import Hint.Type import Util import Data.List diff --git a/src/Hint/Type.hs b/src/Hint/Type.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Type.hs @@ -0,0 +1,11 @@ + +module Hint.Type(module Hint.Type, module Idea, module HSE.All) where + +import HSE.All +import Idea + + +type DeclHint = NameMatch -> Module_ -> Decl_ -> [Idea] +type ModuHint = NameMatch -> Module_ -> [Idea] + +data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint} diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs --- a/src/Hint/Util.hs +++ b/src/Hint/Util.hs @@ -3,22 +3,69 @@ module Hint.Util where import HSE.All +import Util --- generate a lambda, but prettier (if possible) +-- | Generate a lambda, but prettier (if possible). +-- Generally no lambda is good, but removing just some arguments isn't so useful. niceLambda :: [String] -> Exp_ -> Exp_ + +-- \xs -> (e) ==> \xs -> e niceLambda xs (Paren _ x) = niceLambda xs x + +-- \xs -> \v vs -> e ==> \xs v -> \vs -> e +-- \xs -> \ -> e ==> \xs -> e niceLambda xs (Lambda _ ((view -> PVar_ v):vs) x) | v `notElem` xs = niceLambda (xs++[v]) (Lambda an vs x) niceLambda xs (Lambda _ [] x) = niceLambda xs x -niceLambda [x] (App _ a (view -> Var_ b)) | x == b, x `notElem` vars a = a -niceLambda [x] (App _ a (Paren _ (App _ b (view -> Var_ c)))) - | isAtom a && isAtom b && x == c && x `notElem` (vars a ++ vars b) - = if a ~= "$" then LeftSection an b (toNamed "$") else InfixApp an a (toNamed ".") b -niceLambda [x] (InfixApp _ a op b) - | view a == Var_ x, x `notElem` vars b, allowRightSection (fromNamed op) = RightSection an op b - | view b == Var_ x, x `notElem` vars a, allowLeftSection (fromNamed op) = LeftSection an a op -niceLambda [x,y] (view -> App2 op (view -> Var_ x1) (view -> Var_ y1)) - | x1 == x && y1 == y = op - | x1 == y && y1 == x = App an (toNamed "flip") op + +-- \ -> e ==> e niceLambda [] x = x + +-- \xs -> e xs ==> e +niceLambda xs (fromApps -> e) | map view xs2 == map Var_ xs, vars e2 `disjoint` xs, notNull e2 = apps e2 + where (e2,xs2) = splitAt (length e - length xs) e + +-- \x y -> x + y ==> (+) +niceLambda [x,y] (InfixApp _ (view -> Var_ x1) (opExp -> op) (view -> Var_ y1)) + | x == x1, y == y1, vars op `disjoint` [x,y] = op + +-- \x -> x + b ==> (+ b) [heuristic, b must be a single lexeme, or gets too complex] +niceLambda [x] (view -> App2 (expOp -> Just op) a b) + | isLexeme b, view a == Var_ x, x `notElem` vars b, allowRightSection (fromNamed op) = rebracket1 $ RightSection an op b + +-- \x y -> f y x = flip f +niceLambda [x,y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1)) + | x == x1 && y == y1 = App an (toNamed "flip") op + +-- \x -> f (b x) ==> f . b +-- \x -> f $ b x ==> f . b +niceLambda [x] y | Just z <- factor y, x `notElem` vars z = z + where + -- factor the expression with respect to x + factor y@App{} | (ini,lst) <- unsnoc $ fromApps y, view lst == Var_ x = Just $ apps ini + factor y@App{} | (ini,lst) <- unsnoc $ fromApps y, Just z <- factor lst = Just $ niceDotApp (apps ini) z + factor (InfixApp _ y op (factor -> Just z)) | isDol op = Just $ niceDotApp y z + factor (Paren _ y@App{}) = factor y + factor _ = Nothing + +-- base case niceLambda ps x = Lambda an (map toNamed ps) x + + + +-- ($) . b ==> b +niceDotApp :: Exp_ -> Exp_ -> Exp_ +niceDotApp a b | a ~= "$" = b + | otherwise = dotApp a b + + + +-- | Convert expressions which have redundant junk in them away. +-- Mainly so that later stages can match on fewer alternatives. +simplifyExp :: Exp_ -> Exp_ +simplifyExp (InfixApp _ x dol y) | isDol dol = App an x (paren y) +simplifyExp (Let _ (BDecls _ [PatBind _ (view -> PVar_ x) Nothing (UnGuardedRhs _ y) Nothing]) z) + | x `notElem` vars y && x `notElem` pvars z && length (filter (== x) (vars z)) <= 1 = transform f z + where f (view -> Var_ x') | x == x' = paren y + f x = x +simplifyExp x = x diff --git a/src/Idea.hs b/src/Idea.hs new file mode 100644 --- /dev/null +++ b/src/Idea.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} + +module Idea(module Idea, Rank(..)) where + +import HSE.All +import Settings +import Language.Haskell.HsColour.TTY +import Language.Haskell.HsColour.Colourise +import Util + + +data Idea + = Idea {func :: FuncName, rank :: Rank, hint :: String, loc :: SrcLoc, from :: String, to :: String} + | ParseError {rank :: Rank, hint :: String, loc :: SrcLoc, msg :: String, from :: String} + deriving (Eq,Ord) + + +isParseError ParseError{} = True; isParseError _ = False + + +instance Show Idea where + show = showEx id + + +showANSI :: IO (Idea -> String) +showANSI = do + prefs <- readColourPrefs + return $ showEx (hscolour prefs) + +showEx :: (String -> String) -> Idea -> String +showEx tt Idea{..} = unlines $ + [showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to + where f msg x = (msg ++ ":") : map (" "++) (lines $ tt x) + +showEx tt ParseError{..} = unlines $ + [showSrcLoc loc ++ " Parse error","Error message:"," " ++ msg,"Code:"] ++ map (" "++) (lines $ tt from) + + +rawIdea = Idea ("","") +idea rank hint from to = rawIdea rank hint (toSrcLoc $ ann from) (f from) (f to) + where f = ltrim . prettyPrint +warn = idea Warning +err = idea Error diff --git a/src/Language/Haskell/HLint.hs b/src/Language/Haskell/HLint.hs --- a/src/Language/Haskell/HLint.hs +++ b/src/Language/Haskell/HLint.hs @@ -1,4 +1,9 @@ +{-| +This module provides a library interface to HLint. The current +interface is strongly modelled on the command line interface, +and is expected to evolve. +-} -module Language.Haskell.HLint(hlint) where +module Language.Haskell.HLint(module HLint) where import HLint diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -27,6 +27,6 @@ main = do args <- getArgs errs <- hlint args - when (errs > 0) $ + when (length errs > 0) $ exitWith $ ExitFailure 1 diff --git a/src/Parallel.hs b/src/Parallel.hs --- a/src/Parallel.hs +++ b/src/Parallel.hs @@ -1,7 +1,16 @@ +{- +The parallel function (specialised to lists) is equivalent to: +import Control.Parallel.Strategies +parallel :: [IO [a]] -> IO [[a]] +parallel = return . withStrategy (parList $ seqList r0) . map unsafePerformIO + +However, this version performs about 10% slower with 2 processors in GHC 6.12.1 +-} + module Parallel(parallel) where -import System.IO.Unsafe(unsafeInterleaveIO) +import System.IO.Unsafe import GHC.Conc(numCapabilities) import Control.Concurrent import Control.Monad diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -2,7 +2,7 @@ module Report(writeReport) where -import Type +import Idea import Control.Arrow import Data.List import Data.Maybe diff --git a/src/Settings.hs b/src/Settings.hs --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,15 +1,63 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-} -module Settings(readSettings, readPragma, classify, defaultHintName) where +module Settings( + Rank(..), FuncName, Setting(..), isClassify, isMatchExp, + defaultHintName, isUnifyVar, + readSettings, readPragma, findSettings + ) where import HSE.All -import Type import Data.Char import Data.List import System.FilePath import Util +defaultHintName = "Use alternative" + + +data Rank = Ignore | Warning | Error + deriving (Eq,Ord,Show) + +getRank :: String -> Maybe Rank +getRank "ignore" = Just Ignore +getRank "warn" = Just Warning +getRank "warning" = Just Warning +getRank "error" = Just Error +getRank _ = Nothing + + +-- (modulename,functionname) +-- either being blank implies universal matching +type FuncName = (String,String) + + +-- Any 1-letter variable names are assumed to be unification variables +isUnifyVar :: String -> Bool +isUnifyVar [x] = x == '?' || isAlpha x +isUnifyVar _ = False + + +addInfix x = x{infixes = infix_ (-1) ["==>"] ++ infixes x} + + +--------------------------------------------------------------------- +-- TYPE + +data Setting + = Classify {rankS :: Rank, hintS :: String, funcS :: FuncName} + | MatchExp {rankS :: Rank, hintS :: String, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_} + | Builtin String -- use a builtin hint set + | Infix Fixity + deriving Show + +isClassify Classify{} = True; isClassify _ = False +isMatchExp MatchExp{} = True; isMatchExp _ = False + + +--------------------------------------------------------------------- +-- READ A SETTINGS FILE + -- Given a list of hint files to start from -- Return the list of settings commands readSettings :: FilePath -> [FilePath] -> IO [Setting] @@ -18,12 +66,10 @@ return $ map Builtin builtin ++ concatMap (concatMap readSetting . concatMap getEquations . moduleDecls) mods --- read all the files --- in future this should also do import chasing, but --- currently it doesn't +-- Read a hint file, and all hint files it imports readHints :: FilePath -> FilePath -> IO [Either String Module_] readHints dataDir file = do - y <- parseFile_ parseFlags{implies=True} file + y <- parseResult $ parseFile (addInfix parseFlags) file ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y return $ Right y:ys where @@ -32,38 +78,20 @@ | otherwise = readHints dataDir $ x <.> "hs" --- precondition: all isClassify xs -classify :: [Setting] -> Idea -> Idea -classify xs i = if isParseError i then i else i{rank = foldl' (rerank i) (rank i) xs} - where - -- figure out if we need to change the rank - rerank :: Idea -> Rank -> Setting -> Rank - rerank i r c | matchHint (hintS c) (hint i) && matchFunc (funcS c) (func i) = rankS c - | otherwise = r - - matchHint = (~=) - matchFunc (x1,x2) (y1,y2) = (x1~=y1) && (x2~=y2) - x ~= y = null x || x == y - - ---------------------------------------------------------------------- --- READ A HINT - -defaultHintName = "Use alternative" - readSetting :: Decl_ -> [Setting] readSetting (FunBind _ [Match _ (Ident _ (getRank -> Just rank)) pats (UnGuardedRhs _ bod) bind]) | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" = [MatchExp rank (if null names then defaultHintName else head names) (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)] | otherwise = [Classify rank n func | n <- names2, func <- readFuncs bod] where - names = getNames pats bod + names = filter notNull $ getNames pats bod names2 = ["" | null names] ++ names readSetting x@AnnPragma{} | Just y <- readPragma x = [y] -readSetting (PatBind an (PVar _ name) _ bod bind) = readSetting $ FunBind an [Match an name [PLit an (String an "" "")] bod bind] +readSetting (PatBind an (PVar _ name) _ bod bind) = readSetting $ FunBind an [Match an name [] bod bind] readSetting (FunBind an xs) | length xs /= 1 = concatMap (readSetting . FunBind an . return) xs readSetting (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing] +readSetting x@InfixDecl{} = map Infix $ getFixity x readSetting x = errorOn x "bad hint" @@ -100,13 +128,6 @@ readFuncs x = errorOn x "bad classification rule" --- errorOn :: Pretty x => x -> String -> a -errorOn val msg = exitMessage $ - showSrcLoc (getPointLoc $ ann val) ++ - " Error while reading hint file, " ++ msg ++ "\n" ++ - prettyPrint val - - getNames :: [Pat_] -> Exp_ -> [String] getNames ps _ | ps /= [] && all isPString ps = map fromPString ps getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names @@ -119,9 +140,55 @@ getNames _ _ = [] -getRank :: String -> Maybe Rank -getRank "ignore" = Just Ignore -getRank "warn" = Just Warning -getRank "warning" = Just Warning -getRank "error" = Just Error -getRank _ = Nothing +errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b +errorOn val msg = exitMessage $ + showSrcLoc (getPointLoc $ ann val) ++ + " Error while reading hint file, " ++ msg ++ "\n" ++ + prettyPrint val + + +--------------------------------------------------------------------- +-- FIND SETTINGS IN A SOURCE FILE + +-- find definitions in a source file +findSettings :: ParseFlags -> FilePath -> IO (String, [Setting]) +findSettings flags file = do + x <- parseResult $ parseFile flags file + let xs = concatMap (findSetting $ UnQual an) (moduleDecls x) + s = unlines $ ["-- hints found in " ++ file] ++ xs ++ ["-- no hints found" | null xs] + r <- do + m <- parseResult $ parseString (addInfix flags) "INTERNAL ERROR (please report)" $ unlines xs + return $ concatMap readSetting $ moduleDecls m + return (s,r) + + +findSetting :: (Name S -> QName S) -> Decl_ -> [String] +findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs] +findSetting qual (PatBind _ (PVar _ name) Nothing (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod +findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind] +findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod +findSetting _ x@InfixDecl{} = [ltrim $ prettyPrint x] +findSetting _ _ = [] + + +-- given a result function name, a list of variables, a body expression, give some hints +findExp :: QName S -> [String] -> Exp_ -> [String] +findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod + | otherwise = [] + where ps2 = [x | PVar_ x <- map view ps] +findExp name vs Var{} = [] +findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint") + +findExp name vs bod = ["warn = " ++ prettyPrint lhs ++ " ==> " ++ prettyPrint rhs] + where + lhs = g $ transform f bod + rhs = apps $ Var an name : map snd rep + + rep = zip vs $ map (toNamed . return) ['a'..] + f xx | Var_ x <- view xx, Just y <- lookup x rep = y + f (InfixApp _ x dol y) | isDol dol = App an x (paren y) + f x = x + + g o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o + g o@App{} = o + g o = paren o diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -16,9 +16,9 @@ import System.Exit import Settings -import Type import Util -import Hint +import Idea +import Apply import HSE.All import Hint.All @@ -36,7 +36,7 @@ src <- doesDirectoryExist "src/Hint" (fail,total) <- fmap ((sum *** sum) . unzip) $ sequence $ [runTestDyn dataDir (dataDir h) | h <- dataLs, takeExtension h == ".hs", not $ "HLint" `isPrefixOf` takeBaseName h] ++ - [runTest [] [h] ("src/Hint" name <.> "hs") | (name,h) <- staticHints, src] + [runTest [Builtin name] ("src/Hint" name <.> "hs") | (name,h) <- staticHints, src] unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped" if fail == 0 then putStrLn $ "Tests passed (" ++ show total ++ ")" @@ -51,7 +51,7 @@ sequence_ bad (f1,t1) <- runTestTypes settings - (f2,t2) <- runTest (filter isClassify settings) (allHints settings) file + (f2,t2) <- runTest settings file return (length bad + f1 + f2, t1 + t2) @@ -89,15 +89,15 @@ -- return the number of fails/total -runTest :: [Setting] -> [Hint] -> FilePath -> IO (Int,Int) -runTest setting hint file = do +runTest :: [Setting] -> FilePath -> IO (Int,Int) +runTest setting file = do tests <- parseTestFile file failures <- concatMapM f tests putStr $ unlines failures return (length failures, length tests) where f (Test loc inp out) = do - ideas <- applyHintStr parseFlags hint setting file inp + ideas <- applyHintStr parseFlags setting file inp let good = case out of Nothing -> null ideas Just x -> length ideas == 1 && diff --git a/src/Type.hs b/src/Type.hs deleted file mode 100644 --- a/src/Type.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} - -module Type where - -import HSE.All -import Data.Char -import Language.Haskell.HsColour.TTY -import Language.Haskell.HsColour.Colourise -import Util - - ---------------------------------------------------------------------- --- GENERAL DATA TYPES - -data Rank = Ignore | Warning | Error - deriving (Eq,Ord,Show) - --- (modulename,functionname) --- either being blank implies universal matching -type FuncName = (String,String) - - ---------------------------------------------------------------------- --- IDEAS/SETTINGS - --- Classify and MatchExp are read from the Settings file --- Idea are generated by the program -data Setting - = Classify {rankS :: Rank, hintS :: String, funcS :: FuncName} - | MatchExp {rankS :: Rank, hintS :: String, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_} - | Builtin String -- use a builtin hint set - deriving Show - -data Idea - = Idea {func :: FuncName, rank :: Rank, hint :: String, loc :: SrcLoc, from :: String, to :: String} - | ParseError {rank :: Rank, hint :: String, loc :: SrcLoc, msg :: String, from :: String} - deriving Eq - - -isClassify Classify{} = True; isClassify _ = False -isMatchExp MatchExp{} = True; isMatchExp _ = False -isParseError ParseError{} = True; isParseError _ = False - - -instance Show Idea where - show = showEx id - - -showANSI :: IO (Idea -> String) -showANSI = do - prefs <- readColourPrefs - return $ showEx (hscolour prefs) - -showEx :: (String -> String) -> Idea -> String -showEx tt Idea{..} = unlines $ - [showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to - where f msg x = (msg ++ ":") : map (" "++) (lines $ tt x) - -showEx tt ParseError{..} = unlines $ - [showSrcLoc loc ++ " Parse error","Error message:"," " ++ msg,"Code:"] ++ map (" "++) (lines $ tt from) - - -rawIdea = Idea ("","") -idea rank hint from to = rawIdea rank hint (toSrcLoc $ ann from) (f from) (f to) - where f = ltrim . prettyPrint -warn = idea Warning -err = idea Error - - --- Any 1-letter variable names are assumed to be unification variables -isUnifyVar :: String -> Bool -isUnifyVar [x] = x == '?' || isAlpha x -isUnifyVar _ = False diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -3,7 +3,7 @@ module Util where import Control.Arrow -import Control.Monad +import Control.Monad.State import Data.Char import Data.Function import Data.List @@ -15,8 +15,13 @@ import System.IO.Unsafe import Unsafe.Coerce import Data.Data +import Data.Generics.Uniplate.Operations +import Language.Haskell.Exts.Extension +--------------------------------------------------------------------- +-- SYSTEM.DIRECTORY + getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive dir = do xs <- getDirectoryContents dir @@ -27,6 +32,9 @@ isBadDir x = "." `isPrefixOf` x || "_" `isPrefixOf` x +--------------------------------------------------------------------- +-- CONTROL.MONAD + partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) partitionM f [] = return ([], []) partitionM f (x:xs) = do @@ -34,29 +42,28 @@ (as,bs) <- partitionM f xs return ([x|res]++as, [x|not res]++bs) - concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = liftM concat . mapM f - concatZipWithM :: Monad m => (a -> b -> m [c]) -> [a] -> [b] -> m [c] concatZipWithM f xs ys = liftM concat $ zipWithM f xs ys +listM' :: Monad m => [a] -> m [a] +listM' x = length x `seq` return x -headDef :: a -> [a] -> a -headDef x [] = x -headDef x (y:ys) = y +--------------------------------------------------------------------- +-- PRELUDE -limit :: Int -> String -> String -limit n s = if null post then s else pre ++ "..." - where (pre,post) = splitAt n s +notNull = not . null +headDef :: a -> [a] -> a +headDef x [] = x +headDef x (y:ys) = y isLeft Left{} = True; isLeft _ = False isRight = not . isLeft - unzipEither :: [Either a b] -> ([a], [b]) unzipEither (x:xs) = case x of Left y -> (y:a,b) @@ -65,18 +72,37 @@ unzipEither [] = ([], []) -listM' :: Monad m => [a] -> m [a] -listM' x = length x `seq` return x +--------------------------------------------------------------------- +-- DATA.STRING +limit :: Int -> String -> String +limit n s = if null post then s else pre ++ "..." + where (pre,post) = splitAt n s +ltrim :: String -> String +ltrim = dropWhile isSpace + +trimBy :: (a -> Bool) -> [a] -> [a] +trimBy f = reverse . dropWhile f . reverse . dropWhile f + + +--------------------------------------------------------------------- +-- DATA.LIST + groupSortFst :: Ord a => [(a,b)] -> [(a,[b])] groupSortFst = map (fst . head &&& map snd) . groupBy ((==) `on` fst) . sortBy (comparing fst) - disjoint :: Eq a => [a] -> [a] -> Bool disjoint xs = null . intersect xs +unsnoc :: [a] -> ([a],a) +unsnoc [] = error "Unsnoc on empty list" +unsnoc xs = (init xs, last xs) + +--------------------------------------------------------------------- +-- SYSTEM.IO + readFileEncoding :: String -> FilePath -> IO String #if __GLASGOW_HASKELL__ < 612 readFileEncoding _ = readFile @@ -102,13 +128,8 @@ exitWith $ ExitFailure 1 -ltrim :: String -> String -ltrim = dropWhile isSpace - - -trimBy :: (a -> Bool) -> [a] -> [a] -trimBy f = reverse . dropWhile f . reverse . dropWhile f - +--------------------------------------------------------------------- +-- DATA.GENERICS data Box = forall a . Data a => Box a @@ -116,3 +137,26 @@ gzip f x y | toConstr x /= toConstr y = Nothing | otherwise = Just $ zipWith op (gmapQ Box x) (gmapQ Box y) where op (Box x) (Box y) = f x (unsafeCoerce y) + + +--------------------------------------------------------------------- +-- DATA.GENERICS.UNIPLATE.OPERATIONS + +descendIndex :: Uniplate a => (Int -> a -> a) -> a -> a +descendIndex f x = flip evalState 0 $ flip descendM x $ \y -> do + i <- get + modify (+1) + return $ f i y + + +--------------------------------------------------------------------- +-- LANGUAGE.HASKELL.EXTS.EXTENSION + +defaultExtensions :: [Extension] +defaultExtensions = knownExtensions \\ badExtensions + +badExtensions = + [Arrows -- steals proc + ,TransformListComp -- steals the group keyword + ,XmlSyntax, RegularPatterns -- steals a-b + ]