hlint-1.8.53/0000755000000000000000000000000012220306165011111 5ustar0000000000000000hlint-1.8.53/Setup.hs0000644000000000000000000000005612220306165012546 0ustar0000000000000000import Distribution.Simple main = defaultMain hlint-1.8.53/LICENSE0000644000000000000000000000276412220306165012127 0ustar0000000000000000Copyright Neil Mitchell 2006-2012. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Neil Mitchell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hlint-1.8.53/hlint.htm0000644000000000000000000004552012220306165012747 0ustar0000000000000000 HLint Manual

HLint Manual

by Neil Mitchell

HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. This document is structured as follows:

  1. Installing and running HLint
  2. FAQ
  3. Customizing the hints

Acknowledgements

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, Andy Stewart, Roman Leshchinskiy and others.

Bugs and limitations

To report a bug either email me, or add the issue directly to the bug tracker. There are three common issues that I do not intend to fix:

Installing and running 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, 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: 


$ hlint darcs-2.1.2

darcs-2.1.2\src\CommandLine.lhs:94:1: Error: Use concatMap
Found:
  concat $ map escapeC s
Why not:
  concatMap escapeC s

darcs-2.1.2\src\CommandLine.lhs:103:1: Warning: Use fewer brackets
Found:
  ftable ++ (map (\ (c, x) -> (toUpper c, urlEncode x)) ftable)
Why not:
  ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable

darcs-2.1.2\src\Darcs\Patch\Test.lhs:306:1: Error: Use a more efficient monadic variant
Found:
  mapM (delete_line (fn2fp f) line) old
Why not:
  mapM_ (delete_line (fn2fp f) line) old

... lots more suggestions ...

Each suggestion says which file/line the suggestion relates to, how serious the issue is, a description of the issue, what it found, and what you might want to replace it with. In the case of the first hint, it has suggested that instead of applying concat and map separately, it would be better to use the combination function concatMap.

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.

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, 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.

Language Extensions

HLint enables most Haskell extensions, disabling only those which steal too much syntax (currently Arrows, TransformListComp, XmlSyntax and RegularPatterns). Individual extensions can be enabled or disabled with, for instance, -XArrows, or -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 ()
   (local-set-key "\C-cl" 'hs-lint))
(add-hook 'haskell-mode-hook 'my-haskell-mode-hook)

GHCi Integration

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

To run HLint on n processors append the flags +RTS -Nn, as described in the GHC user manual. HLint will usually perform fastest if n is equal to the number of physical processors.

If your version of GHC does not support the GHC threaded runtime then install with the command: cabal install --flags="-threaded"

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:

Unicode 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.

FAQ

Why are suggestions not applied recursively?

Consider: 

foo xs = concat (map op xs)

This will suggest eta reduction to concat . map op, and then after making that change and running HLint again, will suggest use of concatMap. Many people wonder why HLint doesn't directly suggest concatMap op. There are a number of reasons:

Why aren't the suggestions automatically applied?

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:

I am intending to develop such a feature, but the above reasons mean it is likely to take some time.

Why doesn't the compiler automatically apply the optimisations?

HLint doesn't suggest optimisations, it suggests code improvements - the intention is to make the code simpler, rather than making the code perform faster. The GHC compiler automatically applies many of the rules suggested by HLint, so HLint suggestions will rarely improve performance.

Why doesn't HLint know the fixity for my custom !@%$ operator?

HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file, or passing them on the command line. For example, pass "--with=infixr 5 !@%$", or put all the fixity declarations in a file and pass --hint=fixities.hs. You can also use --find to automatically produce a list of fixity declarations in a file.

How can I use --with or --hint with the default hints?

HLint does not use the default set of hints if custom hints are specified on the command line using --with or --hint. To include the default hints either pass --hint=HLint on the command line, or add import "hint" HLint.HLint in one of the hint files you specify with --hint.

Why do I sometimes get a "Note" with my hint?

Most hints are perfect substitutions, and these are displayed without any notes. However, some hints change the semantics of your program - typically in irrelevant ways - but HLint shows a warning note. HLint does not warn when assuming typeclass laws (such as == being symmetric). Some notes you may see include:

What is the difference between error and warning?

Every hint has a severity level:

The difference between error and warning is one of personal taste, typically my personal taste. If you already have a well developed sense of Haskell style, you should ignore the difference. If you are a beginner Haskell programmer you may wish to focus on error hints before warning hints.

Customizing the hints

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.

Choosing a package of hints

By default, HLint will use the HLint.hs file either from the current working directory, or from the data directory. Alternatively, hint files can be specified with the --hint flag. HLint comes with a number of hint packages:

As an example, to check the file Example.hs with both the default hints and the dollar hint, I could type: hlint Example.hs --hint=Default --hint=Dollar. Alternatively, I could create the file HLint.hs in the working directory and give it the contents: 

import "hint" HLint.Default
import "hint" HLint.Dollar

Ignoring hints

Some of the hints are subjective, and some users believe they should be ignored. Some hints are applicable usually, but occasionally don't always make sense. The ignoring mechanism provides features for supressing certain hints. Ignore directives can either be written as pragmas in the file being analysed, or in the hint files. Examples of pragmas are:

Ignore directives can also be written in the hint files:

These directives are applied in the order they are given, with later hints overriding earlier ones.

Adding hints

The hint suggesting concatMap is defined as: 

error = concat (map f x) ==> concatMap f x

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: 

$ hlint --find=src/Utils.hs
-- hints found in src/Util.hs
warn = null (intersect a b) ==> disjoint a b
warn = dropWhile isSpace ==> ltrim
infixr 5 !:

These hints are suitable for inclusion in a custom hint file. You can also include Haskell fixity declarations in a hint file, and these will also be extracted. If you pass only --find flags then the hints will be written out, if you also pass files/folders to check, then the found hints will be automatically used when checking.

hlint-1.8.53/hlint.cabal0000644000000000000000000000412712220306165013217 0ustar0000000000000000cabal-version: >= 1.6 build-type: Simple name: hlint version: 1.8.53 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell copyright: Neil Mitchell 2006-2013 synopsis: Source code suggestions description: HLint gives suggestions on how to improve your source code. homepage: http://community.haskell.org/~ndm/hlint/ stability: Beta data-dir: data data-files: Default.hs Generalise.hs Dollar.hs HLint.hs Test.hs report_template.html hs-lint.el hlint.1 hlint.ghci extra-source-files: hlint.htm source-repository head type: git location: git://github.com/ndmitchell/hlint.git flag threaded default: True description: Build with support for multithreaded execution library build-depends: base == 4.*, process, filepath, directory, containers, transformers >= 0.0, hscolour >= 1.17, cpphs >= 1.11, haskell-src-exts >= 1.14 && < 1.15, uniplate >= 1.5 hs-source-dirs: src exposed-modules: Language.Haskell.HLint other-modules: Paths_hlint Apply CmdLine HLint Idea Settings Report Proof Test Util Parallel HSE.All HSE.Bracket HSE.Evaluate HSE.FreeVars HSE.Match HSE.NameMatch HSE.Type HSE.Util Hint.All Hint.Bracket Hint.Duplicate Hint.Extensions Hint.Import Hint.Lambda Hint.List Hint.ListRec Hint.Match Hint.Monad Hint.Naming Hint.Pragma Hint.Structure Hint.Type Hint.Util executable hlint build-depends: base hs-source-dirs: src main-is: Main.hs ghc-options: -fno-warn-overlapping-patterns if flag(threaded) ghc-options: -threaded hlint-1.8.53/src/0000755000000000000000000000000012220306165011700 5ustar0000000000000000hlint-1.8.53/src/Util.hs0000644000000000000000000001671212220306165013160 0ustar0000000000000000{-# LANGUAGE CPP, ExistentialQuantification, Rank2Types, PatternGuards #-} module Util where import Control.Arrow import Control.Monad import Control.Monad.Trans.State import Control.Exception import Data.Char import Data.Function import Data.List import Data.Ord import System.Directory import System.Exit import System.FilePath import System.IO import System.IO.Unsafe import Unsafe.Coerce import Data.Data import Data.Generics.Uniplate.Operations import Language.Haskell.Exts.Extension #if __GLASGOW_HASKELL__ >= 612 import GHC.IO.Handle(hDuplicate,hDuplicateTo) #endif --------------------------------------------------------------------- -- SYSTEM.DIRECTORY getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive dir = do xs <- getDirectoryContents dir (dirs,files) <- partitionM doesDirectoryExist [dir x | x <- xs, not $ isBadDir x] rest <- concatMapM getDirectoryContentsRecursive dirs return $ files++rest where 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 res <- f x (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 concatM :: Monad m => [m [a]] -> m [a] concatM = liftM concat . sequence 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 --------------------------------------------------------------------- -- PRELUDE 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) Right y -> (a,y:b) where (a,b) = unzipEither xs unzipEither [] = ([], []) for = flip map --------------------------------------------------------------------- -- 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) revTake :: Int -> [a] -> [a] revTake i = reverse . take i . reverse concatUnzip :: [([a], [b])] -> ([a], [b]) concatUnzip = (concat *** concat) . unzip --------------------------------------------------------------------- -- DATA.TUPLE swap :: (a,b) -> (b,a) swap (a,b) = (b,a) --------------------------------------------------------------------- -- SYSTEM.IO -- | An encoding is a function to change a handle to a particular encoding data Encoding = Encoding_Internal (Maybe (Handle -> IO ())) defaultEncoding :: Encoding defaultEncoding = Encoding_Internal Nothing readFileEncoding :: Encoding -> FilePath -> IO String readFileEncoding (Encoding_Internal x) file = case x of Nothing -> if file == "-" then getContents else readFile file Just set -> do h <- if file == "-" then return stdin else openFile file ReadMode set h hGetContents h -- GHC's mkTextEncoding function is fairly poor - it doesn't support lots of fun things, -- so we fake them up, and then try mkTextEncoding last newEncoding :: String -> IO Encoding newEncoding "" = return defaultEncoding #if __GLASGOW_HASKELL__ >= 612 newEncoding enc | Just e <- lookup (f enc) [(f a, b) | (as,b) <- encs, a <- as] = return $ wrap e | otherwise = do res <- try $ mkTextEncoding enc :: IO (Either SomeException TextEncoding) case res of Right e -> return $ wrap e Left _ -> do let (a,b) = splitAt 2 $ map (head . fst) encs putStr $ unlines ["Error: Unknown text encoding argument, " ++ enc ,"Possible values:" ," " ++ unwords a ," " ++ unwords b ," and anything accepted by System.IO.mkTextEncoding"] exitWith $ ExitFailure 1 where f = map toLower . filter (`notElem` "-_ ") wrap = Encoding_Internal . Just . flip hSetEncoding encs = let a*b = (words a, b) in ["ISO8859-1 8859-1 ISO8859 8859 LATIN LATIN1" * latin1 ,"LOCALE" * localeEncoding ,"UTF-8" * utf8 ,"UTF-8BOM" * utf8_bom ,"UTF-16" * utf16 ,"UTF-16LE" * utf16le ,"UTF-16BE" * utf16be ,"UTF-32" * utf16 ,"UTF-32LE" * utf16le ,"UTF-32BE" * utf16be] #else newEncoding enc = do putStrLn "Warning: Text encodings are not supported with HLint compiled by GHC 6.10" return defaultEncoding #endif exitMessage :: String -> a exitMessage msg = unsafePerformIO $ do putStrLn msg exitWith $ ExitFailure 1 -- FIXME: This could use a lot more bracket calls! captureOutput :: IO () -> IO (Maybe String) #if __GLASGOW_HASKELL__ < 612 captureOutput act = return Nothing #else captureOutput act = do tmp <- getTemporaryDirectory (f,h) <- openTempFile tmp "hlint" sto <- hDuplicate stdout ste <- hDuplicate stderr hDuplicateTo h stdout hDuplicateTo h stderr hClose h act hDuplicateTo sto stdout hDuplicateTo ste stderr res <- readFile' f removeFile f return $ Just res #endif -- FIXME: Should use strict ByteString readFile' :: FilePath -> IO String readFile' x = listM' =<< readFile x --------------------------------------------------------------------- -- DATA.GENERICS data Box = forall a . Data a => Box a gzip :: Data a => (forall b . Data b => b -> b -> c) -> a -> a -> Maybe [c] 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 universeParent :: Uniplate a => a -> [(Maybe a, a)] universeParent x = (Nothing,x) : f x where f :: Uniplate a => a -> [(Maybe a, a)] f x = concat [(Just x, y) : f y | y <- children x] universeParentBi :: Biplate a b => a -> [(Maybe b, b)] universeParentBi = concatMap universeParent . childrenBi --------------------------------------------------------------------- -- LANGUAGE.HASKELL.EXTS.EXTENSION defaultExtensions :: [Extension] defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions badExtensions = [Arrows -- steals proc ,TransformListComp -- steals the group keyword ,XmlSyntax, RegularPatterns -- steals a-b ] hlint-1.8.53/src/Test.hs0000644000000000000000000002175212220306165013162 0ustar0000000000000000{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-} module Test(test) where import Control.Exception import Control.Monad import Data.Char import Data.List import Data.Maybe import Data.Monoid import Data.Function import System.Directory import System.FilePath import System.IO import System.Cmd import System.Exit import Settings import Util import Idea import Apply import HSE.All import Hint.All data Result = Result {_failures :: Int, _total :: Int} pass = Result 0 1 failure = Result 1 1 result x = if x then pass else failure results = fmap mconcat instance Monoid Result where mempty = Result 0 0 mappend (Result f1 t1) (Result f2 t2) = Result (f1+f2) (t1+t2) progress = putChar '.' failed xs = putStrLn $ unlines $ "" : xs test :: ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int test main dataDir files = do Result failures total <- if null files then do src <- doesFileExist "hlint.cabal" res <- results $ sequence $ (if src then id else take 1) [testHintFiles dataDir, testSourceFiles, testInputOutput main] putStrLn "" unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped" return res else do res <- results $ mapM (testHintFile dataDir) files putStrLn "" return res putStrLn $ if failures == 0 then "Tests passed (" ++ show total ++ ")" else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")" return failures testHintFiles :: FilePath -> IO Result testHintFiles dataDir = do xs <- getDirectoryContents dataDir results $ mapM (testHintFile dataDir) [dataDir x | x <- xs, takeExtension x == ".hs", not $ "HLint" `isPrefixOf` takeBaseName x] testHintFile :: FilePath -> FilePath -> IO Result testHintFile dataDir file = do hints <- readSettings dataDir [file] [] res <- results $ sequence $ nameCheckHints hints : checkAnnotations hints file : [typeCheckHints hints | takeFileName file /= "Test.hs"] progress return res testSourceFiles :: IO Result testSourceFiles = fmap mconcat $ sequence [checkAnnotations [Builtin name] ("src/Hint" name <.> "hs") | (name,h) <- staticHints] testInputOutput :: ([String] -> IO ()) -> IO Result testInputOutput main = do xs <- getDirectoryContents "tests" results $ mapM (checkInputOutput main) $ groupBy ((==) `on` takeBaseName) $ sort $ filter (not . isPrefixOf ".") xs --------------------------------------------------------------------- -- VARIOUS SMALL TESTS nameCheckHints :: [Setting] -> IO Result nameCheckHints hints = do let bad = [failed ["No name for the hint " ++ prettyPrint (lhs x)] | x@MatchExp{} <- hints, hintS x == defaultHintName] sequence_ bad return $ Result (length bad) 0 -- | Given a set of hints, do all the MatchExp hints type check typeCheckHints :: [Setting] -> IO Result typeCheckHints hints = bracket (openTempFile "." "hlinttmp.hs") (\(file,h) -> removeFile file) $ \(file,h) -> do hPutStrLn h $ unlines contents hClose h res <- system $ "runhaskell " ++ file progress return $ result $ res == ExitSuccess where matches = filter isMatchExp hints -- Hack around haskell98 not being compatible with base anymore hackImport i@ImportDecl{importAs=Just a,importModule=b} | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a} hackImport i = i contents = ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"] ++ concat [map (prettyPrint . hackImport) $ scopeImports $ scope x | x <- take 1 matches] ++ ["main = return ()" ,"(==>) :: a -> a -> a; (==>) = undefined" ,"_noParen_ = id" ,"_eval_ = id"] ++ ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++ prettyPrint (PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing) | (i, MatchExp _ _ _ lhs rhs side _) <- zip [1..] matches, "notTypeSafe" `notElem` vars (maybeToList side) , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs) , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner] --------------------------------------------------------------------- -- CHECK ANNOTATIONS -- Input, Output -- Output = Nothing, should not match -- Output = Just xs, should match xs data Test = Test SrcLoc String (Maybe String) checkAnnotations :: [Setting] -> FilePath -> IO Result checkAnnotations setting file = do tests <- parseTestFile file failures <- concatMapM f tests sequence_ failures return $ Result (length failures) (length tests) where f (Test loc inp out) = do ideas <- applyHintString parseFlags setting file inp let good = case out of Nothing -> null ideas Just x -> length ideas == 1 && seq (length (show ideas)) True && -- force, mainly for hpc not (isParseError (head ideas)) && match x (head ideas) return $ [failed $ ["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)" ,"SRC: " ++ showSrcLoc loc ,"INPUT: " ++ inp] ++ map ((++) "OUTPUT: " . show) ideas ++ ["WANTED: " ++ fromMaybe "" out] | not good] ++ [failed ["TEST FAILURE (BAD LOCATION)" ,"SRC: " ++ showSrcLoc loc ,"INPUT: " ++ inp ,"OUTPUT: " ++ show i] | i@Idea{loc=SrcLoc{..}} <- ideas, srcFilename == "" || srcLine == 0 || srcColumn == 0] match "???" _ = True match x y | "@" `isPrefixOf` x = a == show (severity y) && match (ltrim b) y where (a,b) = break isSpace $ tail x match x y = on (==) norm (to y) x -- FIXME: Should use a better check for expected results norm = filter $ \x -> not (isSpace x) && x /= ';' parseTestFile :: FilePath -> IO [Test] parseTestFile file = do src <- readFile file return $ f False $ zip [1..] $ lines src where open = isPrefixOf "" shut = isPrefixOf "" f False ((i,x):xs) = f (open x) xs f True ((i,x):xs) | shut x = f False xs | null x || "--" `isPrefixOf` x = f True xs | "\\" `isSuffixOf` x, (_,y):ys <- xs = f True $ (i,init x++"\n"++y):ys | otherwise = parseTest file i x : f True xs f _ [] = [] parseTest file i x = Test (SrcLoc file i 0) x $ case dropWhile (/= "--") $ words x of [] -> Nothing _:xs -> Just $ unwords xs --------------------------------------------------------------------- -- CHECK INPUT/OUTPUT PAIRS checkInputOutput :: ([String] -> IO ()) -> [FilePath] -> IO Result checkInputOutput main xs = do let pre = takeBaseName $ head xs has x = (pre <.> x) `elem` xs reader x = readFile' $ "tests" pre <.> x flags <- if has "flags" then fmap lines $ reader "flags" else if has "hs" then return ["tests/" ++ pre <.> "hs"] else if has "lhs" then return ["tests/" ++ pre <.> "lhs"] else error "checkInputOutput, couldn't find or figure out flags" got <- fmap (fmap lines) $ captureOutput $ handle (\(e::SomeException) -> print e) $ handle (\(e::ExitCode) -> return ()) $ main flags let gotValid = isJust got want <- fmap lines $ reader "output" (want,got) <- return $ matchStarStar want $ fromMaybe [] got if not gotValid then putStrLn "Warning: failed to capture output (GHC too old?)" >> return pass else if length got == length want && and (zipWith matchStar want got) then return pass else do let trail = replicate (max (length got) (length want)) "" let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), not $ matchStar w g] putStrLn $ unlines ["TEST FAILURE IN tests/" ++ pre ,"DIFFER ON LINE: " ++ show i ,"GOT : " ++ g ,"WANT: " ++ w] when (null want) $ putStrLn $ unlines $ "FULL OUTPUT FOR GOT:" : got return failure -- | First string may have stars in it (the want) matchStar :: String -> String -> Bool matchStar ('*':xs) ys = any (matchStar xs) $ tails ys matchStar (x:xs) (y:ys) = x == y && matchStar xs ys matchStar [] [] = True matchStar _ _ = False matchStarStar :: [String] -> [String] -> ([String], [String]) matchStarStar want got = case break (== "**") want of (_, []) -> (want, got) (w1,_:w2) -> (w1++w2, g1 ++ revTake (length w2) g2) where (g1,g2) = splitAt (length w1) got hlint-1.8.53/src/Settings.hs0000644000000000000000000002403312220306165014036 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns #-} module Settings( Severity(..), Note(..), showNotes, FuncName, Setting(..), isClassify, isMatchExp, defaultHintName, isUnifyVar, readSettings, readPragma, findSettings ) where import HSE.All import Data.Char import Data.List import System.FilePath import Util defaultHintName = "Use alternative" -- | How severe an error is. data Severity = Ignore -- ^ Ignored errors are only returned when @--show@ is passed. | Warning -- ^ Warnings are things that some people may consider improvements, but some may not. | Error -- ^ Errors are suggestions that should nearly always be a good idea to apply. deriving (Eq,Ord,Show,Read,Bounded,Enum) getSeverity :: String -> Maybe Severity getSeverity "ignore" = Just Ignore getSeverity "warn" = Just Warning getSeverity "warning" = Just Warning getSeverity "error" = Just Error getSeverity "hint" = Just Error getSeverity _ = 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 Note = IncreasesLaziness | DecreasesLaziness | RemovesError String -- RemovesError "on []", RemovesError "when x is negative" | ValidInstance String String -- ValidInstance "Eq" "x" | Note String deriving (Eq,Ord) instance Show Note where show IncreasesLaziness = "increases laziness" show DecreasesLaziness = "decreases laziness" show (RemovesError x) = "removes error " ++ x show (ValidInstance x y) = "requires a valid " ++ x ++ " instance for " ++ y show (Note x) = x showNotes :: [Note] -> String showNotes = intercalate ", " . map show . filter use where use ValidInstance{} = False -- Not important enough to tell an end user use _ = True data Setting = Classify {severityS :: Severity, hintS :: String, funcS :: FuncName} | MatchExp {severityS :: Severity, hintS :: String, scope :: Scope, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_, notes :: [Note]} | 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] -> [String] -> IO [Setting] readSettings dataDir files hints = do (builtin,mods) <- fmap unzipEither $ concatMapM (readHints dataDir) $ map Right files ++ map Left hints let f m = concatMap (readSetting $ moduleScope m) $ concatMap getEquations $ moduleDecls m return $ map Builtin builtin ++ concatMap f mods -- Read a hint file, and all hint files it imports readHints :: FilePath -> Either String FilePath -> IO [Either String Module_] readHints dataDir file = do let flags = addInfix parseFlags y <- parseResult $ either (parseString flags "CommandLine") (parseFile flags) file ys <- concatM [f $ fromNamed $ importModule i | i <- moduleImports y, importPkg i `elem` [Just "hint", Just "hlint"]] return $ Right y:ys where f x | "HLint.Builtin." `isPrefixOf` x = return [Left $ drop 14 x] | "HLint." `isPrefixOf` x = readHints dataDir $ Right $ dataDir drop 6 x <.> "hs" | otherwise = readHints dataDir $ Right $ x <.> "hs" readSetting :: Scope -> Decl_ -> [Setting] readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind]) | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" = let (a,b) = readSide $ childrenBi bind in [MatchExp severity (headDef defaultHintName names) s (fromParen lhs) (fromParen rhs) a b] | otherwise = [Classify severity n func | n <- names2, func <- readFuncs bod] where names = filter notNull $ getNames pats bod names2 = ["" | null names] ++ names readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = [] readSetting s x@AnnPragma{} | Just y <- readPragma x = [y] readSetting s (PatBind an (PVar _ name) _ bod bind) = readSetting s $ FunBind an [Match an name [] bod bind] readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing] readSetting s x@InfixDecl{} = map Infix $ getFixity x readSetting s x = errorOn x "bad hint" -- return Nothing if it is not an HLint pragma, otherwise all the settings readPragma :: Decl_ -> Maybe Setting readPragma o@(AnnPragma _ p) = f p where f (Ann _ name x) = g (fromNamed name) x f (TypeAnn _ name x) = g (fromNamed name) x f (ModuleAnn _ x) = g "" x g name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s = case getSeverity a of Nothing -> errorOn o "bad classify pragma" Just severity -> Just $ Classify severity (ltrim b) ("",name) where (a,b) = break isSpace $ ltrim $ drop 6 s g name (Paren _ x) = g name x g name (ExpTypeSig _ x _) = g name x g _ _ = Nothing readPragma _ = Nothing readSide :: [Decl_] -> (Maybe Exp_, [Note]) readSide = foldl f (Nothing,[]) where f (Nothing,notes) (PatBind _ PWildCard{} Nothing (UnGuardedRhs _ side) Nothing) = (Just side, notes) f (Nothing,notes) (PatBind _ (fromNamed -> "side") Nothing (UnGuardedRhs _ side) Nothing) = (Just side, notes) f (side,[]) (PatBind _ (fromNamed -> "note") Nothing (UnGuardedRhs _ note) Nothing) = (side,g note) f _ x = errorOn x "bad side condition" g (Lit _ (String _ x _)) = [Note x] g (List _ xs) = concatMap g xs g x = case fromApps x of [con -> Just "IncreasesLaziness"] -> [IncreasesLaziness] [con -> Just "DecreasesLaziness"] -> [DecreasesLaziness] [con -> Just "RemovesError",str -> Just a] -> [RemovesError a] [con -> Just "ValidInstance",str -> Just a,var -> Just b] -> [ValidInstance a b] _ -> errorOn x "bad note" con :: Exp_ -> Maybe String con c@Con{} = Just $ prettyPrint c; con _ = Nothing var c@Var{} = Just $ prettyPrint c; var _ = Nothing str c = if isString c then Just $ fromString c else Nothing -- Note: Foo may be ("","Foo") or ("Foo",""), return both readFuncs :: Exp_ -> [FuncName] readFuncs (App _ x y) = readFuncs x ++ readFuncs y readFuncs (Lit _ (String _ "" _)) = [("","")] readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)] readFuncs (Var _ (Qual _ (ModuleName _ mod) name)) = [(mod, fromNamed name)] readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,""),("",fromNamed name)] readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)] readFuncs x = errorOn x "bad classification rule" getNames :: [Pat_] -> Exp_ -> [String] getNames ps _ | ps /= [] && all isPString ps = map fromPString ps getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names where lnames = map f $ childrenS lhs rnames = map f $ childrenS rhs names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames f (Ident _ x) = x f (Symbol _ x) = x getNames _ _ = [] 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 <- parseFile flags file case snd x of ParseFailed sl msg -> return ("-- Parse error " ++ showSrcLoc sl ++ ": " ++ msg, []) ParseOk m -> do let xs = concatMap (findSetting $ UnQual an) (moduleDecls m) s = unlines $ ["-- hints found in " ++ file] ++ map prettyPrint xs ++ ["-- no hints found" | null xs] r = concatMap (readSetting emptyScope) xs return (s,r) findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_] 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{} = [x] findSetting _ _ = [] -- given a result function name, a list of variables, a body expression, give some hints findExp :: QName S -> [String] -> Exp_ -> [Decl_] 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 = [PatBind an (toNamed "warn") Nothing (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing] 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 hlint-1.8.53/src/Report.hs0000644000000000000000000000477612220306165013525 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Report(writeReport) where import Idea import Control.Arrow import Data.List import Data.Maybe import Data.Version import System.FilePath import HSE.All import Paths_hlint import Language.Haskell.HsColour.CSS writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO () writeTemplate dataDir content to = do src <- readFile $ dataDir "report_template.html" writeFile to $ unlines $ concatMap f $ lines src where f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content f x = [x] writeReport :: FilePath -> FilePath -> [Idea] -> IO () writeReport dataDir file ideas = writeTemplate dataDir inner file where generateIds :: [String] -> [(String,Int)] -- sorted by name generateIds = map (head &&& length) . group . sort files = generateIds $ map (srcFilename . loc) ideas hints = generateIds $ map hintName ideas hintName x = show (severity x) ++ ": " ++ hint x inner = [("VERSION",['v' : showVersion version]),("CONTENT",content), ("HINTS",list "hint" hints),("FILES",list "file" files)] content = concatMap (\i -> writeIdea (getClass i) i) ideas getClass i = "hint" ++ f hints (hintName i) ++ " file" ++ f files (srcFilename $ loc i) where f xs x = show $ fromJust $ findIndex ((==) x . fst) xs list mode xs = zipWith f [0..] xs where f i (name,n) = "
  • " ++ escapeHTML name ++ " (" ++ show n ++ ")
    • " where id = mode ++ show i code = hscolour False writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} = ["
    " ,escapeHTML (showSrcLoc loc ++ ": " ++ show severity ++ ": " ++ hint) ++ "
    " ,"Found
    " ,code from ,"Why not" ++ (if to == "" then " remove it." else "") ++ "
    " ,code to ,let n = showNotes note in if n /= "" then "Note: " ++ n ++ "" else "" ,"
    " ,""] writeIdea cls ParseError{..} = ["
    " ,escapeHTML (showSrcLoc loc ++ ": " ++ show severity ++ ": " ++ hint) ++ "
    " ,"Error message
    " ,"
    " ++ escapeHTML msg ++ "
    " ,"Code
    " ,code from ,"
    " ,""] escapeHTML :: String -> String escapeHTML = concatMap f where f '>' = ">" f '<' = "<" f '&' = "&" f x = [x] hlint-1.8.53/src/Proof.hs0000644000000000000000000002045712220306165013331 0ustar0000000000000000{-# LANGUAGE RecordWildCards, PatternGuards #-} module Proof(proof) where import Control.Arrow import Control.Monad import Control.Monad.Trans.State import Data.Char import Data.List import Data.Maybe import Data.Function import System.FilePath import Settings import HSE.All data Theorem = Theorem {original :: Maybe Setting ,location :: String ,lemma :: String } instance Eq Theorem where t1 == t2 = lemma t1 == lemma t2 instance Show Theorem where show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n" where f MatchExp{..} = "(* " ++ prettyPrint lhs ++ " ==> " ++ prettyPrint rhs ++ " *)\n" proof :: [FilePath] -> [Setting] -> FilePath -> IO () proof reports hints thy = do got <- fmap (isabelleTheorems (takeFileName thy)) $ readFile thy let want = nub $ hintTheorems hints let unused = got \\ want let missing = want \\ got let reasons = map (\x -> (fst $ head x, map snd x)) $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) $ map (classifyMissing &&& id) missing let summary = table $ let (*) = (,) in ["HLint hints" * want ,"HOL proofs" * got ,"Useful proofs" * (got `intersect` want) ,"Unused proofs" * unused ,"Unproved hints" * missing] ++ [(" " ++ name) * ps | (name,ps) <- reasons] putStr $ unlines summary forM_ reports $ \report -> do let out = ("Unused proofs",unused) : map (first ("Unproved hints - " ++)) reasons writeFile report $ unlines $ summary ++ "" : concat [("== " ++ a ++ " ==") : "" : map show b | (a,b) <- out] putStrLn $ "Report written to " ++ report where table xs = [a ++ replicate (n + 6 - length a - length bb) ' ' ++ bb | (a,b) <- xs, let bb = show $ length b] where n = maximum $ map (length . fst) xs missingFuncs = let a*b = [(b,a) | b <- words b] in concat ["IO" * "putChar putStr print putStrLn getLine getChar getContents hReady hPrint stdin" ,"Exit" * "exitSuccess" ,"Ord" * "(>) (<=) (>=) (<) compare minimum maximum sort sortBy" ,"Show" * "show shows showIntAtBase" ,"Read" * "reads read" ,"String" * "lines unlines words unwords" ,"Monad" * "mapM mapM_ sequence sequence_ msum mplus mzero liftM when unless return evaluate join void (>>=) (<=<) (>=>) forever ap" ,"Functor" * "fmap" ,"Numeric" * "(+) (*) fromInteger fromIntegral negate log (/) (-) (*) (^^) (^) subtract sqrt even odd" ,"Char" * "isControl isPrint isUpper isLower isAlpha isDigit" ,"Arrow" * "second first (***) (&&&)" ,"Applicative+" * "traverse for traverse_ for_ pure (<|>) (<**>)" ,"Exception" * "catch handle catchJust bracket error toException" ,"WeakPtr" * "mkWeak" ] -- | Guess why a theorem is missing classifyMissing :: Theorem -> String classifyMissing Theorem{original = Just MatchExp{..}} | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (lhs,rhs)] = "case" | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (lhs,rhs)] = "list-comp" | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name SrcSpanInfo) | v <- universeBi (lhs,rhs)] = v classifyMissing _ = "?unknown" -- Extract theorems out of Isabelle code (HLint.thy) isabelleTheorems :: FilePath -> String -> [Theorem] isabelleTheorems file = find . lexer 1 where find ((i,"lemma"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest find ((i,"lemma"):(_,name):(_,":"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest find ((i,"lemma"):(_,"assumes"):(_,'\"':assumes):(_,"shows"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) (assumes ++ " \\ " ++ lemma) : find rest find ((i,"lemma"):rest) = Theorem Nothing (file ++ ":" ++ show i) "Unsupported lemma format" : find rest find (x:xs) = find xs find [] = [] lexer i x | i `seq` False = [] | Just x <- stripPrefix "(*" x, (a,b) <- breaks "*)" x = lexer (add a i) b | Just x <- stripPrefix "\"" x, (a,b) <- breaks "\"" x = (i,'\"':a) : lexer (add a i) b -- NOTE: drop the final " | x:xs <- x, isSpace x = lexer (add [x] i) xs | (a@(_:_),b) <- span (\y -> y == '_' || isAlpha y) x = (i,a) : lexer (add a i) b lexer i (x:xs) = (i,[x]) : lexer (add [x] i) xs lexer i [] = [] add s i = length (filter (== '\n') s) + i breaks s x | Just x <- stripPrefix s x = ("",x) breaks s (x:xs) = let (a,b) = breaks s xs in (x:a,b) breaks s [] = ([],[]) reparen :: Setting -> Setting reparen m@MatchExp{..} = m{lhs = f False lhs, rhs = f True rhs} where f right x = if isLambda x || isIf x || badInfix x then Paren (ann x) x else x badInfix (InfixApp _ _ op _) = prettyPrint op `elem` words "|| && ." badInfix _ = False reparen x = x -- Extract theorems out of the hints hintTheorems :: [Setting] -> [Theorem] hintTheorems xs = [ Theorem (Just m) (loc $ ann lhs) $ maybe "" assumes side ++ relationship notes a b | m@MatchExp{..} <- map reparen xs, let a = exp1 $ typeclasses notes lhs, let b = exp1 rhs, a /= b] where loc (SrcSpanInfo (SrcSpan file ln _ _ _) _) = takeFileName file ++ ":" ++ show ln subs xs = flip lookup [(reverse b, reverse a) | x <- words xs, let (a,'=':b) = break (== '=') $ reverse x] funs = subs "id=ID not=neg or=the_or and=the_and (||)=tror (&&)=trand (++)=append (==)=eq (/=)=neq ($)=dollar" ops = subs "||=orelse &&=andalso .=oo ===eq /==neq ++=++ !!=!! $=dollar $!=dollarBang" pre = flip elem $ words "eq neq dollar dollarBang" cons = subs "True=TT False=FF" typeclasses notes x = foldr f x notes where f (ValidInstance cls var) x = evalState (transformM g x) True where g v@Var{} | v ~= var = do b <- get; put False return $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v g v = return v :: State Bool Exp_ f _ x = x relationship notes a b | any lazier notes = a ++ " \\ " ++ b | DecreasesLaziness `elem` notes = b ++ " \\ " ++ a | otherwise = a ++ " = " ++ b where lazier IncreasesLaziness = True lazier RemovesError{} = True lazier _ = False assumes (App _ op var) | op ~= "isNat" = "le\\0\\" ++ prettyPrint var ++ " \\ FF \\ " | op ~= "isNegZero" = "gt\\0\\" ++ prettyPrint var ++ " \\ FF \\ " assumes (App _ op var) | op ~= "isWHNF" = prettyPrint var ++ " \\ \\ \\ " assumes _ = "" exp1 = exp . transformBi unqual -- Syntax translations exp (App _ a b) = exp a ++ "\\" ++ exp b exp (Paren _ x) = "(" ++ exp x ++ ")" exp (Var _ x) | Just x <- funs $ prettyPrint x = x exp (Con _ (Special _ (TupleCon _ _ i))) = "\\" ++ replicate (i-1) ',' ++ "\\" exp (Con _ x) | Just x <- cons $ prettyPrint x = x exp (Tuple _ _ xs) = "\\" ++ intercalate ", " (map exp xs) ++ "\\" exp (If _ a b c) = "If " ++ exp a ++ " then " ++ exp b ++ " else " ++ exp c exp (Lambda _ xs y) = "\\ " ++ unwords (map pat xs) ++ ". " ++ exp y exp (InfixApp _ x op y) | Just op <- ops $ prettyPrint op = if pre op then op ++ "\\" ++ exp (paren x) ++ "\\" ++ exp (paren y) else exp x ++ " " ++ op ++ " " ++ exp y -- Translations from the Haskell 2010 report exp (InfixApp l a (QVarOp _ b) c) = exp $ App l (App l (Var l b) a) c -- S3.4 exp x@(LeftSection l e op) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l e op (toNamed v) -- S3.5 exp x@(RightSection l op e) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l (toNamed v) op e -- S3.5 exp x = prettyPrint x pat (PTuple _ _ xs) = "\\" ++ intercalate ", " (map pat xs) ++ "\\" pat x = prettyPrint x fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x hlint-1.8.53/src/Parallel.hs0000644000000000000000000000224712220306165013775 0ustar0000000000000000{- 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 import GHC.Conc(numCapabilities) import Control.Concurrent import Control.Monad parallel :: [IO a] -> IO [a] parallel = if numCapabilities <= 1 then parallel1 else parallelN parallel1 :: [IO a] -> IO [a] parallel1 [] = return [] parallel1 (x:xs) = do x2 <- x xs2 <- unsafeInterleaveIO $ parallel1 xs return $ x2:xs2 parallelN :: [IO a] -> IO [a] parallelN xs = do ms <- mapM (const newEmptyMVar) xs chan <- newChan mapM_ (writeChan chan . Just) $ zip ms xs replicateM_ numCapabilities (writeChan chan Nothing >> forkIO (f chan)) parallel1 $ map takeMVar ms where f chan = do v <- readChan chan case v of Nothing -> return () Just (m,x) -> do x' <- x putMVar m x' f chan hlint-1.8.53/src/Main.hs0000644000000000000000000000036712220306165013126 0ustar0000000000000000 module Main where import Language.Haskell.HLint import Control.Monad import System.Environment import System.Exit main :: IO () main = do args <- getArgs errs <- hlint args when (length errs > 0) $ exitWith $ ExitFailure 1 hlint-1.8.53/src/Idea.hs0000644000000000000000000000270012220306165013075 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} module Idea(module Idea, Note(..), showNotes, Severity(..)) where import HSE.All import Settings import Language.Haskell.HsColour.TTY import Language.Haskell.HsColour.Colourise import Util data Idea = Idea {func :: FuncName, severity :: Severity, hint :: String, loc :: SrcLoc, from :: String, to :: String, note :: [Note]} | ParseError {severity :: Severity, 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 severity ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to ++ ["Note: " ++ n | let n = showNotes note, n /= ""] where f msg x | null xs = [msg ++ " remove it."] | otherwise = (msg ++ ":") : map (" "++) xs where xs = lines $ tt x showEx tt ParseError{..} = unlines $ [showSrcLoc loc ++ ": Parse error","Error message:"," " ++ msg,"Code:"] ++ map (" "++) (lines $ tt from) rawIdea = Idea ("","") idea severity hint from to = rawIdea severity hint (toSrcLoc $ ann from) (f from) (f to) [] where f = ltrim . prettyPrint warn = idea Warning err = idea Error hlint-1.8.53/src/HLint.hs0000644000000000000000000000673712220306165013267 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where import Control.Monad import Data.List import Data.Maybe import System.Exit import CmdLine import Settings import Report import Idea import Apply import Test import Proof import Util import Parallel import HSE.All -- | 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 -- | From a suggestion, determine how severe it is. suggestionSeverity :: Suggestion -> Severity suggestionSeverity = severity . 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 writes to the stdout/stderr streams, unless @--quiet@ is specified. -- -- As an example: -- -- > do hints <- hlint ["src", "--ignore=Use map","--quiet"] -- > when (length hints > 3) $ error "Too many hints!" hlint :: [String] -> IO [Suggestion] hlint args = do cmd@Cmd{..} <- getCmd args let flags = parseFlags{cppFlags=cmdCpp, encoding=cmdEncoding, language=cmdLanguage} if cmdTest then do failed <- test (\x -> hlint x >> return ()) cmdDataDir cmdGivenHints when (failed > 0) exitFailure return [] else if notNull cmdProof then do s <- readAllSettings cmd flags 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 =<< findSettings flags x) cmdFindHints >> return [] else if isNothing cmdFiles then exitWithHelp else if cmdFiles == Just [] then error "No files found" else runHints cmd flags readAllSettings :: Cmd -> ParseFlags -> IO [Setting] readAllSettings Cmd{..} flags = do settings1 <- readSettings cmdDataDir cmdHintFiles cmdWithHints settings2 <- concatMapM (fmap snd . findSettings flags) cmdFindHints settings3 <- return [Classify Ignore x ("","") | x <- cmdIgnore] return $ settings1 ++ settings2 ++ settings3 runHints :: Cmd -> ParseFlags -> IO [Suggestion] runHints cmd@Cmd{..} flags = do let outStrLn x = unless cmdQuiet $ putStrLn x settings <- readAllSettings cmd flags let files = fromMaybe [] cmdFiles ideas <- if cmdCross then applyHintFiles flags settings files else fmap concat $ parallel [listM' =<< applyHintFile flags settings x | x <- files] let (showideas,hideideas) = partition (\i -> cmdShowAll || severity i /= Ignore) ideas showItem <- if cmdColor then showANSI else return show mapM_ (outStrLn . showItem) showideas if null showideas then when (cmdReports /= []) $ outStrLn "Skipping writing reports" else forM_ cmdReports $ \x -> do outStrLn $ "Writing report to " ++ x ++ " ..." writeReport cmdDataDir x showideas outStrLn $ (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 hlint-1.8.53/src/CmdLine.hs0000644000000000000000000002142612220306165013554 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module CmdLine(Cmd(..), CppFlags(..), getCmd, exitWithHelp) where import Control.Monad import Data.Char import Data.List import Data.Maybe import System.Console.GetOpt import System.Directory import System.Exit import System.FilePath import Language.Preprocessor.Cpphs import Language.Haskell.Exts.Extension import Util import Paths_hlint import Data.Version data CppFlags = NoCpp | CppSimple | Cpphs CpphsOptions -- 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 ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given ,cmdWithHints :: [String] -- ^ hints that are given on the command line ,cmdReports :: [FilePath] -- ^ where to generate reports ,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 ,cmdCross :: Bool -- ^ work between source files, applies to hints such as duplicate code between modules ,cmdProof :: [FilePath] -- ^ a proof script to check against } 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 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" ] -- | 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 fmap 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 <- newEncoding $ 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] } exitWithHelp :: IO a exitWithHelp = do putStr helpText exitSuccess versionText :: String versionText = "HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2013\n" 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 getFile :: [FilePath] -> [String] -> FilePath -> IO [FilePath] getFile path _ "-" = return ["-"] getFile [] exts file = error $ "Couldn't find file: " ++ file getFile (p:ath) exts file = do isDir <- doesDirectoryExist $ p <\> file if isDir then do xs <- getDirectoryContentsRecursive $ p <\> file return [x | x <- xs, drop 1 (takeExtension x) `elem` exts] else do isFil <- doesFileExist $ p <\> file if isFil then return [p <\> file] else do res <- getModule p exts file case res of Just x -> return [x] Nothing -> getFile ath exts file getModule :: FilePath -> [String] -> FilePath -> IO (Maybe FilePath) getModule path exts x | not (any isSpace x) && all isMod xs = f exts where xs = words $ map (\x -> if x == '.' then ' ' else x) x isMod (x:xs) = isUpper x && all (\x -> isAlphaNum x || x == '_') xs isMod _ = False pre = path <\> joinPath xs f [] = return Nothing f (x:xs) = do let s = pre <.> x b <- doesFileExist s if b then return $ Just s else f xs getModule _ _ _ = return Nothing getHintFile :: FilePath -> FilePath -> IO FilePath getHintFile _ "-" = return "-" getHintFile dataDir x = do let poss = nub $ concat [x : [x <.> "hs" | takeExtension x /= ".hs"] | x <- [x,dataDir x]] f poss poss where f o [] = error $ unlines $ [ "Couldn't find file: " ++ x, "Tried with:"] ++ map (" "++) o 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 hlint-1.8.53/src/Apply.hs0000644000000000000000000001025012220306165013317 0ustar0000000000000000 module Apply(applyHintFile, applyHintFiles, applyHintString) where import HSE.All import Hint.All import Control.Arrow import Data.Char import Data.List import Data.Maybe import Data.Ord import Settings import Idea import Util -- | Apply hints to a single file. applyHintFile :: ParseFlags -> [Setting] -> FilePath -> IO [Idea] applyHintFile flags s file = do res <- parseModuleFile flags s file return $ case res of Left err -> [err] Right m -> executeHints s [m] -- | Apply hints to the contents of a single file. applyHintString :: ParseFlags -> [Setting] -> FilePath -> String -> IO [Idea] applyHintString flags s file src = do res <- parseModuleString flags s file src return $ case res of Left err -> [err] Right m -> executeHints s [m] -- | Apply hints to multiple files, allowing cross-file hints to fire. applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea] applyHintFiles flags s files = do (err, ms) <- fmap unzipEither $ mapM (parseModuleFile flags s) files return $ err ++ executeHints s ms -- | Given a list of settings (a way to classify) and a list of hints, run them over a list of modules. executeHints :: [Setting] -> [Module_] -> [Idea] executeHints s ms = concat $ [ map (classify $ s ++ mapMaybe readPragma (moduleDecls m)) $ order "" [i | ModuHint h <- hints, i <- h nm m] ++ concat [order (fromNamed d) [i | h <- decHints, i <- h d] | d <- moduleDecls m] | (nm,m) <- mns , let decHints = [h nm m | DeclHint h <- hints] -- partially apply , let order n = map (\i -> i{func = (moduleName m,n)}) . sortBy (comparing loc)] ++ [map (classify s) $ op mns | CrossHint op <- hints] where mns = map (moduleScope &&& id) ms hints = for (allHints s) $ \x -> case x of CrossHint op | length ms <= 1 -> ModuHint $ \a b -> op [(a,b)] _ -> x -- | Like 'parseModuleString', but also load the file from disk. parseModuleFile :: ParseFlags -> [Setting] -> FilePath -> IO (Either Idea Module_) parseModuleFile flags s file = do src <- readFileEncoding (encoding flags) file parseModuleString flags s file src -- | Return either an idea (a parse error) or the module. In IO because might call the C pre processor. parseModuleString :: ParseFlags -> [Setting] -> FilePath -> String -> IO (Either Idea Module_) parseModuleString flags s file src = do res <- parseString flags{infixes=[x | Infix x <- s]} file src case snd res of ParseOk m -> return $ Right m ParseFailed sl msg | length src `seq` True -> 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 $ Left $ classify s $ ParseError Warning "Parse error" sl msg ctxt -- | Given a line number, and some source code, put bird ticks around the appropriate bit. context :: Int -> String -> String context lineNo src = unlines $ trimBy (all isSpace) $ zipWith (++) ticks $ take 5 $ drop (lineNo - 3) $ lines src ++ [""] where ticks = [" "," ","> "," "," "] -- | Find which hints a list of settings implies. 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 -- | Given some settings, make sure the severity field of the Idea is correct. classify :: [Setting] -> Idea -> Idea classify xs i = i{severity = foldl' (f i) (severity i) $ filter isClassify xs} where -- figure out if we need to change the severity f :: Idea -> Severity -> Setting -> Severity f i r c | matchHint (hintS c) (hint i) && matchFunc (funcS c) (func_ i) = severityS c | otherwise = r func_ x = if isParseError x then ("","") else func x matchHint = (~=) matchFunc (x1,x2) (y1,y2) = (x1~=y1) && (x2~=y2) x ~= y = null x || x == y hlint-1.8.53/src/Language/0000755000000000000000000000000012220306165013423 5ustar0000000000000000hlint-1.8.53/src/Language/Haskell/0000755000000000000000000000000012220306165015006 5ustar0000000000000000hlint-1.8.53/src/Language/Haskell/HLint.hs0000644000000000000000000000034012220306165016355 0ustar0000000000000000{-| 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(module HLint) where import HLint hlint-1.8.53/src/HSE/0000755000000000000000000000000012220306165012317 5ustar0000000000000000hlint-1.8.53/src/HSE/Util.hs0000644000000000000000000002163312220306165013575 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module HSE.Util where import Control.Monad import Data.List import Data.Maybe import System.FilePath import HSE.Type import Language.Haskell.Exts.Annotated.Simplify(sQName, sAssoc) --------------------------------------------------------------------- -- ACCESSOR/TESTER opExp :: QOp S -> Exp_ 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 moduleName :: Module_ -> String moduleName (Module _ Nothing _ _ _) = "Main" moduleName (Module _ (Just (ModuleHead _ (ModuleName _ x) _ _)) _ _ _) = x moduleImports :: Module_ -> [ImportDecl S] moduleImports (Module _ _ _ x _) = x modulePragmas :: Module_ -> [ModulePragma S] modulePragmas (Module _ _ x _ _) = x fromModuleName :: ModuleName S -> String fromModuleName (ModuleName _ x) = x isChar :: Exp_ -> Bool isChar (Lit _ Char{}) = True isChar _ = False fromChar :: Exp_ -> Char fromChar (Lit _ (Char _ x _)) = x isString :: Exp_ -> Bool isString (Lit _ String{}) = True isString _ = False fromString :: Exp_ -> String fromString (Lit _ (String _ x _)) = x isPString (PLit _ String{}) = True; isPString _ = False fromPString (PLit _ (String _ x _)) = x fromParen :: Exp_ -> Exp_ fromParen (Paren _ x) = fromParen x fromParen x = x fromPParen :: Pat s -> Pat s fromPParen (PParen _ x) = fromPParen x fromPParen x = x fromTyParen :: Type s -> Type s fromTyParen (TyParen _ x) = fromTyParen x fromTyParen x = x fromDeriving :: Deriving s -> [InstHead s] fromDeriving (Deriving _ x) = x -- is* :: Exp_ -> Bool -- is* :: Decl_ -> Bool isVar Var{} = True; isVar _ = False isCon Con{} = True; isCon _ = False isApp App{} = True; isApp _ = False isInfixApp InfixApp{} = True; isInfixApp _ = False isList List{} = True; isList _ = False isAnyApp x = isApp x || isInfixApp x isParen Paren{} = True; isParen _ = False isIf If{} = True; isIf _ = False isLambda Lambda{} = True; isLambda _ = False isMDo MDo{} = True; isMDo _ = False isBoxed Boxed{} = True; isBoxed _ = False isDerivDecl DerivDecl{} = True; isDerivDecl _ = False isPBangPat PBangPat{} = True; isPBangPat _ = False isPExplTypeArg PExplTypeArg{} = True; isPExplTypeArg _ = False isPFieldPun PFieldPun{} = True; isPFieldPun _ = False isFieldPun FieldPun{} = True; isFieldPun _ = False isPWildCard PWildCard{} = True; isPWildCard _ = False isPFieldWildcard PFieldWildcard{} = True; isPFieldWildcard _ = False isFieldWildcard FieldWildcard{} = True; isFieldWildcard _ = False isPViewPat PViewPat{} = True; isPViewPat _ = False isParComp ParComp{} = True; isParComp _ = False isPatTypeSig PatTypeSig{} = True; isPatTypeSig _ = False isQuasiQuote QuasiQuote{} = True; isQuasiQuote _ = False isSpliceDecl SpliceDecl{} = True; isSpliceDecl _ = False isNewType NewType{} = True; isNewType _ = False isSection LeftSection{} = True isSection RightSection{} = True isSection _ = False allowRightSection x = x `notElem` ["-","#"] allowLeftSection x = x /= "#" unqual :: QName S -> QName S unqual (Qual an _ x) = UnQual an x unqual x = x fromQual :: QName S -> Name S fromQual (Qual _ _ x) = x fromQual (UnQual _ x) = x isSpecial :: QName S -> Bool isSpecial Special{} = True; isSpecial _ = False isDol :: QOp S -> Bool isDol (QVarOp _ (UnQual _ (Symbol _ "$"))) = True isDol _ = False isDot :: QOp S -> Bool isDot (QVarOp _ (UnQual _ (Symbol _ "."))) = True isDot _ = False isDotApp :: Exp_ -> Bool isDotApp (InfixApp _ _ dot _) | isDot dot = True isDotApp _ = False dotApp :: Exp_ -> Exp_ -> Exp_ dotApp x = InfixApp an x (QVarOp an $ UnQual an $ Symbol an ".") dotApps :: [Exp_] -> Exp_ dotApps [x] = x dotApps (x:xs) = dotApp x (dotApps xs) isLexeme Var{} = True isLexeme Con{} = True isLexeme Lit{} = True isLexeme _ = False isWHNF :: Exp_ -> Bool isWHNF Con{} = True isWHNF Lit{} = True isWHNF Lambda{} = True isWHNF Tuple{} = True isWHNF List{} = True isWHNF (Paren _ x) = isWHNF x isWHNF RecConstr{} = True isWHNF (ExpTypeSig _ x _) = isWHNF x isWHNF _ = False --------------------------------------------------------------------- -- HSE FUNCTIONS getEquations :: Decl s -> [Decl s] getEquations (FunBind s xs) = map (FunBind s . (:[])) xs getEquations x@PatBind{} = [toFunBind x] getEquations x = [x] toFunBind :: Decl s -> Decl s toFunBind (PatBind s (PVar _ name) _ bod bind) = FunBind s [Match s name [] bod bind] toFunBind x = x fromGuardedAlts :: GuardedAlts s -> Rhs s fromGuardedAlts (UnGuardedAlt s x) = UnGuardedRhs s x fromGuardedAlts (GuardedAlts s xs) = GuardedRhss s [GuardedRhs a b c | GuardedAlt a b c <- xs] toGuardedAlts :: Rhs s -> GuardedAlts s toGuardedAlts (UnGuardedRhs s x) = UnGuardedAlt s x toGuardedAlts (GuardedRhss s xs) = GuardedAlts s [GuardedAlt a b c | GuardedRhs a b c <- xs] -- 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, Case s a . g bs) where f (Alt _ _ (UnGuardedAlt _ x) _) = [x] f (Alt _ _ (GuardedAlts _ xs) _) = [x | GuardedAlt _ _ x <- xs] g (Alt s1 a (UnGuardedAlt s2 _) b:rest) (x:xs) = Alt s1 a (UnGuardedAlt s2 x) b : g rest xs g (Alt s1 a (GuardedAlts s2 ns) b:rest) xs = Alt s1 a (GuardedAlts s2 [GuardedAlt a b x | (GuardedAlt a b _,x) <- zip ns as]) b : g rest bs where (as,bs) = splitAt (length ns) xs g [] [] = [] replaceBranches x = ([], \[] -> x) --------------------------------------------------------------------- -- VECTOR APPLICATION apps :: [Exp_] -> Exp_ apps = foldl1 (App an) fromApps :: Exp_ -> [Exp_] fromApps (App _ x y) = fromApps x ++ [y] fromApps x = [x] -- Rule for the Uniplate Apps functions -- Given (f a) b, consider the children to be: children f ++ [a,b] childrenApps :: Exp_ -> [Exp_] childrenApps (App _ x@App{} y) = childrenApps x ++ [y] childrenApps (App _ x y) = children x ++ [y] childrenApps x = children x descendApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_ descendApps f (App s x@App{} y) = App s (descendApps f x) (f y) descendApps f (App s x y) = App s (descend f x) (f y) descendApps f x = descend f x descendAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_ descendAppsM f (App s x@App{} y) = liftM2 (App s) (descendAppsM f x) (f y) descendAppsM f (App s x y) = liftM2 (App s) (descendM f x) (f y) descendAppsM f x = descendM f x universeApps :: Exp_ -> [Exp_] universeApps x = x : concatMap universeApps (childrenApps x) transformApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_ transformApps f = f . descendApps (transformApps f) transformAppsM :: (Monad m) => (Exp_ -> m Exp_) -> Exp_ -> m Exp_ transformAppsM f x = f =<< descendAppsM (transformAppsM f) x --------------------------------------------------------------------- -- UNIPLATE FUNCTIONS universeS :: Biplate x (f S) => x -> [f S] universeS = universeBi childrenS :: Biplate x (f S) => x -> [f S] childrenS = childrenBi -- return the parent along with the child universeParentExp :: Biplate a Exp_ => a -> [(Maybe (Int, Exp_), Exp_)] universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs] where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p] --------------------------------------------------------------------- -- SRCLOC FUNCTIONS showSrcLoc :: SrcLoc -> String showSrcLoc (SrcLoc file line col) = take 1 file ++ f (drop 1 file) ++ ":" ++ show line ++ ":" ++ show col where f (x:y:zs) | isPathSeparator x && isPathSeparator y = f $ x:zs f (x:xs) = x : f xs f [] = [] toSrcLoc :: SrcInfo si => si -> SrcLoc toSrcLoc = getPointLoc nullSrcLoc :: SrcLoc nullSrcLoc = SrcLoc "" 0 0 an :: SrcSpanInfo an = toSrcInfo nullSrcLoc [] nullSrcLoc dropAnn :: Functor f => f s -> f () dropAnn = fmap (const ()) --------------------------------------------------------------------- -- SRCLOC EQUALITY -- enforce all being on S, as otherwise easy to =~= on a Just, and get the wrong functor x /=~= y = not $ x =~= y elem_, notElem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool elem_ x = any (x =~=) notElem_ x = not . elem_ x nub_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] nub_ = nubBy (=~=) intersect_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> [f S] intersect_ = intersectBy (=~=) eqList, neqList :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> Bool neqList x y = not $ eqList x y eqList (x:xs) (y:ys) = x =~= y && eqList xs ys eqList [] [] = True eqList _ _ = False eqMaybe:: (Annotated f, Eq (f ())) => Maybe (f S) -> Maybe (f S) -> Bool eqMaybe (Just x) (Just y) = x =~= y eqMaybe Nothing Nothing = True eqMaybe _ _ = False --------------------------------------------------------------------- -- FIXITIES getFixity :: Decl a -> [Fixity] getFixity (InfixDecl sl a mp ops) = [Fixity (sAssoc a) (fromMaybe 9 mp) (sQName $ UnQual sl $ f op) | op <- ops] where f (VarOp _ x) = x f (ConOp _ x) = x getFixity _ = [] hlint-1.8.53/src/HSE/Type.hs0000644000000000000000000011107612220306165013602 0ustar0000000000000000 module HSE.Type(module HSE.Type, module Export) where -- Almost all from the Annotated module, but the fixity resolution from Annotated -- uses the unannotated Assoc enumeration, so export that instead import Language.Haskell.Exts.Annotated as Export hiding (parse, loc, parseFile, paren, Assoc(..)) import Language.Haskell.Exts as Export(Assoc(..)) import Data.Generics.Uniplate.Data as Export type S = SrcSpanInfo type Module_ = Module S type Decl_ = Decl S type Exp_ = Exp S type Pat_ = Pat S type Type_ = Type S {-! deriving instance UniplateDirect (Pat S) (Pat S) deriving instance UniplateDirect (Exp S) deriving instance UniplateDirect (Pat S) deriving instance UniplateDirect (Pat S) (Exp S) deriving instance UniplateDirect (Binds S) (Exp S) deriving instance UniplateDirect (Alt S) (Exp S) deriving instance UniplateDirect (Stmt S) (Exp S) deriving instance UniplateDirect (QualStmt S) (Exp S) deriving instance UniplateDirect [QualStmt S] (Exp S) deriving instance UniplateDirect (Bracket S) (Exp S) deriving instance UniplateDirect (Splice S) (Exp S) deriving instance UniplateDirect (XAttr S) (Exp S) deriving instance UniplateDirect (Maybe (Exp S)) (Exp S) deriving instance UniplateDirect (FieldUpdate S) (Exp S) deriving instance UniplateDirect (PatField S) (Pat S) deriving instance UniplateDirect (Exp S) (Pat S) deriving instance UniplateDirect (RPat S) (Pat S) deriving instance UniplateDirect (PXAttr S) (Pat S) deriving instance UniplateDirect (Maybe (Pat S)) (Pat S) deriving instance UniplateDirect (PatField S) (Exp S) deriving instance UniplateDirect (RPat S) (Exp S) deriving instance UniplateDirect (PXAttr S) (Exp S) deriving instance UniplateDirect (Maybe (Pat S)) (Exp S) deriving instance UniplateDirect (Decl S) (Exp S) deriving instance UniplateDirect (IPBind S) (Exp S) deriving instance UniplateDirect (GuardedAlts S) (Exp S) deriving instance UniplateDirect (Maybe (Binds S)) (Exp S) deriving instance UniplateDirect (Maybe (Exp S)) (Exp S) deriving instance UniplateDirect (FieldUpdate S) (Exp S) deriving instance UniplateDirect (PatField S) (Pat S) deriving instance UniplateDirect (Exp S) (Pat S) deriving instance UniplateDirect (RPat S) (Pat S) deriving instance UniplateDirect (PXAttr S) (Pat S) deriving instance UniplateDirect (Maybe (Pat S)) (Pat S) deriving instance UniplateDirect (PatField S) (Exp S) deriving instance UniplateDirect (RPat S) (Exp S) deriving instance UniplateDirect (PXAttr S) (Exp S) deriving instance UniplateDirect (Maybe (Pat S)) (Exp S) deriving instance UniplateDirect (Decl S) (Exp S) deriving instance UniplateDirect (IPBind S) (Exp S) deriving instance UniplateDirect (GuardedAlts S) (Exp S) deriving instance UniplateDirect (Maybe (Binds S)) (Exp S) deriving instance UniplateDirect (Binds S) (Pat S) deriving instance UniplateDirect (Alt S) (Pat S) deriving instance UniplateDirect (Stmt S) (Pat S) deriving instance UniplateDirect (Maybe (Exp S)) (Pat S) deriving instance UniplateDirect (FieldUpdate S) (Pat S) deriving instance UniplateDirect (QualStmt S) (Pat S) deriving instance UniplateDirect [QualStmt S] (Pat S) deriving instance UniplateDirect (Bracket S) (Pat S) deriving instance UniplateDirect (Splice S) (Pat S) deriving instance UniplateDirect (XAttr S) (Pat S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Exp S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Exp S) deriving instance UniplateDirect (Match S) (Exp S) deriving instance UniplateDirect (Rhs S) (Exp S) deriving instance UniplateDirect (Rule S) (Exp S) deriving instance UniplateDirect (GuardedAlt S) (Exp S) deriving instance UniplateDirect (Decl S) (Pat S) deriving instance UniplateDirect (IPBind S) (Pat S) deriving instance UniplateDirect (GuardedAlts S) (Pat S) deriving instance UniplateDirect (Maybe (Binds S)) (Pat S) deriving instance UniplateDirect (ClassDecl S) (Exp S) deriving instance UniplateDirect (InstDecl S) (Exp S) deriving instance UniplateDirect (GuardedRhs S) (Exp S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Pat S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Pat S) deriving instance UniplateDirect (Match S) (Pat S) deriving instance UniplateDirect (Rhs S) (Pat S) deriving instance UniplateDirect (Rule S) (Pat S) deriving instance UniplateDirect (GuardedAlt S) (Pat S) deriving instance UniplateDirect (ClassDecl S) (Pat S) deriving instance UniplateDirect (InstDecl S) (Pat S) deriving instance UniplateDirect (GuardedRhs S) (Pat S) deriving instance UniplateDirect (Maybe (Binds S)) (Decl S) deriving instance UniplateDirect (Exp S) (Name S) deriving instance UniplateDirect (Decl S) deriving instance UniplateDirect (Binds S) (Decl S) deriving instance UniplateDirect (Name S) deriving instance UniplateDirect (QName S) (Name S) deriving instance UniplateDirect (QOp S) (Name S) deriving instance UniplateDirect (Pat S) (Name S) deriving instance UniplateDirect (Binds S) (Name S) deriving instance UniplateDirect (Alt S) (Name S) deriving instance UniplateDirect (Stmt S) (Name S) deriving instance UniplateDirect (Maybe (Exp S)) (Name S) deriving instance UniplateDirect (FieldUpdate S) (Name S) deriving instance UniplateDirect (QualStmt S) (Name S) deriving instance UniplateDirect [QualStmt S] (Name S) deriving instance UniplateDirect (Type S) (Name S) deriving instance UniplateDirect (Bracket S) (Name S) deriving instance UniplateDirect (Splice S) (Name S) deriving instance UniplateDirect (XAttr S) (Name S) deriving instance UniplateDirect (Decl S) (Name S) deriving instance UniplateDirect (Exp S) (Decl S) deriving instance UniplateDirect (GuardedAlts S) (Name S) deriving instance UniplateDirect (IPBind S) (Decl S) deriving instance UniplateDirect (IPBind S) (Name S) deriving instance UniplateDirect (Kind S) (Name S) deriving instance UniplateDirect (Match S) (Decl S) deriving instance UniplateDirect (Maybe (Binds S)) (Name S) deriving instance UniplateDirect (Maybe (Context S)) (Name S) deriving instance UniplateDirect (Maybe (Pat S)) (Name S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Decl S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Decl S) deriving instance UniplateDirect (Maybe [TyVarBind S]) (Name S) deriving instance UniplateDirect (PXAttr S) (Name S) deriving instance UniplateDirect (Pat S) (Decl S) deriving instance UniplateDirect (PatField S) (Name S) deriving instance UniplateDirect (RPat S) (Name S) deriving instance UniplateDirect (Rhs S) (Decl S) deriving instance UniplateDirect (Rule S) (Decl S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Name S) deriving instance UniplateDirect (InstHead S) (Name S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Name S) deriving instance UniplateDirect (Op S) (Name S) deriving instance UniplateDirect (Match S) (Name S) deriving instance UniplateDirect (Maybe (Type S)) (Name S) deriving instance UniplateDirect (Rhs S) (Name S) deriving instance UniplateDirect (Rule S) (Name S) deriving instance UniplateDirect ([Name S], String) (Name S) deriving instance UniplateDirect (Alt S) (Decl S) deriving instance UniplateDirect (Stmt S) (Decl S) deriving instance UniplateDirect (Maybe (Exp S)) (Decl S) deriving instance UniplateDirect (FieldUpdate S) (Decl S) deriving instance UniplateDirect (QualStmt S) (Decl S) deriving instance UniplateDirect [QualStmt S] (Decl S) deriving instance UniplateDirect (Bracket S) (Decl S) deriving instance UniplateDirect (Splice S) (Decl S) deriving instance UniplateDirect (XAttr S) (Decl S) deriving instance UniplateDirect (GuardedAlt S) (Name S) deriving instance UniplateDirect (Context S) (Name S) deriving instance UniplateDirect (ClassDecl S) (Decl S) deriving instance UniplateDirect (InstDecl S) (Decl S) deriving instance UniplateDirect (TyVarBind S) (Name S) deriving instance UniplateDirect (PatField S) (Decl S) deriving instance UniplateDirect (RPat S) (Decl S) deriving instance UniplateDirect (PXAttr S) (Decl S) deriving instance UniplateDirect (Maybe (Pat S)) (Decl S) deriving instance UniplateDirect (GuardedRhs S) (Decl S) deriving instance UniplateDirect (DeclHead S) (Name S) deriving instance UniplateDirect (Maybe (Kind S)) (Name S) deriving instance UniplateDirect (QualConDecl S) (Name S) deriving instance UniplateDirect (Maybe (Deriving S)) (Name S) deriving instance UniplateDirect (GadtDecl S) (Name S) deriving instance UniplateDirect (FunDep S) (Name S) deriving instance UniplateDirect (ClassDecl S) (Name S) deriving instance UniplateDirect (InstDecl S) (Name S) deriving instance UniplateDirect (GuardedRhs S) (Name S) deriving instance UniplateDirect (Maybe [RuleVar S]) (Name S) deriving instance UniplateDirect (GuardedAlts S) (Decl S) deriving instance UniplateDirect (Asst S) (Name S) deriving instance UniplateDirect (ConDecl S) (Name S) deriving instance UniplateDirect (Deriving S) (Name S) deriving instance UniplateDirect (RuleVar S) (Name S) deriving instance UniplateDirect (GuardedAlt S) (Decl S) deriving instance UniplateDirect (BangType S) (Name S) deriving instance UniplateDirect (FieldDecl S) (Name S) deriving instance UniplateDirect (Module S) (FunDep S) deriving instance UniplateDirect (Module S) (IPName S) deriving instance UniplateDirect (Module S) (Decl S) deriving instance UniplateDirect (Module S) (Kind S) deriving instance UniplateDirect (Module S) (Pat S) deriving instance UniplateDirect (Module S) (CallConv S) deriving instance UniplateDirect (Module S) (GuardedRhs S) deriving instance UniplateDirect (Module S) (GuardedAlt S) deriving instance UniplateDirect (Module S) (PatField S) deriving instance UniplateDirect (Module S) Boxed deriving instance UniplateDirect (Module S) (ImportDecl S) deriving instance UniplateDirect (Module S) (Exp S) deriving instance UniplateDirect (Module S) (QualStmt S) deriving instance UniplateDirect (Exp S) (CallConv S) deriving instance UniplateDirect (GuardedRhs S) deriving instance UniplateDirect (Decl S) (GuardedRhs S) deriving instance UniplateDirect (XAttr S) (GuardedRhs S) deriving instance UniplateDirect (Maybe (Exp S)) (GuardedRhs S) deriving instance UniplateDirect (Exp S) (GuardedRhs S) deriving instance UniplateDirect (GuardedAlt S) deriving instance UniplateDirect (Decl S) (GuardedAlt S) deriving instance UniplateDirect (XAttr S) (GuardedAlt S) deriving instance UniplateDirect (Maybe (Exp S)) (GuardedAlt S) deriving instance UniplateDirect (Exp S) (GuardedAlt S) deriving instance UniplateDirect (PatField S) deriving instance UniplateDirect (Decl S) (PatField S) deriving instance UniplateDirect (XAttr S) (PatField S) deriving instance UniplateDirect (Maybe (Exp S)) (PatField S) deriving instance UniplateDirect (Exp S) (PatField S) deriving instance UniplateDirect Boxed deriving instance UniplateDirect (Maybe (ModuleHead S)) Boxed deriving instance UniplateDirect (Decl S) Boxed deriving instance UniplateDirect (XAttr S) Boxed deriving instance UniplateDirect (Maybe (Exp S)) Boxed deriving instance UniplateDirect (Exp S) Boxed deriving instance UniplateDirect (ImportDecl S) deriving instance UniplateDirect (QualStmt S) deriving instance UniplateDirect (Decl S) (QualStmt S) deriving instance UniplateDirect (XAttr S) (QualStmt S) deriving instance UniplateDirect (Maybe (Exp S)) (QualStmt S) deriving instance UniplateDirect (Exp S) (QualStmt S) deriving instance UniplateDirect (Maybe (Type S)) Boxed deriving instance UniplateDirect (Rhs S) Boxed deriving instance UniplateDirect (Maybe (Binds S)) Boxed deriving instance UniplateDirect (Rule S) Boxed deriving instance UniplateDirect (QName S) Boxed deriving instance UniplateDirect (QOp S) Boxed deriving instance UniplateDirect (Binds S) Boxed deriving instance UniplateDirect (Alt S) Boxed deriving instance UniplateDirect (Stmt S) Boxed deriving instance UniplateDirect (FieldUpdate S) Boxed deriving instance UniplateDirect (QualStmt S) Boxed deriving instance UniplateDirect [QualStmt S] Boxed deriving instance UniplateDirect (Bracket S) Boxed deriving instance UniplateDirect (Splice S) Boxed deriving instance UniplateDirect (Stmt S) (QualStmt S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (QualStmt S) deriving instance UniplateDirect (Maybe [InstDecl S]) (QualStmt S) deriving instance UniplateDirect (Match S) (QualStmt S) deriving instance UniplateDirect (Pat S) (QualStmt S) deriving instance UniplateDirect (Rhs S) (QualStmt S) deriving instance UniplateDirect (Maybe (Binds S)) (QualStmt S) deriving instance UniplateDirect (Rule S) (QualStmt S) deriving instance UniplateDirect (Binds S) (QualStmt S) deriving instance UniplateDirect (Alt S) (QualStmt S) deriving instance UniplateDirect (FieldUpdate S) (QualStmt S) deriving instance UniplateDirect [QualStmt S] (QualStmt S) deriving instance UniplateDirect (Bracket S) (QualStmt S) deriving instance UniplateDirect (Splice S) (QualStmt S) deriving instance UniplateDirect (FunDep S) deriving instance UniplateDirect (Decl S) (FunDep S) deriving instance UniplateDirect (XAttr S) (FunDep S) deriving instance UniplateDirect (Maybe (Exp S)) (FunDep S) deriving instance UniplateDirect (Exp S) (FunDep S) deriving instance UniplateDirect (IPName S) deriving instance UniplateDirect (Decl S) (IPName S) deriving instance UniplateDirect (XAttr S) (IPName S) deriving instance UniplateDirect (Maybe (Exp S)) (IPName S) deriving instance UniplateDirect (Exp S) (IPName S) deriving instance UniplateDirect (Kind S) deriving instance UniplateDirect (Decl S) (Kind S) deriving instance UniplateDirect (XAttr S) (Kind S) deriving instance UniplateDirect (Maybe (Exp S)) (Kind S) deriving instance UniplateDirect (Exp S) (Kind S) deriving instance UniplateDirect (CallConv S) deriving instance UniplateDirect (Decl S) (CallConv S) deriving instance UniplateDirect (XAttr S) (CallConv S) deriving instance UniplateDirect (Maybe (Exp S)) (CallConv S) deriving instance UniplateDirect (CallConv S) deriving instance UniplateDirect (Pat S) (CallConv S) deriving instance UniplateDirect (Binds S) (CallConv S) deriving instance UniplateDirect (Alt S) (CallConv S) deriving instance UniplateDirect (Stmt S) (CallConv S) deriving instance UniplateDirect (FieldUpdate S) (CallConv S) deriving instance UniplateDirect (QualStmt S) (CallConv S) deriving instance UniplateDirect [QualStmt S] (CallConv S) deriving instance UniplateDirect (Bracket S) (CallConv S) deriving instance UniplateDirect (Splice S) (CallConv S) deriving instance UniplateDirect (Stmt S) (GuardedRhs S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (GuardedRhs S) deriving instance UniplateDirect (Maybe [InstDecl S]) (GuardedRhs S) deriving instance UniplateDirect (Match S) (GuardedRhs S) deriving instance UniplateDirect (Pat S) (GuardedRhs S) deriving instance UniplateDirect (Rhs S) (GuardedRhs S) deriving instance UniplateDirect (Maybe (Binds S)) (GuardedRhs S) deriving instance UniplateDirect (Rule S) (GuardedRhs S) deriving instance UniplateDirect (Binds S) (GuardedRhs S) deriving instance UniplateDirect (Alt S) (GuardedRhs S) deriving instance UniplateDirect (FieldUpdate S) (GuardedRhs S) deriving instance UniplateDirect (QualStmt S) (GuardedRhs S) deriving instance UniplateDirect [QualStmt S] (GuardedRhs S) deriving instance UniplateDirect (Bracket S) (GuardedRhs S) deriving instance UniplateDirect (Splice S) (GuardedRhs S) deriving instance UniplateDirect (Stmt S) (GuardedAlt S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (GuardedAlt S) deriving instance UniplateDirect (Maybe [InstDecl S]) (GuardedAlt S) deriving instance UniplateDirect (Match S) (GuardedAlt S) deriving instance UniplateDirect (Pat S) (GuardedAlt S) deriving instance UniplateDirect (Rhs S) (GuardedAlt S) deriving instance UniplateDirect (Maybe (Binds S)) (GuardedAlt S) deriving instance UniplateDirect (Rule S) (GuardedAlt S) deriving instance UniplateDirect (Binds S) (GuardedAlt S) deriving instance UniplateDirect (Alt S) (GuardedAlt S) deriving instance UniplateDirect (FieldUpdate S) (GuardedAlt S) deriving instance UniplateDirect (QualStmt S) (GuardedAlt S) deriving instance UniplateDirect [QualStmt S] (GuardedAlt S) deriving instance UniplateDirect (Bracket S) (GuardedAlt S) deriving instance UniplateDirect (Splice S) (GuardedAlt S) deriving instance UniplateDirect (Pat S) (PatField S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (PatField S) deriving instance UniplateDirect (Maybe [InstDecl S]) (PatField S) deriving instance UniplateDirect (Match S) (PatField S) deriving instance UniplateDirect (Rhs S) (PatField S) deriving instance UniplateDirect (Maybe (Binds S)) (PatField S) deriving instance UniplateDirect (Rule S) (PatField S) deriving instance UniplateDirect (Binds S) (PatField S) deriving instance UniplateDirect (Alt S) (PatField S) deriving instance UniplateDirect (Stmt S) (PatField S) deriving instance UniplateDirect (FieldUpdate S) (PatField S) deriving instance UniplateDirect (QualStmt S) (PatField S) deriving instance UniplateDirect [QualStmt S] (PatField S) deriving instance UniplateDirect (Bracket S) (PatField S) deriving instance UniplateDirect (Splice S) (PatField S) deriving instance UniplateDirect (ModuleHead S) Boxed deriving instance UniplateDirect (Type S) Boxed deriving instance UniplateDirect (Maybe (Context S)) Boxed deriving instance UniplateDirect (QualConDecl S) Boxed deriving instance UniplateDirect (Maybe (Deriving S)) Boxed deriving instance UniplateDirect (GadtDecl S) Boxed deriving instance UniplateDirect (Maybe [ClassDecl S]) Boxed deriving instance UniplateDirect (InstHead S) Boxed deriving instance UniplateDirect (Maybe [InstDecl S]) Boxed deriving instance UniplateDirect (Match S) Boxed deriving instance UniplateDirect (Pat S) Boxed deriving instance UniplateDirect (GuardedRhs S) Boxed deriving instance UniplateDirect (Maybe [RuleVar S]) Boxed deriving instance UniplateDirect (SpecialCon S) Boxed deriving instance UniplateDirect (IPBind S) Boxed deriving instance UniplateDirect (GuardedAlts S) Boxed deriving instance UniplateDirect (ClassDecl S) (QualStmt S) deriving instance UniplateDirect (InstDecl S) (QualStmt S) deriving instance UniplateDirect (PatField S) (QualStmt S) deriving instance UniplateDirect (RPat S) (QualStmt S) deriving instance UniplateDirect (PXAttr S) (QualStmt S) deriving instance UniplateDirect (Maybe (Pat S)) (QualStmt S) deriving instance UniplateDirect (GuardedRhs S) (QualStmt S) deriving instance UniplateDirect (IPBind S) (QualStmt S) deriving instance UniplateDirect (GuardedAlts S) (QualStmt S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (FunDep S) deriving instance UniplateDirect (Maybe [InstDecl S]) (FunDep S) deriving instance UniplateDirect (Match S) (FunDep S) deriving instance UniplateDirect (Pat S) (FunDep S) deriving instance UniplateDirect (Rhs S) (FunDep S) deriving instance UniplateDirect (Maybe (Binds S)) (FunDep S) deriving instance UniplateDirect (Rule S) (FunDep S) deriving instance UniplateDirect (Binds S) (FunDep S) deriving instance UniplateDirect (Alt S) (FunDep S) deriving instance UniplateDirect (Stmt S) (FunDep S) deriving instance UniplateDirect (FieldUpdate S) (FunDep S) deriving instance UniplateDirect (QualStmt S) (FunDep S) deriving instance UniplateDirect [QualStmt S] (FunDep S) deriving instance UniplateDirect (Bracket S) (FunDep S) deriving instance UniplateDirect (Splice S) (FunDep S) deriving instance UniplateDirect (Type S) (IPName S) deriving instance UniplateDirect (Maybe (Context S)) (IPName S) deriving instance UniplateDirect (QualConDecl S) (IPName S) deriving instance UniplateDirect (Maybe (Deriving S)) (IPName S) deriving instance UniplateDirect (GadtDecl S) (IPName S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (IPName S) deriving instance UniplateDirect (InstHead S) (IPName S) deriving instance UniplateDirect (Maybe [InstDecl S]) (IPName S) deriving instance UniplateDirect (Match S) (IPName S) deriving instance UniplateDirect (Pat S) (IPName S) deriving instance UniplateDirect (Maybe (Type S)) (IPName S) deriving instance UniplateDirect (Rhs S) (IPName S) deriving instance UniplateDirect (Maybe (Binds S)) (IPName S) deriving instance UniplateDirect (Rule S) (IPName S) deriving instance UniplateDirect (Binds S) (IPName S) deriving instance UniplateDirect (Alt S) (IPName S) deriving instance UniplateDirect (Stmt S) (IPName S) deriving instance UniplateDirect (FieldUpdate S) (IPName S) deriving instance UniplateDirect (QualStmt S) (IPName S) deriving instance UniplateDirect [QualStmt S] (IPName S) deriving instance UniplateDirect (Bracket S) (IPName S) deriving instance UniplateDirect (Splice S) (IPName S) deriving instance UniplateDirect (DeclHead S) (Kind S) deriving instance UniplateDirect (Type S) (Kind S) deriving instance UniplateDirect (Maybe (Kind S)) (Kind S) deriving instance UniplateDirect (Maybe (Context S)) (Kind S) deriving instance UniplateDirect (QualConDecl S) (Kind S) deriving instance UniplateDirect (Maybe (Deriving S)) (Kind S) deriving instance UniplateDirect (GadtDecl S) (Kind S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Kind S) deriving instance UniplateDirect (InstHead S) (Kind S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Kind S) deriving instance UniplateDirect (Match S) (Kind S) deriving instance UniplateDirect (Pat S) (Kind S) deriving instance UniplateDirect (Maybe (Type S)) (Kind S) deriving instance UniplateDirect (Rhs S) (Kind S) deriving instance UniplateDirect (Maybe (Binds S)) (Kind S) deriving instance UniplateDirect (Rule S) (Kind S) deriving instance UniplateDirect (Binds S) (Kind S) deriving instance UniplateDirect (Alt S) (Kind S) deriving instance UniplateDirect (Stmt S) (Kind S) deriving instance UniplateDirect (FieldUpdate S) (Kind S) deriving instance UniplateDirect (QualStmt S) (Kind S) deriving instance UniplateDirect [QualStmt S] (Kind S) deriving instance UniplateDirect (Bracket S) (Kind S) deriving instance UniplateDirect (Splice S) (Kind S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (CallConv S) deriving instance UniplateDirect (Maybe [InstDecl S]) (CallConv S) deriving instance UniplateDirect (Match S) (CallConv S) deriving instance UniplateDirect (Rhs S) (CallConv S) deriving instance UniplateDirect (Maybe (Binds S)) (CallConv S) deriving instance UniplateDirect (Rule S) (CallConv S) deriving instance UniplateDirect (PatField S) (CallConv S) deriving instance UniplateDirect (RPat S) (CallConv S) deriving instance UniplateDirect (PXAttr S) (CallConv S) deriving instance UniplateDirect (Maybe (Pat S)) (CallConv S) deriving instance UniplateDirect (IPBind S) (CallConv S) deriving instance UniplateDirect (GuardedAlts S) (CallConv S) deriving instance UniplateDirect (ClassDecl S) (GuardedRhs S) deriving instance UniplateDirect (InstDecl S) (GuardedRhs S) deriving instance UniplateDirect (PatField S) (GuardedRhs S) deriving instance UniplateDirect (RPat S) (GuardedRhs S) deriving instance UniplateDirect (PXAttr S) (GuardedRhs S) deriving instance UniplateDirect (Maybe (Pat S)) (GuardedRhs S) deriving instance UniplateDirect (IPBind S) (GuardedRhs S) deriving instance UniplateDirect (GuardedAlts S) (GuardedRhs S) deriving instance UniplateDirect (ClassDecl S) (GuardedAlt S) deriving instance UniplateDirect (InstDecl S) (GuardedAlt S) deriving instance UniplateDirect (PatField S) (GuardedAlt S) deriving instance UniplateDirect (RPat S) (GuardedAlt S) deriving instance UniplateDirect (PXAttr S) (GuardedAlt S) deriving instance UniplateDirect (Maybe (Pat S)) (GuardedAlt S) deriving instance UniplateDirect (GuardedRhs S) (GuardedAlt S) deriving instance UniplateDirect (IPBind S) (GuardedAlt S) deriving instance UniplateDirect (GuardedAlts S) (GuardedAlt S) deriving instance UniplateDirect (RPat S) (PatField S) deriving instance UniplateDirect (PXAttr S) (PatField S) deriving instance UniplateDirect (Maybe (Pat S)) (PatField S) deriving instance UniplateDirect (ClassDecl S) (PatField S) deriving instance UniplateDirect (InstDecl S) (PatField S) deriving instance UniplateDirect (GuardedRhs S) (PatField S) deriving instance UniplateDirect (IPBind S) (PatField S) deriving instance UniplateDirect (GuardedAlts S) (PatField S) deriving instance UniplateDirect (Maybe (ExportSpecList S)) Boxed deriving instance UniplateDirect (Context S) Boxed deriving instance UniplateDirect (ConDecl S) Boxed deriving instance UniplateDirect (Deriving S) Boxed deriving instance UniplateDirect (ClassDecl S) Boxed deriving instance UniplateDirect (InstDecl S) Boxed deriving instance UniplateDirect (PatField S) Boxed deriving instance UniplateDirect (RPat S) Boxed deriving instance UniplateDirect (PXAttr S) Boxed deriving instance UniplateDirect (Maybe (Pat S)) Boxed deriving instance UniplateDirect (RuleVar S) Boxed deriving instance UniplateDirect (GuardedAlt S) Boxed deriving instance UniplateDirect (GuardedAlt S) (QualStmt S) deriving instance UniplateDirect (ClassDecl S) (FunDep S) deriving instance UniplateDirect (InstDecl S) (FunDep S) deriving instance UniplateDirect (PatField S) (FunDep S) deriving instance UniplateDirect (RPat S) (FunDep S) deriving instance UniplateDirect (PXAttr S) (FunDep S) deriving instance UniplateDirect (Maybe (Pat S)) (FunDep S) deriving instance UniplateDirect (GuardedRhs S) (FunDep S) deriving instance UniplateDirect (IPBind S) (FunDep S) deriving instance UniplateDirect (GuardedAlts S) (FunDep S) deriving instance UniplateDirect (Context S) (IPName S) deriving instance UniplateDirect (ConDecl S) (IPName S) deriving instance UniplateDirect (Deriving S) (IPName S) deriving instance UniplateDirect (ClassDecl S) (IPName S) deriving instance UniplateDirect (InstDecl S) (IPName S) deriving instance UniplateDirect (PatField S) (IPName S) deriving instance UniplateDirect (RPat S) (IPName S) deriving instance UniplateDirect (PXAttr S) (IPName S) deriving instance UniplateDirect (Maybe (Pat S)) (IPName S) deriving instance UniplateDirect (GuardedRhs S) (IPName S) deriving instance UniplateDirect (Maybe [RuleVar S]) (IPName S) deriving instance UniplateDirect (IPBind S) (IPName S) deriving instance UniplateDirect (GuardedAlts S) (IPName S) deriving instance UniplateDirect (TyVarBind S) (Kind S) deriving instance UniplateDirect (Maybe [TyVarBind S]) (Kind S) deriving instance UniplateDirect (Context S) (Kind S) deriving instance UniplateDirect (ConDecl S) (Kind S) deriving instance UniplateDirect (Deriving S) (Kind S) deriving instance UniplateDirect (ClassDecl S) (Kind S) deriving instance UniplateDirect (InstDecl S) (Kind S) deriving instance UniplateDirect (PatField S) (Kind S) deriving instance UniplateDirect (RPat S) (Kind S) deriving instance UniplateDirect (PXAttr S) (Kind S) deriving instance UniplateDirect (Maybe (Pat S)) (Kind S) deriving instance UniplateDirect (GuardedRhs S) (Kind S) deriving instance UniplateDirect (Maybe [RuleVar S]) (Kind S) deriving instance UniplateDirect (IPBind S) (Kind S) deriving instance UniplateDirect (GuardedAlts S) (Kind S) deriving instance UniplateDirect (ClassDecl S) (CallConv S) deriving instance UniplateDirect (InstDecl S) (CallConv S) deriving instance UniplateDirect (GuardedRhs S) (CallConv S) deriving instance UniplateDirect (GuardedAlt S) (CallConv S) deriving instance UniplateDirect (GuardedAlt S) (GuardedRhs S) deriving instance UniplateDirect (GuardedAlt S) (PatField S) deriving instance UniplateDirect (ExportSpecList S) Boxed deriving instance UniplateDirect (Asst S) Boxed deriving instance UniplateDirect (BangType S) Boxed deriving instance UniplateDirect (FieldDecl S) Boxed deriving instance UniplateDirect (GuardedAlt S) (FunDep S) deriving instance UniplateDirect (Asst S) (IPName S) deriving instance UniplateDirect (BangType S) (IPName S) deriving instance UniplateDirect (FieldDecl S) (IPName S) deriving instance UniplateDirect (RuleVar S) (IPName S) deriving instance UniplateDirect (GuardedAlt S) (IPName S) deriving instance UniplateDirect (Asst S) (Kind S) deriving instance UniplateDirect (BangType S) (Kind S) deriving instance UniplateDirect (FieldDecl S) (Kind S) deriving instance UniplateDirect (RuleVar S) (Kind S) deriving instance UniplateDirect (GuardedAlt S) (Kind S) deriving instance UniplateDirect (ExportSpec S) Boxed deriving instance UniplateDirect (Module S) (Splice S) deriving instance UniplateDirect (Module S) (Bracket S) deriving instance UniplateDirect (Splice S) deriving instance UniplateDirect (Decl S) (Splice S) deriving instance UniplateDirect (XAttr S) (Splice S) deriving instance UniplateDirect (Maybe (Exp S)) (Splice S) deriving instance UniplateDirect (Exp S) (Splice S) deriving instance UniplateDirect (Bracket S) deriving instance UniplateDirect (Decl S) (Bracket S) deriving instance UniplateDirect (XAttr S) (Bracket S) deriving instance UniplateDirect (Maybe (Exp S)) (Bracket S) deriving instance UniplateDirect (Exp S) (Bracket S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Splice S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Splice S) deriving instance UniplateDirect (Match S) (Splice S) deriving instance UniplateDirect (Pat S) (Splice S) deriving instance UniplateDirect (Rhs S) (Splice S) deriving instance UniplateDirect (Maybe (Binds S)) (Splice S) deriving instance UniplateDirect (Rule S) (Splice S) deriving instance UniplateDirect (Binds S) (Splice S) deriving instance UniplateDirect (Alt S) (Splice S) deriving instance UniplateDirect (Stmt S) (Splice S) deriving instance UniplateDirect (FieldUpdate S) (Splice S) deriving instance UniplateDirect (QualStmt S) (Splice S) deriving instance UniplateDirect [QualStmt S] (Splice S) deriving instance UniplateDirect (Bracket S) (Splice S) deriving instance UniplateDirect (Pat S) (Bracket S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Bracket S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Bracket S) deriving instance UniplateDirect (Match S) (Bracket S) deriving instance UniplateDirect (Rhs S) (Bracket S) deriving instance UniplateDirect (Maybe (Binds S)) (Bracket S) deriving instance UniplateDirect (Rule S) (Bracket S) deriving instance UniplateDirect (Binds S) (Bracket S) deriving instance UniplateDirect (Alt S) (Bracket S) deriving instance UniplateDirect (Stmt S) (Bracket S) deriving instance UniplateDirect (FieldUpdate S) (Bracket S) deriving instance UniplateDirect (QualStmt S) (Bracket S) deriving instance UniplateDirect [QualStmt S] (Bracket S) deriving instance UniplateDirect (Splice S) (Bracket S) deriving instance UniplateDirect (ClassDecl S) (Splice S) deriving instance UniplateDirect (InstDecl S) (Splice S) deriving instance UniplateDirect (PatField S) (Splice S) deriving instance UniplateDirect (RPat S) (Splice S) deriving instance UniplateDirect (PXAttr S) (Splice S) deriving instance UniplateDirect (Maybe (Pat S)) (Splice S) deriving instance UniplateDirect (GuardedRhs S) (Splice S) deriving instance UniplateDirect (IPBind S) (Splice S) deriving instance UniplateDirect (GuardedAlts S) (Splice S) deriving instance UniplateDirect (PatField S) (Bracket S) deriving instance UniplateDirect (RPat S) (Bracket S) deriving instance UniplateDirect (PXAttr S) (Bracket S) deriving instance UniplateDirect (Maybe (Pat S)) (Bracket S) deriving instance UniplateDirect (ClassDecl S) (Bracket S) deriving instance UniplateDirect (InstDecl S) (Bracket S) deriving instance UniplateDirect (GuardedRhs S) (Bracket S) deriving instance UniplateDirect (IPBind S) (Bracket S) deriving instance UniplateDirect (GuardedAlts S) (Bracket S) deriving instance UniplateDirect (GuardedAlt S) (Splice S) deriving instance UniplateDirect (GuardedAlt S) (Bracket S) deriving instance UniplateDirect (Exp S) (Exp S) deriving instance UniplateDirect [Pat S] (Pat S) deriving instance UniplateDirect (Module S) (Name S) deriving instance UniplateDirect (Maybe (ModuleHead S)) (Name S) deriving instance UniplateDirect (OptionPragma S) (Name S) deriving instance UniplateDirect (ImportDecl S) (Name S) deriving instance UniplateDirect (ModuleHead S) (Name S) deriving instance UniplateDirect (Maybe (ImportSpecList S)) (Name S) deriving instance UniplateDirect (Maybe (ExportSpecList S)) (Name S) deriving instance UniplateDirect (ImportSpecList S) (Name S) deriving instance UniplateDirect (ExportSpecList S) (Name S) deriving instance UniplateDirect (ImportSpec S) (Name S) deriving instance UniplateDirect (ExportSpec S) (Name S) deriving instance UniplateDirect (CName S) (Name S) deriving instance UniplateDirect [Stmt S] (Exp S) deriving instance UniplateDirect (Decl S) (Type S) deriving instance UniplateDirect (Type S) deriving instance UniplateDirect (Maybe (Context S)) (Type S) deriving instance UniplateDirect (QualConDecl S) (Type S) deriving instance UniplateDirect (Maybe (Deriving S)) (Type S) deriving instance UniplateDirect (GadtDecl S) (Type S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (Type S) deriving instance UniplateDirect (InstHead S) (Type S) deriving instance UniplateDirect (Maybe [InstDecl S]) (Type S) deriving instance UniplateDirect (Exp S) (Type S) deriving instance UniplateDirect (Match S) (Type S) deriving instance UniplateDirect (Pat S) (Type S) deriving instance UniplateDirect (Maybe (Type S)) (Type S) deriving instance UniplateDirect (Rhs S) (Type S) deriving instance UniplateDirect (Maybe (Binds S)) (Type S) deriving instance UniplateDirect (Rule S) (Type S) deriving instance UniplateDirect (Context S) (Type S) deriving instance UniplateDirect (ConDecl S) (Type S) deriving instance UniplateDirect (Deriving S) (Type S) deriving instance UniplateDirect (ClassDecl S) (Type S) deriving instance UniplateDirect (InstDecl S) (Type S) deriving instance UniplateDirect (Binds S) (Type S) deriving instance UniplateDirect (Alt S) (Type S) deriving instance UniplateDirect (Stmt S) (Type S) deriving instance UniplateDirect (Maybe (Exp S)) (Type S) deriving instance UniplateDirect (FieldUpdate S) (Type S) deriving instance UniplateDirect (QualStmt S) (Type S) deriving instance UniplateDirect [QualStmt S] (Type S) deriving instance UniplateDirect (Bracket S) (Type S) deriving instance UniplateDirect (Splice S) (Type S) deriving instance UniplateDirect (XAttr S) (Type S) deriving instance UniplateDirect (PatField S) (Type S) deriving instance UniplateDirect (RPat S) (Type S) deriving instance UniplateDirect (PXAttr S) (Type S) deriving instance UniplateDirect (Maybe (Pat S)) (Type S) deriving instance UniplateDirect (GuardedRhs S) (Type S) deriving instance UniplateDirect (Maybe [RuleVar S]) (Type S) deriving instance UniplateDirect (Asst S) (Type S) deriving instance UniplateDirect (BangType S) (Type S) deriving instance UniplateDirect (FieldDecl S) (Type S) deriving instance UniplateDirect (IPBind S) (Type S) deriving instance UniplateDirect (GuardedAlts S) (Type S) deriving instance UniplateDirect (RuleVar S) (Type S) deriving instance UniplateDirect (GuardedAlt S) (Type S) deriving instance UniplateDirect (Exp S) (QName S) deriving instance UniplateDirect (QName S) deriving instance UniplateDirect (QOp S) (QName S) deriving instance UniplateDirect (Pat S) (QName S) deriving instance UniplateDirect (Binds S) (QName S) deriving instance UniplateDirect (Alt S) (QName S) deriving instance UniplateDirect (Stmt S) (QName S) deriving instance UniplateDirect (Maybe (Exp S)) (QName S) deriving instance UniplateDirect (FieldUpdate S) (QName S) deriving instance UniplateDirect (QualStmt S) (QName S) deriving instance UniplateDirect [QualStmt S] (QName S) deriving instance UniplateDirect (Type S) (QName S) deriving instance UniplateDirect (Bracket S) (QName S) deriving instance UniplateDirect (Splice S) (QName S) deriving instance UniplateDirect (XAttr S) (QName S) deriving instance UniplateDirect (PatField S) (QName S) deriving instance UniplateDirect (RPat S) (QName S) deriving instance UniplateDirect (PXAttr S) (QName S) deriving instance UniplateDirect (Maybe (Pat S)) (QName S) deriving instance UniplateDirect (Decl S) (QName S) deriving instance UniplateDirect (IPBind S) (QName S) deriving instance UniplateDirect (GuardedAlts S) (QName S) deriving instance UniplateDirect (Maybe (Binds S)) (QName S) deriving instance UniplateDirect (Maybe (Context S)) (QName S) deriving instance UniplateDirect (QualConDecl S) (QName S) deriving instance UniplateDirect (Maybe (Deriving S)) (QName S) deriving instance UniplateDirect (GadtDecl S) (QName S) deriving instance UniplateDirect (Maybe [ClassDecl S]) (QName S) deriving instance UniplateDirect (InstHead S) (QName S) deriving instance UniplateDirect (Maybe [InstDecl S]) (QName S) deriving instance UniplateDirect (Match S) (QName S) deriving instance UniplateDirect (Maybe (Type S)) (QName S) deriving instance UniplateDirect (Rhs S) (QName S) deriving instance UniplateDirect (Rule S) (QName S) deriving instance UniplateDirect (GuardedAlt S) (QName S) deriving instance UniplateDirect (Context S) (QName S) deriving instance UniplateDirect (ConDecl S) (QName S) deriving instance UniplateDirect (Deriving S) (QName S) deriving instance UniplateDirect (ClassDecl S) (QName S) deriving instance UniplateDirect (InstDecl S) (QName S) deriving instance UniplateDirect (GuardedRhs S) (QName S) deriving instance UniplateDirect (Maybe [RuleVar S]) (QName S) deriving instance UniplateDirect (Asst S) (QName S) deriving instance UniplateDirect (BangType S) (QName S) deriving instance UniplateDirect (FieldDecl S) (QName S) deriving instance UniplateDirect (RuleVar S) (QName S) !-} hlint-1.8.53/src/HSE/NameMatch.hs0000644000000000000000000000617712220306165014523 0ustar0000000000000000 module HSE.NameMatch( Scope, emptyScope, moduleScope, scopeImports, NameMatch, nameMatch, nameQualify ) where import HSE.Type import HSE.Util import Data.List import Data.Maybe {- the hint file can do: import Prelude (filter) import Data.List (filter) import List (filter) then filter on it's own will get expanded to all of them import Data.List import List as Data.List if Data.List.head x ==> x, then that might match List too -} type NameMatch = QName S -> QName S -> Bool data Scope = Scope [ImportDecl S] deriving Show moduleScope :: Module S -> Scope moduleScope xs = Scope $ [prelude | not $ any isPrelude res] ++ res where res = [x | x <- moduleImports xs, importPkg x /= Just "hint"] prelude = ImportDecl an (ModuleName an "Prelude") False False Nothing Nothing Nothing isPrelude x = fromModuleName (importModule x) == "Prelude" emptyScope :: Scope emptyScope = Scope [] scopeImports :: Scope -> [ImportDecl S] scopeImports (Scope x) = x -- given A B x y, does A{x} possibly refer to the same name as B{y} -- this property is reflexive nameMatch :: Scope -> Scope -> NameMatch nameMatch a b x@Special{} y@Special{} = x =~= y nameMatch a b x y | isSpecial x || isSpecial y = False nameMatch a b x y = unqual x =~= unqual y && not (null $ possModules a x `intersect` possModules b y) -- given A B x, return y such that A{x} == B{y}, if you can nameQualify :: Scope -> Scope -> QName S -> QName S nameQualify a (Scope b) x | isSpecial x = x | null imps = head $ real ++ [x] | any (not . importQualified) imps = unqual x | otherwise = Qual an (head $ mapMaybe importAs imps ++ map importModule imps) $ fromQual x where real = [Qual an (ModuleName an m) $ fromQual x | m <- possModules a x] imps = [i | r <- real, i <- b, possImport i r] -- which modules could a name possibly lie in -- if it's qualified but not matching any import, assume the user -- just lacks an import possModules :: Scope -> QName S -> [String] possModules (Scope is) x = f x where res = [fromModuleName $ importModule i | i <- is, possImport i x] f Special{} = [""] f x@(Qual _ mod _) = [fromModuleName mod | null res] ++ res f _ = res possImport :: ImportDecl S -> QName S -> Bool possImport i Special{} = False possImport i (Qual _ mod x) = fromModuleName mod `elem` map fromModuleName ms && possImport i{importQualified=False} (UnQual an x) where ms = importModule i : maybeToList (importAs i) possImport i (UnQual _ x) = not (importQualified i) && maybe True f (importSpecs i) where f (ImportSpecList _ hide xs) = if hide then Just True `notElem` ms else Nothing `elem` ms || Just True `elem` ms where ms = map g xs g :: ImportSpec S -> Maybe Bool -- does this import cover the name x g (IVar _ y) = Just $ x =~= y g (IAbs _ y) = Just $ x =~= y g (IThingAll _ y) = if x =~= y then Just True else Nothing g (IThingWith _ y ys) = Just $ x `elem_` (y : map fromCName ys) fromCName :: CName S -> Name S fromCName (VarName _ x) = x fromCName (ConName _ x) = x hlint-1.8.53/src/HSE/Match.hs0000644000000000000000000001030512220306165013706 0ustar0000000000000000{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} module HSE.Match where import Data.Char import HSE.Type import HSE.Util import qualified Language.Haskell.Exts as HSE_ class View a b where view :: a -> b data App2 = NoApp2 | App2 Exp_ Exp_ Exp_ deriving Show instance View Exp_ App2 where view (fromParen -> InfixApp _ lhs op rhs) = App2 (opExp op) lhs rhs view (fromParen -> App _ (fromParen -> App _ f x) y) = App2 f x y view _ = NoApp2 data App1 = NoApp1 | App1 Exp_ Exp_ deriving Show instance View Exp_ App1 where view (fromParen -> App _ f x) = App1 f x view _ = NoApp1 data PVar_ = NoPVar_ | PVar_ String instance View Pat_ PVar_ where view (fromPParen -> PVar _ x) = PVar_ $ fromNamed x view _ = NoPVar_ data Var_ = NoVar_ | Var_ String deriving Eq instance View Exp_ Var_ where view (fromParen -> Var _ (UnQual _ x)) = Var_ $ fromNamed x view _ = NoVar_ (~=) :: Named a => a -> String -> Bool (~=) = (==) . fromNamed -- | fromNamed will return \"\" when it cannot be represented -- toNamed may crash on \"\" class Named a where toNamed :: String -> a fromNamed :: a -> String isCtor (x:_) = isUpper x || x == ':' isCtor _ = False isSym (x:_) = not $ isAlpha x || x `elem` "_'" isSym _ = False instance Named (Exp S) where fromNamed (Var _ x) = fromNamed x fromNamed (Con _ x) = fromNamed x fromNamed (List _ []) = "[]" fromNamed _ = "" toNamed "[]" = List an [] toNamed x | isCtor x = Con an $ toNamed x | otherwise = Var an $ toNamed x instance Named (QName S) where fromNamed (Special _ Cons{}) = ":" fromNamed (Special _ UnitCon{}) = "()" fromNamed (UnQual _ x) = fromNamed x fromNamed _ = "" toNamed ":" = Special an $ Cons an toNamed x = UnQual an $ toNamed x instance Named HSE_.QName where fromNamed (HSE_.Special HSE_.Cons) = ":" fromNamed (HSE_.Special HSE_.UnitCon) = "()" fromNamed (HSE_.UnQual x) = fromNamed x fromNamed _ = "" toNamed ":" = HSE_.Special HSE_.Cons toNamed x = HSE_.UnQual $ toNamed x instance Named (Name S) where fromNamed (Ident _ x) = x fromNamed (Symbol _ x) = x toNamed x | isSym x = Symbol an x | otherwise = Ident an x instance Named HSE_.Name where fromNamed (HSE_.Ident x) = x fromNamed (HSE_.Symbol x) = x toNamed x | isSym x = HSE_.Symbol x | otherwise = HSE_.Ident x instance Named (ModuleName S) where fromNamed (ModuleName _ x) = x toNamed = ModuleName an instance Named (Pat S) where fromNamed (PVar _ x) = fromNamed x fromNamed (PApp _ x []) = fromNamed x fromNamed _ = "" toNamed x | isCtor x = PApp an (toNamed x) [] | otherwise = PVar an $ toNamed x instance Named (TyVarBind S) where fromNamed (KindedVar _ x _) = fromNamed x fromNamed (UnkindedVar _ x) = fromNamed x toNamed x = UnkindedVar an (toNamed x) instance Named (QOp S) where fromNamed (QVarOp _ x) = fromNamed x fromNamed (QConOp _ x) = fromNamed x toNamed x | isCtor x = QConOp an $ toNamed x | otherwise = QVarOp an $ toNamed x instance Named (Match S) where fromNamed (Match _ x _ _ _) = fromNamed x fromNamed (InfixMatch _ _ x _ _ _) = fromNamed x toNamed = error "No toNamed for Match" instance Named (DeclHead S) where fromNamed (DHead _ x _) = fromNamed x fromNamed (DHInfix _ _ x _) = fromNamed x fromNamed (DHParen _ x) = fromNamed x toNamed = error "No toNamed for DeclHead" instance Named (Decl S) where fromNamed (TypeDecl _ name _) = fromNamed name fromNamed (DataDecl _ _ _ name _ _) = fromNamed name fromNamed (GDataDecl _ _ _ name _ _ _) = fromNamed name fromNamed (TypeFamDecl _ name _) = fromNamed name fromNamed (DataFamDecl _ _ name _) = fromNamed name fromNamed (ClassDecl _ _ name _ _) = fromNamed name fromNamed (PatBind _ (PVar _ name) _ _ _) = fromNamed name fromNamed (FunBind _ (name:_)) = fromNamed name fromNamed (ForImp _ _ _ _ name _) = fromNamed name fromNamed (ForExp _ _ _ name _) = fromNamed name fromNamed (TypeSig _ (name:_) _) = fromNamed name fromNamed _ = "" toNamed = error "No toNamed for Decl" hlint-1.8.53/src/HSE/FreeVars.hs0000644000000000000000000001222412220306165014371 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module HSE.FreeVars(FreeVars, freeVars, vars, varss, pvars, declBind) where import HSE.Type import Data.Monoid import qualified Data.Set as Set import Data.Set(Set) -- which names are bound by a declaration declBind :: Decl_ -> [String] declBind x = pvars x vars x = Set.toList $ freeVars x varss x = Set.toList $ free $ allVars x pvars x = Set.toList $ bound $ allVars x (^+) = Set.union (^-) = Set.difference data Vars = Vars {bound :: Set String, free :: Set String} instance Monoid Vars where mempty = Vars Set.empty Set.empty mappend (Vars x1 x2) (Vars y1 y2) = Vars (x1 ^+ y1) (x2 ^+ y2) mconcat fvs = Vars (Set.unions $ map bound fvs) (Set.unions $ map free fvs) class AllVars a where -- | Return the variables, erring on the side of more free variables allVars :: a -> Vars class FreeVars a where -- | Return the variables, erring on the side of more free variables freeVars :: a -> Set String freeVars_ :: FreeVars a => a -> Vars freeVars_ = Vars Set.empty . freeVars inFree :: (AllVars a, FreeVars b) => a -> b -> Set String inFree a b = free aa ^+ (freeVars b ^- bound aa) where aa = allVars a inVars :: (AllVars a, AllVars b) => a -> b -> Vars inVars a b = Vars (bound aa ^+ bound bb) (free aa ^+ (free bb ^- bound aa)) where aa = allVars a bb = allVars b unqualNames :: QName S -> [String] unqualNames (UnQual _ x) = [prettyPrint x] unqualNames _ = [] unqualOp :: QOp S -> [String] unqualOp (QVarOp _ x) = unqualNames x unqualOp (QConOp _ x) = unqualNames x instance FreeVars (Set String) where freeVars = id instance AllVars Vars where allVars = id instance FreeVars Exp_ where -- never has any bound variables freeVars (Var _ x) = Set.fromList $ unqualNames x freeVars (VarQuote l x) = freeVars $ Var l x freeVars (SpliceExp _ (IdSplice _ x)) = Set.fromList [x] freeVars (InfixApp _ a op b) = freeVars a ^+ Set.fromList (unqualOp op) ^+ freeVars b freeVars (LeftSection _ a op) = freeVars a ^+ Set.fromList (unqualOp op) freeVars (RightSection _ op b) = Set.fromList (unqualOp op) ^+ freeVars b freeVars (Lambda _ p x) = inFree p x freeVars (Let _ bind x) = inFree bind x freeVars (Case _ x alts) = freeVars x `mappend` freeVars alts freeVars (Do _ xs) = free $ allVars xs freeVars (MDo l xs) = freeVars $ Do l xs freeVars (ParComp _ x xs) = free xfv ^+ (freeVars x ^- bound xfv) where xfv = mconcat $ map allVars xs freeVars (ListComp l x xs) = freeVars $ ParComp l x [xs] freeVars x = freeVars $ children x instance FreeVars [Exp_] where freeVars = Set.unions . map freeVars instance AllVars Pat_ where allVars (PVar _ x) = Vars (Set.singleton $ prettyPrint x) Set.empty allVars (PNPlusK l x _) = allVars (PVar l x) allVars (PAsPat l n x) = allVars (PVar l n) `mappend` allVars x allVars (PWildCard _) = mempty -- explicitly cannot guess what might be bound here allVars (PViewPat _ e p) = freeVars_ e `mappend` allVars p allVars x = allVars $ children x instance AllVars [Pat_] where allVars = mconcat . map allVars instance FreeVars (Alt S) where freeVars (Alt _ pat alt bind) = inFree pat $ inFree bind alt instance FreeVars [Alt S] where freeVars = mconcat . map freeVars instance FreeVars (GuardedAlts S) where freeVars (UnGuardedAlt _ x) = freeVars x freeVars (GuardedAlts _ xs) = mconcat $ map freeVars xs instance FreeVars (GuardedAlt S) where freeVars (GuardedAlt _ stmt exp) = inFree stmt exp instance FreeVars (Rhs S) where freeVars (UnGuardedRhs _ x) = freeVars x freeVars (GuardedRhss _ xs) = mconcat $ map freeVars xs instance FreeVars (GuardedRhs S) where freeVars (GuardedRhs _ stmt exp) = inFree stmt exp instance AllVars (QualStmt S) where allVars (QualStmt _ x) = allVars x allVars x = freeVars_ (childrenBi x :: [Exp_]) instance AllVars [QualStmt S] where allVars (x:xs) = inVars x xs allVars [] = mempty instance AllVars [Stmt S] where allVars (x:xs) = inVars x xs allVars [] = mempty instance AllVars (Stmt S) where allVars (Generator _ pat exp) = allVars pat `mappend` freeVars_ exp allVars (Qualifier _ exp) = freeVars_ exp allVars (LetStmt _ binds) = allVars binds allVars (RecStmt _ stmts) = allVars stmts instance AllVars (Maybe (Binds S)) where allVars = maybe mempty allVars instance AllVars (Binds S) where allVars (BDecls _ decls) = allVars decls allVars (IPBinds _ binds) = freeVars_ binds instance AllVars [Decl S] where allVars = mconcat . map allVars instance AllVars (Decl S) where allVars (FunBind _ m) = allVars m allVars (PatBind _ pat _ rhs bind) = allVars pat `mappend` freeVars_ (inFree bind rhs) allVars _ = mempty instance AllVars [Match S] where allVars = mconcat . map allVars instance AllVars (Match S) where allVars (Match l name pat rhs binds) = allVars (PVar l name) `mappend` freeVars_ (inFree pat (inFree binds rhs)) allVars (InfixMatch l p1 name p2 rhs binds) = allVars $ Match l name (p1:p2) rhs binds instance FreeVars [IPBind S] where freeVars = mconcat . map freeVars instance FreeVars (IPBind S) where freeVars (IPBind _ _ exp) = freeVars exp hlint-1.8.53/src/HSE/Evaluate.hs0000644000000000000000000000156212220306165014425 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} -- Evaluate a HSE Exp as much as possible module HSE.Evaluate(evaluate) where import HSE.Match import HSE.Util import HSE.Type import HSE.Bracket evaluate :: Exp_ -> Exp_ evaluate = fromParen . transform evaluate1 evaluate1 :: Exp_ -> Exp_ evaluate1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n) where n = fromIntegral $ length xs evaluate1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n) where n = fromIntegral $ length xs evaluate1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y evaluate1 (view -> App2 op (Lit _ (Int _ x _)) (Lit _ (Int _ y _))) | op ~= ">=" = toNamed $ show $ x >= y evaluate1 (view -> App2 op x y) | op ~= "&&" && x ~= "True" = y | op ~= "&&" && x ~= "False" = x evaluate1 (Paren _ x) | isAtom x = x evaluate1 x = x hlint-1.8.53/src/HSE/Bracket.hs0000644000000000000000000001022412220306165014225 0ustar0000000000000000{-# LANGUAGE PatternGuards, TypeSynonymInstances, FlexibleInstances #-} module HSE.Bracket where import HSE.Type import HSE.Util import Util class Brackets a where remParen :: a -> Maybe a -- remove one paren, or Nothing if there is no paren addParen :: a -> a -- write out a paren -- | Is this item lexically requiring no bracketing ever -- i.e. is totally atomic isAtom :: a -> Bool -- | Is the child safe free from brackets in the parent position. -- Err on the side of caution, True = don't know needBracket :: Int -> a -> a -> Bool instance Brackets Exp_ where remParen (Paren _ x) = Just x remParen _ = Nothing addParen = Paren an isAtom x = case x of Paren{} -> True Tuple{} -> True List{} -> True LeftSection{} -> True RightSection{} -> True TupleSection{} -> True RecConstr{} -> True ListComp{} -> True EnumFrom{} -> True EnumFromTo{} -> True EnumFromThen{} -> True EnumFromThenTo{} -> True _ -> 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 | Let{} <- parent, App{} <- child = False | ListComp{} <- parent = False | List{} <- parent = False | Tuple{} <- parent = False | If{} <- parent, isAnyApp child = False | App{} <- parent, i == 0, App{} <- child = False | ExpTypeSig{} <- parent, i == 0, isApp child = False | Paren{} <- parent = False | isDotApp parent, isDotApp child, i == 1 = False | RecConstr{} <- parent = False | RecUpdate{} <- parent, i /= 0 = False | Case{} <- parent, i /= 0 || isAnyApp child = False | Lambda{} <- parent, i == length (universeBi parent :: [Pat_]) - 1 = False -- watch out for PViewPat | Do{} <- parent = False | otherwise = True instance Brackets Type_ where remParen (TyParen _ x) = Just x remParen _ = Nothing addParen = TyParen an isAtom x = case x of TyParen{} -> True TyTuple{} -> True TyList{} -> True TyVar{} -> True TyCon{} -> True _ -> False needBracket i parent child | isAtom child = False | TyFun{} <- parent, i == 1, TyFun{} <- child = False | TyFun{} <- parent, TyApp{} <- child = False | TyTuple{} <- parent = False | TyList{} <- parent = False | TyInfix{} <- parent, TyApp{} <- child = False | TyParen{} <- parent = False | otherwise = True instance Brackets Pat_ where remParen (PParen _ x) = Just x remParen _ = Nothing addParen = PParen an isAtom x = case x of PParen{} -> True PTuple{} -> True PList{} -> True PVar{} -> True PApp _ _ [] -> True PWildCard{} -> True _ -> False needBracket i parent child | isAtom child = False | PTuple{} <- parent = False | PList{} <- parent = False | PInfixApp{} <- parent, PApp{} <- child = False | PParen{} <- parent = False | 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 -- | Descend, and if something changes then add/remove brackets appropriately descendBracket :: (Exp_ -> (Bool, Exp_)) -> Exp_ -> Exp_ 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 op = snd . g where g = f . descendBracket g f x = maybe (False,x) ((,) True) (op x) -- | 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 -> rebracket1 . App an x) hlint-1.8.53/src/HSE/All.hs0000644000000000000000000000702012220306165013362 0ustar0000000000000000 module HSE.All( module X, ParseFlags(..), parseFlags, parseFlagsNoLocations, parseFile, parseString, parseResult ) where import HSE.Util as X import HSE.Evaluate as X import HSE.Type as X import HSE.Bracket as X import HSE.Match as X import HSE.NameMatch as X import HSE.FreeVars as X import Util import CmdLine import Data.List import Data.Maybe import Language.Preprocessor.Cpphs import qualified Data.Map as Map data ParseFlags = ParseFlags {cppFlags :: CppFlags ,language :: [Extension] ,encoding :: Encoding ,infixes :: [Fixity] } parseFlags :: ParseFlags parseFlags = ParseFlags NoCpp defaultExtensions defaultEncoding [] parseFlagsNoLocations :: ParseFlags -> ParseFlags parseFlagsNoLocations x = x{cppFlags = case cppFlags x of Cpphs y -> Cpphs $ f y; y -> y} where f x = x{boolopts = (boolopts x){locations=False}} runCpp :: CppFlags -> FilePath -> String -> IO String runCpp NoCpp _ x = return x runCpp CppSimple _ x = return $ unlines [if "#" `isPrefixOf` ltrim x then "" else x | x <- lines x] runCpp (Cpphs o) file x = runCpphs o file x --------------------------------------------------------------------- -- PARSING -- | Parse a Haskell module parseString :: ParseFlags -> FilePath -> String -> IO (String, ParseResult Module_) parseString flags file str = do ppstr <- runCpp (cppFlags flags) file str return (ppstr, fmap (applyFixity fixity) $ parseFileContentsWithMode mode ppstr) where fixity = infixes flags ++ baseFixities mode = defaultParseMode {parseFilename = file ,extensions = language flags ,fixities = Nothing ,ignoreLinePragmas = False } parseFile :: ParseFlags -> FilePath -> IO (String, ParseResult Module_) parseFile flags file = do src <- readFileEncoding (encoding flags) file parseString flags file src -- throw an error if the parse is invalid parseResult :: IO (String, ParseResult Module_) -> IO Module_ parseResult x = do (_, res) <- x return $! fromParseResult res --------------------------------------------------------------------- -- FIXITIES -- resolve fixities later, so we don't ever get uncatchable ambiguity errors -- if there are fixity errors, try the cheapFixities (which never fails) applyFixity :: [Fixity] -> Module_ -> Module_ applyFixity base modu = descendBi f modu where f x = fromMaybe (cheapFixities fixs x) $ applyFixities fixs x :: Decl_ fixs = concatMap getFixity (moduleDecls modu) ++ base -- Apply fixities, but ignoring any ambiguous fixity errors and skipping qualified names, -- local infix declarations etc. Only use as a backup, if HSE gives an error. -- -- Inspired by the code at: -- http://hackage.haskell.org/trac/haskell-prime/attachment/wiki/FixityResolution/resolve.hs cheapFixities :: [Fixity] -> Decl_ -> Decl_ cheapFixities fixs = descendBi (transform f) where ask = askFixity fixs f o@(InfixApp s1 (InfixApp s2 x op1 y) op2 z) | p1 == p2 && (a1 /= a2 || a1 == AssocNone) = o -- Ambiguous infix expression! | p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone) = o | otherwise = InfixApp s1 x op1 (f $ InfixApp s1 y op2 z) where (a1,p1) = ask op1 (a2,p2) = ask op2 f x = x askFixity :: [Fixity] -> QOp S -> (Assoc, Int) askFixity xs = \k -> Map.findWithDefault (AssocLeft, 9) (fromNamed k) mp where mp = Map.fromList [(s,(a,p)) | Fixity a p x <- xs, let s = fromNamed x, s /= ""] hlint-1.8.53/src/Hint/0000755000000000000000000000000012220306165012602 5ustar0000000000000000hlint-1.8.53/src/Hint/Util.hs0000644000000000000000000000526612220306165014064 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns #-} module Hint.Util where import HSE.All import Util -- | 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 -- \ -> 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, vars op `disjoint` [x,y] = 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 -- \x -> (x +) ==> (+) niceLambda [x] (LeftSection _ (view -> Var_ x1) op) | x == x1 = opExp op -- 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 && length [() | UnQual _ a <- universeS z, prettyPrint a == x] <= 1 = transform f z where f (view -> Var_ x') | x == x' = paren y f x = x simplifyExp x = x hlint-1.8.53/src/Hint/Type.hs0000644000000000000000000000060312220306165014056 0ustar0000000000000000 module Hint.Type(module Hint.Type, module Idea, module HSE.All) where import HSE.All import Idea type DeclHint = Scope -> Module_ -> Decl_ -> [Idea] type ModuHint = Scope -> Module_ -> [Idea] type CrossHint = [(Scope, Module_)] -> [Idea] data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint} | CrossHint {crossHint :: CrossHint} hlint-1.8.53/src/Hint/Structure.hs0000644000000000000000000001211712220306165015140 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} {- Improve the structure of code yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e x `yes` y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e no x y = if a then b else c -- foo b | c <- f b = c -- foo (f -> c) = c -- foo x y b z | c:cs <- f g b = c -- foo x y (f g -> c:cs) z = c foo b | c <- f b = c + b foo b | c <- f b = c where f = here foo b | c <- f b = c where foo = b foo b | c <- f b = c \ | c <- f b = c foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e foo x | otherwise = y -- foo x = y -- FIXME: #358 foo x = x + x where -- foo x = x + x foo x | a = b | True = d -- foo x | a = b ; | otherwise = d foo (Bar _ _ _ _) = x -- Bar{} foo (Bar _ x _ _) = x foo (Bar _ _) = x foo = case f v of _ -> x -- x foo = case v of v -> x -- x foo = case v of z -> z foo = case v of _ | False -> x foo = case v of !True -> x -- True foo = case v of !(Just x) -> x -- (Just x) foo = case v of !(x : xs) -> x -- (x:xs) foo = case v of !1 -> x -- 1 foo = case v of !x -> x foo = let ~x = 1 in y -- x foo = let ~(x:xs) = y in z -} module Hint.Structure where import Hint.Type import Util structureHint :: DeclHint structureHint _ _ x = concatMap (uncurry hints . swap) (asPattern x) ++ concatMap patHint (universeBi x) ++ concatMap expHint (universeBi x) hints :: (String -> Pattern -> Idea) -> Pattern -> [Idea] hints gen (Pattern pat (UnGuardedRhs d bod) bind) | length guards > 2 = [gen "Use guards" $ Pattern pat (GuardedRhss d guards) bind] where guards = asGuards bod {- -- Do not suggest view patterns, they aren't something everyone likes sufficiently hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) bind) | Just i <- findIndex (=~= (toNamed p :: Pat_)) pats , p `notElem` (vars bod ++ vars bind) , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats = [gen "Use view patterns" $ Pattern (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) bind] where decsBind = nub $ concatMap declBind $ childrenBi bind -} hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind) | prettyPrint test `elem` ["otherwise","True"] = [gen "Redundant guard" $ Pattern pats (UnGuardedRhs an bod) bind] hints gen (Pattern pats bod (Just bind)) | f bind && False -- disabled due to bug 358 = [gen "Redundant where" $ Pattern pats bod Nothing] where f (BDecls _ x) = null x f (IPBinds _ x) = null x hints gen (Pattern pats (GuardedRhss _ (unsnoc -> (gs, GuardedRhs _ [test] bod))) bind) | prettyPrint test == "True" = [gen "Use otherwise" $ Pattern pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind] hints _ _ = [] asGuards :: Exp_ -> [GuardedRhs S] asGuards (Paren _ x) = asGuards x asGuards (If _ a b c) = GuardedRhs an [Qualifier an a] b : asGuards c asGuards x = [GuardedRhs an [Qualifier an $ toNamed "otherwise"] x] data Pattern = Pattern [Pat_] (Rhs S) (Maybe (Binds S)) -- Invariant: Number of patterns may not change asPattern :: Decl_ -> [(Pattern, String -> Pattern -> Idea)] asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x) where decl o@(PatBind a pat b rhs bind) = [(Pattern [pat] rhs bind, \msg (Pattern [pat] rhs bind) -> warn msg o $ PatBind a pat b rhs bind)] decl (FunBind _ xs) = map match xs decl _ = [] match o@(Match a b pat rhs bind) = (Pattern pat rhs bind, \msg (Pattern pat rhs bind) -> warn msg o $ Match a b pat rhs bind) match o@(InfixMatch a p b ps rhs bind) = (Pattern (p:ps) rhs bind, \msg (Pattern (p:ps) rhs bind) -> warn msg o $ InfixMatch a p b ps rhs bind) alt o@(Alt a pat rhs bind) = [(Pattern [pat] (fromGuardedAlts rhs) bind, \msg (Pattern [pat] rhs bind) -> warn msg o $ Alt a pat (toGuardedAlts rhs) bind)] -- Should these hints be in the same module? They are less structure, and more about pattern matching -- Or perhaps the entire module should be renamed Pattern, since it's all about patterns patHint :: Pat_ -> [Idea] patHint o@(PApp _ name args) | length args >= 3 && all isPWildCard args = [warn "Use record patterns" o $ PRec an name []] patHint o@(PBangPat _ x) | f x = [err "Redundant bang pattern" o x] where f (PParen _ x) = f x f (PAsPat _ _ x) = f x f PLit{} = True f PApp{} = True f PInfixApp{} = True f _ = False patHint o@(PIrrPat _ x) | f x = [err "Redundant irrefutable pattern" o x] where f (PParen _ x) = f x f (PAsPat _ _ x) = f x f PWildCard{} = True f PVar{} = True f _ = False patHint _ = [] expHint :: Exp_ -> [Idea] expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedAlt _ e) Nothing]) = [warn "Redundant case" o e] expHint o@(Case _ (Var _ x) [Alt _ (PVar _ y) (UnGuardedAlt _ e) Nothing]) | x =~= UnQual an y = [warn "Redundant case" o e] expHint _ = [] hlint-1.8.53/src/Hint/Pragma.hs0000644000000000000000000000505412220306165014351 0ustar0000000000000000{- Suggest better pragmas OPTIONS_GHC -cpp => LANGUAGE CPP OPTIONS_GHC -fglasgow-exts => LANGUAGE ... (in HSE) OPTIONS_GHC -XFoo => LANGUAGE Foo LANGUAGE A, A => LANGUAGE A -- do not do LANGUAGE A, LANGUAGE B to combine {-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS -cpp #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_YHC -cpp #-} {-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-} {-# OPTIONS_GHC -fglasgow-exts #-} -- ??? {-# LANGUAGE A, B, C, A #-} -- {-# LANGUAGE A, B, C #-} {-# LANGUAGE A #-} {-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} {-# OPTIONS_GHC -cpp #-} \ {-# LANGUAGE CPP, Text #-} -- {-# LANGUAGE A #-} \ {-# LANGUAGE B #-} {-# LANGUAGE A #-} \ {-# LANGUAGE B, A #-} -- {-# LANGUAGE A, B #-} -} module Hint.Pragma where import Hint.Type import Data.List import Data.Maybe import Util pragmaHint :: ModuHint pragmaHint _ x = languageDupes lang ++ [pragmaIdea old $ [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new | old /= []] where lang = [x | x@LanguagePragma{} <- modulePragmas x] (old,new,ns) = unzip3 [(old,new,ns) | old <- modulePragmas x, Just (new,ns) <- [optToLanguage old]] ns2 = nub (concat ns) \\ concat [map fromNamed n | LanguagePragma _ n <- lang] 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 :: [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, notNull $ intersect_ x y]) ++ languageDupes xs -- Given a pragma, can you extract some language features out strToLanguage :: String -> Maybe [String] strToLanguage "-cpp" = Just ["CPP"] strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x] strToLanguage "-fglasgow-exts" = Just $ map show glasgowExts strToLanguage _ = Nothing 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 strs = words val vs = map strToLanguage strs keep = concat $ zipWith (\v s -> [s | isNothing v]) vs strs res = if null keep then Nothing else Just $ OptionsPragma sl tool (unwords keep) optToLanguage _ = Nothing hlint-1.8.53/src/Hint/Naming.hs0000644000000000000000000000610612220306165014352 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {- Suggest the use of camelCase Only permit: _*[A-Za-z]*_*#*'* Apply this to things that would get exported by default only Also allow prop_ as it's a standard QuickCheck idiom Also allow case_ as it's a standard test-framework-th idiom Also don't suggest anything mentioned elsewhere in the module data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar data No = a :::: b data Yes = Foo {bar_cap :: Int} -- data Yes = Foo{barCap :: Int} data No = FOO | BarBAR | BarBBar yes_foo = yes_foo + yes_foo -- yesFoo = ... no = 1 where yes_foo = 2 a -== b = 1 myTest = 1; my_test = 1 semiring'laws = 1 -- semiringLaws = ... data Yes = FOO_A | Foo_B -- data Yes = FOO_A | FooB case_foo = 1 cast_foo = 1 -- castFoo = ... runMutator# = 1 -} module Hint.Naming(namingHint) where import Hint.Type import Data.List import Data.Char import Data.Maybe import Util import qualified Data.Set as Set namingHint :: DeclHint 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) | notNull res] where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen] x2 = shorten x shorten :: Decl_ -> Decl_ shorten x = case x of FunBind sl (Match a b c d _:_) -> FunBind sl [f (Match a b c) d] PatBind a b c d _ -> f (PatBind a b c) d x -> x where dots = Var an $ UnQual an $ Ident an "..." -- Must be an Ident, not a Symbol f cont (UnGuardedRhs _ _) = cont (UnGuardedRhs an dots) Nothing f cont (GuardedRhss _ _) = cont (GuardedRhss an [GuardedRhs an [Qualifier an dots] dots]) Nothing getNames :: Decl_ -> [String] getNames x = case x of FunBind{} -> name PatBind{} -> name TypeDecl{} -> name DataDecl _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x] GDataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ <- cons] TypeFamDecl{} -> name DataFamDecl{} -> name ClassDecl{} -> name _ -> [] where name = [fromNamed x] f (ConDecl _ x _) = [x] f (InfixConDecl _ _ x _) = [x] f (RecDecl _ x ys) = x : concat [y | FieldDecl _ y _ <- ys] suggestName :: String -> Maybe String suggestName x = listToMaybe [f x | not $ isSym x || good || not (any isLower x) || "prop_" `isPrefixOf` x || "case_" `isPrefixOf` x] where good = all isAlphaNum $ drp '_' $ drp '#' $ drp '\'' $ reverse $ drp '_' x drp x = dropWhile (== x) f xs = us ++ g ys where (us,ys) = span (== '_') xs g x | x `elem` ["_","'","_'"] = x g (a:x:xs) | a `elem` "_'" && isAlphaNum x = toUpper x : g xs g (x:xs) | isAlphaNum x = x : g xs | otherwise = g xs g [] = [] replaceNames :: Biplate a (Name S) => [(String,String)] -> a -> a replaceNames rep = descendBi f where f (Ident _ x) = Ident an $ fromMaybe x $ lookup x rep f x = x hlint-1.8.53/src/Hint/Monad.hs0000644000000000000000000000764712220306165014212 0ustar0000000000000000{-# LANGUAGE ViewPatterns, PatternGuards #-} {- Find and match: mapM, foldM, forM, replicateM, sequence, zipWithM not at the last line of a do statement, or to the left of >> Use let x = y instead of x <- return y, unless x is contained within y, or bound more than once in that do block. yes = do mapM print a; return b -- mapM_ print a no = mapM print a no = do foo ; mapM print a yes = do (bar+foo) -- (bar+foo) no = do bar ; foo yes = do bar; a <- foo; return a -- do bar; foo no = do bar; a <- foo; return b yes = do x <- bar; x -- do join bar no = do x <- bar; x; x no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook yes = do x <- return y; foo x -- @Warning do let x = y; foo x yes = do x <- return $ y + z; foo x -- do let x = y + z; foo x no = do x <- return x; foo x no = do x <- return y; x <- return y; foo x yes = do forM files $ \x -> return (); return () -- forM_ files $ \x -> return () yes = do if a then forM x y else sequence z q; return () -- if a then forM_ x y else sequence_ z q yes = do case a of {_ -> forM x y; x:xs -> forM x xs}; return () -- case a of _ -> forM_ x y ; x:xs -> forM_ x xs foldM_ f a xs = foldM f a xs >> return () folder f a xs = foldM f a xs >> return () -- foldM_ f a xs yes = mapM async ds >>= mapM wait >> return () -- mapM async ds >>= mapM_ wait -} module Hint.Monad where import Control.Arrow import Data.Maybe import Data.List import Hint.Type badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM"] monadHint :: DeclHint monadHint _ _ d = concatMap (monadExp d) $ universeBi d monadExp :: Decl_ -> Exp_ -> [Idea] monadExp decl x = case x of (view -> App2 op x1 x2) | op ~= ">>" -> f x1 Do _ xs -> [err "Redundant return" x y | Just y <- [monadReturn xs]] ++ [err "Use join" x (Do an y) | Just y <- [monadJoin xs]] ++ [err "Redundant do" x y | [Qualifier _ y] <- [xs]] ++ [warn "Use let" x (Do an y) | Just y <- [monadLet xs]] ++ concat [f x | Qualifier _ x <- init xs] _ -> [] where f x = [err ("Use " ++ name) x y | Just (name,y) <- [monadCall x], fromNamed decl /= name] -- see through Paren and down if/case etc -- return the name to use in the hint, and the revised expression monadCall :: Exp_ -> Maybe (String,Exp_) monadCall (Paren _ x) = fmap (second $ Paren an) $ monadCall x monadCall (App _ x y) = fmap (second $ \x -> App an x y) $ monadCall x monadCall (InfixApp _ x op y) | isDol op = fmap (second $ \x -> InfixApp an x op y) $ monadCall x | op ~= ">>=" = fmap (second $ \y -> InfixApp an x op y) $ monadCall y monadCall (replaceBranches -> (bs@(_:_), gen)) | all isJust res = Just (fst $ fromJust $ head res, gen $ map (snd . fromJust) res) where res = map monadCall bs monadCall x | x:_ <- filter (x ~=) badFuncs = let x2 = x ++ "_" in Just (x2, toNamed x2) monadCall _ = Nothing monadReturn (reverse -> Qualifier _ (App _ ret (Var _ v)):Generator _ (PVar _ p) x:rest) | ret ~= "return", fromNamed v == fromNamed p = Just $ Do an $ reverse $ Qualifier an x : rest monadReturn _ = Nothing monadJoin (Generator _ (view -> PVar_ p) x:Qualifier _ (view -> Var_ v):xs) | p == v && v `notElem` varss xs = Just $ Qualifier an (rebracket1 $ App an (toNamed "join") x) : fromMaybe xs (monadJoin xs) monadJoin (x:xs) = fmap (x:) $ monadJoin xs monadJoin [] = Nothing monadLet xs = if xs == ys then Nothing else Just ys where ys = map mkLet xs vs = concatMap pvars [p | Generator _ p _ <- xs] mkLet (Generator _ (view -> PVar_ p) (fromRet -> Just y)) | p `notElem` vars y, p `notElem` delete p vs = LetStmt an $ BDecls an [PatBind an (toNamed p) Nothing (UnGuardedRhs an y) Nothing] mkLet x = x fromRet (Paren _ x) = fromRet x fromRet (InfixApp _ x y z) | opExp y ~= "$" = fromRet $ App an x z fromRet (App _ x y) | x ~= "return" = Just y fromRet _ = Nothing hlint-1.8.53/src/Hint/Match.hs0000644000000000000000000002165712220306165014205 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns, RelaxedPolyRec, RecordWildCards #-} {- The matching does a fairly simple unification between the two terms, treating any single letter variable on the left as a free variable. After the matching we substitute, transform and check the side conditions. We also "see through" both ($) and (.) functions on the right. TRANSFORM PATTERNS _eval_ - perform deep evaluation, must be used at the top of a RHS _noParen_ - don't bracket this particular item SIDE CONDITIONS (&&), (||), not - boolean connectives isAtom x - does x never need brackets isFoo x - is the root constructor of x a "Foo" notEq x y - are x and y not equal notIn xs ys - are all x variables not in ys expressions notTypeSafe - no semantics, a hint for testing only ($) AND (.) We see through ($)/(.) by expanding it if nothing else matches. We also see through (.) by translating rules that have (.) equivalents to separate rules. For example: concat (map f x) ==> concatMap f x -- we spot both these rules can eta reduce with respect to x concat . map f ==> concatMap f -- we use the associativity of (.) to add concat . map f . x ==> concatMap f . x -- currently 36 of 169 rules have (.) equivalents -} module Hint.Match(readMatch) where import Data.List import Data.Maybe import Data.Data import Unsafe.Coerce import Settings import Hint.Type import Control.Monad import Control.Arrow import Util import qualified Data.Set as Set fmapAn = fmap (const an) --------------------------------------------------------------------- -- READ THE RULE readMatch :: [Setting] -> DeclHint readMatch settings = findIdeas (concatMap readRule settings) readRule :: Setting -> [Setting] readRule m@MatchExp{lhs=(fmapAn -> lhs), rhs=(fmapAn -> rhs), side=(fmap fmapAn -> side)} = (:) m{lhs=lhs,side=side,rhs=rhs} $ fromMaybe [] $ do (l,v1) <- dotVersion lhs (r,v2) <- dotVersion rhs guard $ v1 == v2 && l /= [] && r /= [] && Set.notMember v1 (freeVars $ maybeToList side ++ l ++ r) return [m{lhs=dotApps l, rhs=dotApps r, side=side} ,m{lhs=dotApps (l++[toNamed v1]), rhs=dotApps (r++[toNamed v1]), side=side}] readRule _ = [] -- find a dot version of this rule, return the sequence of app prefixes, and the var dotVersion :: Exp_ -> Maybe ([Exp_], String) dotVersion (view -> Var_ v) | isUnifyVar v = Just ([], v) dotVersion (fromApps -> xs) | length xs > 1 = fmap (first (apps (init xs) :)) $ dotVersion (fromParen $ last xs) dotVersion _ = Nothing --------------------------------------------------------------------- -- PERFORM THE MATCHING findIdeas :: [Setting] -> Scope -> Module S -> Decl_ -> [Idea] findIdeas matches s _ decl = [ (idea (severityS m) (hintS m) x y){note=notes} | decl <- case decl of InstDecl{} -> children decl; _ -> [decl] , (parent,x) <- universeParentExp decl, not $ isParen x, let x2 = fmapAn x , m <- matches, Just (y,notes) <- [matchIdea s decl m parent x2]] matchIdea :: Scope -> Decl_ -> Setting -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_,[Note]) matchIdea s decl MatchExp{..} parent x = do let nm = nameMatch scope s u <- unifyExp nm True lhs x u <- check u let e = subst u rhs let res = addBracket parent $ unqualify scope s u $ performEval e guard $ (freeVars e Set.\\ freeVars rhs) `Set.isSubsetOf` freeVars x -- check no unexpected new free variables guard $ checkSide side $ ("original",x) : ("result",res) : u guard $ checkDefine decl parent res return (res,notes) --------------------------------------------------------------------- -- UNIFICATION -- unify a b = c, a[c] = b unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe [(String,Exp_)] unify nm root x y | Just x <- cast x = unifyExp nm root x (unsafeCoerce y) | Just x <- cast x = unifyPat nm x (unsafeCoerce y) | otherwise = unifyDef nm x y unifyDef :: Data a => NameMatch -> a -> a -> Maybe [(String,Exp_)] unifyDef nm x y = fmap concat . sequence =<< gzip (unify nm False) x y -- App/InfixApp are analysed specially for performance reasons -- root = True, this is the outside of the expr -- do not expand out a dot at the root, since otherwise you get two matches because of readRule (Bug #570) unifyExp :: NameMatch -> Bool -> Exp_ -> Exp_ -> Maybe [(String,Exp_)] unifyExp nm root x y | isParen x || isParen y = unifyExp nm root (fromParen x) (fromParen y) unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] unifyExp nm root (Var _ (Qual _ (ModuleName _ [m]) x)) (Var _ y) | Qual _ (ModuleName _ m2) y <- y, y == x = Just [([m], Var an $ UnQual an $ Ident an m2)] | UnQual _ y <- y, y == x = Just [([m], Var an $ UnQual an $ Ident an "")] unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just [] unifyExp nm root x@(App _ x1 x2) (App _ y1 y2) = liftM2 (++) (unifyExp nm False x1 y1) (unifyExp nm False x2 y2) `mplus` (do guard $ not root; InfixApp _ y11 dot y12 <- return $ fromParen y1; guard $ isDot dot; unifyExp nm root x (App an y11 (App an y12 y2))) unifyExp nm root x (InfixApp _ lhs2 op2 rhs2) | InfixApp _ lhs1 op1 rhs1 <- x = guard (op1 == op2) >> liftM2 (++) (unifyExp nm False lhs1 lhs2) (unifyExp nm False rhs1 rhs2) | isDol op2 = unifyExp nm root x $ App an lhs2 rhs2 | otherwise = unifyExp nm root x $ App an (App an (opExp op2) lhs2) rhs2 unifyExp nm root x y | isOther x, isOther y = unifyDef nm x y unifyExp nm root _ _ = Nothing unifyPat :: NameMatch -> Pat_ -> Pat_ -> Maybe [(String,Exp_)] unifyPat nm (PVar _ x) (PVar _ y) = Just [(fromNamed x, toNamed $ fromNamed y)] unifyPat nm (PVar _ x) PWildCard{} = Just [(fromNamed x, toNamed $ "_" ++ fromNamed x)] unifyPat nm x y = unifyDef nm x y -- types that are not already handled in unify {-# INLINE isOther #-} isOther Var{} = False isOther App{} = False isOther InfixApp{} = False isOther _ = True --------------------------------------------------------------------- -- SUBSTITUTION UTILITIES -- check the unification is valid check :: [(String,Exp_)] -> Maybe [(String,Exp_)] check = mapM f . groupSortFst where f (x,ys) = if length (nub ys) == 1 then Just (x,head ys) else Nothing -- perform a substitution subst :: [(String,Exp_)] -> Exp_ -> Exp_ subst bind = transform g . transformBracket f where f (Var _ (fromNamed -> x)) | isUnifyVar x = lookup x bind f _ = Nothing g (App _ np x) | np ~= "_noParen_" = fromParen x g x = x --------------------------------------------------------------------- -- SIDE CONDITIONS checkSide :: Maybe Exp_ -> [(String,Exp_)] -> Bool checkSide x bind = maybe True f x where f (InfixApp _ x op y) | opExp op ~= "&&" = f x && f y | opExp op ~= "||" = f x || f y f (App _ x y) | x ~= "not" = not $ f y f (Paren _ x) = f x f (App _ cond (sub -> y)) | 'i':'s':typ <- fromNamed cond = isType typ y f (App _ (App _ cond (sub -> x)) (sub -> y)) | cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y] | cond ~= "notEq" = x /= y f x | x ~= "notTypeSafe" = True f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x isType "Atom" x = isAtom x isType "WHNF" x = isWHNF x isType "Nat" (asInt -> Just x) | x >= 0 = True isType "Pos" (asInt -> Just x) | x > 0 = True isType "Neg" (asInt -> Just x) | x < 0 = True isType "NegZero" (asInt -> Just x) | x <= 0 = True isType ('L':'i':'t':typ@(_:_)) (Lit _ x) = head (words $ show x) == typ isType typ x = head (words $ show x) == typ asInt :: Exp_ -> Maybe Integer asInt (Paren _ x) = asInt x asInt (NegApp _ x) = fmap negate $ asInt x asInt (Lit _ (Int _ x _)) = Just x asInt _ = Nothing list :: Exp_ -> [Exp_] list (List _ xs) = xs list x = [x] sub :: Exp_ -> Exp_ sub = transform f where f (view -> Var_ x) | Just y <- lookup x bind = y f x = x -- does the result look very much like the declaration checkDefine :: Decl_ -> Maybe (Int, Exp_) -> Exp_ -> Bool checkDefine x Nothing y = fromNamed x /= fromNamed (transformBi unqual $ head $ fromApps y) checkDefine _ _ _ = True --------------------------------------------------------------------- -- TRANSFORMATION -- if it has _eval_ do evaluation on it performEval :: Exp_ -> Exp_ performEval (App _ e x) | e ~= "_eval_" = evaluate x performEval x = x -- contract Data.List.foo ==> foo, if Data.List is loaded -- change X.foo => Module.foo, where X is looked up in the subst unqualify :: Scope -> Scope -> [(String,Exp_)] -> Exp_ -> Exp_ unqualify from to subs = transformBi f where f (Qual _ (ModuleName _ [m]) x) | Just y <- fmap fromNamed $ lookup [m] subs = if null y then UnQual an x else Qual an (ModuleName an y) x f x = nameQualify from to x addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_ addBracket (Just (i,p)) c | needBracket i p c = Paren an c addBracket _ x = x hlint-1.8.53/src/Hint/ListRec.hs0000644000000000000000000001324712220306165014512 0ustar0000000000000000{-# LANGUAGE PatternGuards, ViewPatterns #-} {- map f [] = [] map f (x:xs) = f x : map f xs foldr f z [] = z foldr f z (x:xs) = f x (foldr f z xs) foldl f z [] = z foldl f z (x:xs) = foldl f (f z x) xs -} {- f (x:xs) = negate x + f xs ; f [] = 0 -- f xs = foldr ((+) . negate) 0 xs f (x:xs) = x + 1 : f xs ; f [] = [] -- f xs = map (+ 1) xs 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 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 Hint.Type import Util import Hint.Util import Data.List import Data.Maybe import Data.Ord import Data.Either import Control.Monad listRecHint :: DeclHint listRecHint _ _ = concatMap f . universe where f o = maybeToList $ do let x = o (x, addCase) <- findCase x (use,severity,x) <- matchListRec x let y = addCase x guard $ recursiveStr `notElem` varss y return $ idea severity ("Use " ++ use) o y recursiveStr = "_recursive_" recursive = toNamed recursiveStr -- recursion parameters, nil-case, (x,xs,cons-case) -- for cons-case delete any recursive calls with xs from them -- any recursive calls are marked "_recursive_" data ListCase = ListCase [String] Exp_ (String,String,Exp_) deriving Show data BList = BNil | BCons String String deriving (Eq,Ord,Show) -- function name, parameters, list-position, list-type, body (unmodified) data Branch = Branch String [String] Int BList Exp_ deriving Show --------------------------------------------------------------------- -- MATCH THE RECURSION matchListRec :: ListCase -> Maybe (String,Severity,Exp_) matchListRec o@(ListCase vs nil (x,xs,cons)) | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":" , fromParen rhs =~= recursive, xs `notElem` vars lhs = Just $ (,,) "map" Error $ appsBracket [toNamed "map", niceLambda [x] lhs, toNamed xs] | [] <- vs, App2 op lhs rhs <- view cons , vars op `disjoint` [x,xs] , fromParen rhs == recursive, xs `notElem` vars lhs = Just $ (,,) "foldr" Warning $ appsBracket [toNamed "foldr", niceLambda [x] $ appsBracket [op,lhs], nil, toNamed xs] | [v] <- vs, view nil == Var_ v, App _ r lhs <- cons, r =~= recursive , xs `notElem` vars lhs = Just $ (,,) "foldl" Warning $ appsBracket [toNamed "foldl", niceLambda [v,x] lhs, toNamed v, toNamed xs] | [v] <- vs, App _ ret res <- nil, ret ~= "return", res ~= "()" || view res == Var_ v , [Generator _ (view -> PVar_ b1) e, Qualifier _ (fromParen -> App _ r (view -> Var_ b2))] <- asDo cons , b1 == b2, r == recursive, xs `notElem` vars e , name <- "foldM" ++ ['_'|res ~= "()"] = Just $ (,,) name Warning $ appsBracket [toNamed name, niceLambda [v,x] e, toNamed v, toNamed xs] | otherwise = Nothing -- Very limited attempt to convert >>= to do, only useful for foldM/foldM_ asDo :: Exp_ -> [Stmt S] asDo (view -> App2 bind lhs (Lambda _ [v] rhs)) = [Generator an v lhs, Qualifier an rhs] asDo (Do _ x) = x asDo x = [Qualifier an x] --------------------------------------------------------------------- -- FIND THE CASE ANALYSIS findCase :: Decl_ -> Maybe (ListCase, Exp_ -> Decl_) findCase x = do FunBind _ [x1,x2] <- return x Branch name1 ps1 p1 c1 b1 <- findBranch x1 Branch name2 ps2 p2 c2 b2 <- findBranch x2 guard (name1 == name2 && ps1 == ps2 && p1 == p2) [(BNil, b1), (BCons x xs, b2)] <- return $ sortBy (comparing fst) [(c1,b1), (c2,b2)] b2 <- transformAppsM (delCons name1 p1 xs) b2 (ps,b2) <- return $ eliminateArgs ps1 b2 let ps12 = let (a,b) = splitAt p1 ps1 in map toNamed $ a ++ xs : b return (ListCase ps b1 (x,xs,b2) ,\e -> FunBind an [Match an (toNamed name1) ps12 (UnGuardedRhs an e) Nothing]) delCons :: String -> Int -> String -> Exp_ -> Maybe Exp_ delCons func pos var (fromApps -> (view -> Var_ x):xs) | func == x = do (pre, (view -> Var_ v):post) <- return $ splitAt pos xs guard $ v == var return $ apps $ recursive : pre ++ post delCons _ _ _ x = return x eliminateArgs :: [String] -> Exp_ -> ([String], Exp_) eliminateArgs ps cons = (remove ps, transform f cons) where args = [zs | z:zs <- map fromApps $ universeApps cons, z =~= recursive] elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i,p) <- zip [0..] ps] ++ repeat False remove = concat . zipWith (\b x -> [x | not b]) elim f (fromApps -> x:xs) | x == recursive = apps $ x : remove xs f x = x --------------------------------------------------------------------- -- FIND A BRANCH findBranch :: Match S -> Maybe Branch findBranch x = do Match _ name ps (UnGuardedRhs _ bod) Nothing <- return x (a,b,c) <- findPat ps return $ Branch (fromNamed name) a b c $ simplifyExp bod findPat :: [Pat_] -> Maybe ([String], Int, BList) findPat ps = do ps <- mapM readPat ps [i] <- return $ findIndices isRight_ ps let (left,[right]) = partitionEithers ps return (left, i, right) readPat :: Pat_ -> Maybe (Either String BList) readPat (view -> PVar_ x) = Just $ Left x readPat (PParen _ (PInfixApp _ (view -> PVar_ x) (Special _ Cons{}) (view -> PVar_ xs))) = Just $ Right $ BCons x xs readPat (PList _ []) = Just $ Right BNil readPat _ = Nothing hlint-1.8.53/src/Hint/List.hs0000644000000000000000000000463712220306165014063 0ustar0000000000000000{-# LANGUAGE ViewPatterns, PatternGuards #-} {- Find and match: yes = 1:2:[] -- [1,2] yes = ['h','e','l','l','o'] -- "hello" -- [a]++b -> a : b, but only if not in a chain of ++'s yes = [x] ++ xs -- x : xs yes = "x" ++ xs -- 'x' : xs no = [x] ++ xs ++ ys no = xs ++ [x] ++ ys yes = [if a then b else c] ++ xs -- (if a then b else c) : xs 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 yes = y :: [Char] -> a -- String -> a instance C [Char] foo = [a b] ++ xs -- a b : xs -} module Hint.List where import Hint.Type listHint :: DeclHint listHint _ _ = listDecl listDecl :: Decl_ -> [Idea] listDecl x = concatMap (listExp False) (childrenBi x) ++ stringType x -- boolean = are you in a ++ chain listExp :: Bool -> Exp_ -> [Idea] 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]] isAppend (view -> App2 op _ _) = op ~= "++" isAppend _ = False checks = let (*) = (,) in ["Use string literal" * useString ,"Use list literal" * useList ,"Use :" * useCons ] useString b (List _ xs) | xs /= [] && all isChar xs = Just $ Lit an $ String an s (show s) where s = map fromChar xs useString b _ = Nothing useList b = fmap (List an) . f True where f first x | x ~= "[]" = if first then Nothing else Just [] f first (view -> App2 c a b) | c ~= ":" = fmap (a:) $ f False b f first _ = Nothing useCons False (view -> App2 op x y) | op ~= "++", Just x2 <- f x, not $ isAppend y = Just $ InfixApp an x2 (QConOp an $ list_cons_name an) y where f (Lit _ (String _ [x] _)) = Just $ Lit an $ Char an x (show x) f (List _ [x]) = Just $ if isApp x then x else paren x f _ = Nothing useCons _ _ = Nothing typeListChar = TyList an (TyCon an (toNamed "Char")) typeString = TyCon an (toNamed "String") stringType :: Decl_ -> [Idea] stringType x = case x of InstDecl _ _ _ x -> f x _ -> f x where f x = concatMap g $ childrenBi x g :: Type_ -> [Idea] g (fromTyParen -> x) = [warn "Use String" x (transform f x) | any (=~= typeListChar) $ universe x] where f x = if x =~= typeListChar then typeString else x hlint-1.8.53/src/Hint/Lambda.hs0000644000000000000000000001054312220306165014321 0ustar0000000000000000{-# LANGUAGE ViewPatterns, PatternGuards #-} {- Concept: Remove all the lambdas you can be inserting only sections Never create a right section with +-# as the operator (they are misparsed) Rules: fun a = \x -> y -- promote lambdas, provided no where's outside the lambda fun x = y x -- eta reduce, x /= mr and foo /= symbol \x -> y x -- eta reduce ((#) x) ==> (x #) -- rotate operators (flip op x) ==> (`op` x) -- rotate operators \x y -> x + y ==> (+) -- insert operator \x y -> op y x ==> flip op \x -> x + y ==> (+ y) -- insert section, \x -> op x y ==> (`op` y) -- insert section \x -> y + x ==> (y +) -- insert section \x -> \y -> ... ==> \x y -- lambda compression \x -> (x +) ==> (+) -- operator reduction f a = \x -> x + x -- f a x = x + x f a = \a -> a + a -- f _ a = a + a f a = \x -> x + x where _ = test f = \x -> x + x -- f x = x + x fun x y z = f x y z -- fun = f fun x y z = f x x y z -- fun x = f x x fun x y z = f g z -- fun x y = f g fun mr = y mr f = foo ((*) x) -- (x *) f = (*) x f = foo (flip op x) -- (`op` x) f = flip op x f = foo (flip (*) x) -- (* x) f = foo (flip (-) x) f = foo (\x y -> fun x y) -- @Error fun f = foo (\x y -> x + y) -- (+) f = foo (\x -> x * y) -- @Warning (* y) f = foo (\x -> x # y) f = foo (\x -> \y -> x x y y) -- \x y -> x x y y f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z 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 where -- a yes = \x y -> op y x where -- flip op f = \y -> nub $ reverse y where -- nub . reverse f = \z -> foo $ bar $ baz z where -- foo . bar . baz f = \z -> foo $ bar x $ baz z where -- foo . bar x . baz f = \z -> foo $ z $ baz z where f = \x -> bar map (filter x) where -- bar map . filter f = bar &+& \x -> f (g x) foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] foo = [\x -> x] foo = [\m x -> insert x x m] foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) foo a b c = bar (flux ++ quux) c where flux = c yes = foo (\x -> Just x) -- @Error Just foo = bar (\x -> (x `f`)) -- f baz = bar (\x -> (x +)) -- (+) -} module Hint.Lambda where import Hint.Util import Hint.Type import Util import Data.Maybe lambdaHint :: DeclHint lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeParentBi x) ++ concatMap lambdaDecl (universe x) lambdaDecl :: Decl_ -> [Idea] lambdaDecl (toFunBind -> o@(FunBind loc [Match _ name pats (UnGuardedRhs _ bod) bind])) | isNothing bind, isLambda $ fromParen bod = [err "Redundant lambda" o $ uncurry reform $ fromLambda $ Lambda an pats bod] | (pats2,bod2) <- etaReduce pats bod, length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind = [err "Eta reduce" (reform pats bod) (reform pats2 bod2)] where reform p b = FunBind loc [Match an name p (UnGuardedRhs an b) Nothing] lambdaDecl _ = [] etaReduce :: [Pat_] -> Exp_ -> ([Pat_], Exp_) etaReduce ps (App _ x (Var _ (UnQual _ (Ident _ y)))) | ps /= [], PVar _ (Ident _ p) <- last ps, p == y, p /= "mr", y `notElem` vars x = etaReduce (init ps) x etaReduce ps x = (ps,x) lambdaExp :: Maybe Exp_ -> Exp_ -> [Idea] lambdaExp p o@(Paren _ (App _ (Var _ (UnQual _ (Symbol _ x))) y)) | isAtom y, allowLeftSection x = [warn "Use section" o $ LeftSection an y (toNamed x)] lambdaExp p o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ x)) y)) | allowRightSection $ fromNamed x = [warn "Use section" o $ RightSection an (QVarOp an x) y] lambdaExp p o@Lambda{} | maybe True (not . isInfixApp) p, res <- niceLambda [] o, not $ isLambda res = [(if isVar res || isCon res then err else warn) "Avoid lambda" o res] lambdaExp p o@(Lambda _ _ x) | isLambda (fromParen x) && maybe True (not . isLambda) p = [warn "Collapse lambdas" o $ uncurry (Lambda an) $ fromLambda o] lambdaExp _ _ = [] -- replace any repeated pattern variable with _ fromLambda :: Exp_ -> ([Pat_], Exp_) fromLambda (Lambda _ ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x) where f bad x@PVar{} | prettyPrint x `elem` bad = PWildCard an f bad x = x fromLambda x = ([], x) hlint-1.8.53/src/Hint/Import.hs0000644000000000000000000001375412220306165014422 0ustar0000000000000000{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-} {- Reduce the number of import declarations. Two import declarations can be combined if: (note, A[] is A with whatever import list, or none) import A[]; import A[] = import A[] import A(B); import A(C) = import A(B,C) import A; import A(C) = import A import A; import A hiding (C) = import A import A[]; import A[] as Y = import A[] as Y import A; import A -- import A import A; import A; import A -- import A import A(Foo) ; import A -- import A import A(Bar(..)); import {-# SOURCE #-} A import A; import B import A(B) ; import A(C) -- import A(B,C) import A; import A hiding (C) -- import A import A; import A as Y -- import A as Y import A; import qualified A as Y import A as B; import A as C import A as A -- import A import qualified A as A -- import qualified A import A; import B; import A -- import A import qualified A; import A import B; import A; import A -- import A import A hiding(Foo); import A hiding(Bar) import List -- import Data.List import qualified List -- import qualified Data.List as List import Char(foo) -- import Data.Char(foo) import IO(foo) import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception as X (bracket,bracket_) module Foo(module A, baz, module B, module C) where; import A; import D; import B(map,filter); import C \ -- module Foo(baz, module X) where; import A as X; import B as X(map, filter); import C as X module Foo(module A, baz, module B, module X) where; import A; import B; import X \ -- module Foo(baz, module Y) where; import A as Y; import B as Y; import X as Y -} module Hint.Import where import Hint.Type import Util import Data.List import Data.Maybe importHint :: ModuHint importHint _ x = concatMap (wrap . snd) (groupSortFst [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++ concatMap (\x -> hierarchy x ++ reduce1 x) (universeBi x) ++ multiExport x wrap :: [ImportDecl S] -> [Idea] wrap o = [ rawIdea Error "Use fewer imports" (toSrcLoc $ ann $ head o) (f o) (f x) [] | Just x <- [simplify o]] where f = unlines . map prettyPrint simplify :: [ImportDecl S] -> Maybe [ImportDecl S] simplify [] = Nothing simplify (x:xs) = case simplifyHead x xs of Nothing -> fmap (x:) $ simplify xs Just xs -> Just $ fromMaybe xs $ simplify xs simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe [ImportDecl S] simplifyHead x [] = Nothing simplifyHead x (y:ys) = case reduce x y of Nothing -> fmap (y:) $ simplifyHead x ys Just xy -> Just $ xy : ys reduce :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S) reduce x y | qual, as, specs = Just x | qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y = Just x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys} | qual, as, isNothing (importSpecs x) || isNothing (importSpecs y) = Just x{importSpecs=Nothing} | not (importQualified x), qual, specs, length ass == 1 = Just x{importAs=Just $ head ass} where qual = importQualified x == importQualified y as = importAs x `eqMaybe` importAs y ass = mapMaybe importAs [x,y] specs = importSpecs x `eqMaybe` importSpecs y reduce _ _ = Nothing reduce1 :: ImportDecl S -> [Idea] reduce1 i@ImportDecl{..} | Just (dropAnn importModule) == fmap dropAnn importAs = [warn "Redundant as" i i{importAs=Nothing}] reduce1 _ = [] newNames = let (*) = flip (,) in ["Control" * "Monad" ,"Data" * "Char" ,"Data" * "List" ,"Data" * "Maybe" ,"Data" * "Ratio" ,"System" * "Directory" -- Special, see bug #393 -- ,"System" * "IO" -- Do not encourage use of old-locale/old-time over haskell98 -- ,"System" * "Locale" -- ,"System" * "Time" ] hierarchy :: ImportDecl S -> [Idea] hierarchy i@ImportDecl{importModule=ModuleName _ x,importPkg=Nothing} | Just y <- lookup x newNames = [warn "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an $ y ++ "." ++ x}] -- import IO is equivalent to -- import System.IO, import System.IO.Error, import Control.Exception(bracket, bracket_) hierarchy i@ImportDecl{importModule=ModuleName _ "IO", importSpecs=Nothing,importPkg=Nothing} = [rawIdea Warning "Use hierarchical imports" (toSrcLoc $ ann i) (ltrim $ prettyPrint i) ( unlines $ map (ltrim . prettyPrint) [f "System.IO" Nothing, f "System.IO.Error" Nothing ,f "Control.Exception" $ Just $ ImportSpecList an False [IVar an $ toNamed x | x <- ["bracket","bracket_"]]]) []] where f a b = (desugarQual i){importModule=ModuleName an a, importSpecs=b} hierarchy _ = [] -- import qualified X ==> import qualified X as X desugarQual :: ImportDecl S -> ImportDecl S desugarQual x | importQualified x && isNothing (importAs x) = x{importAs=Just (importModule x)} | otherwise = x multiExport :: Module S -> [Idea] multiExport x = [ rawIdea Warning "Use import/export shortcut" (toSrcLoc $ ann hd) (unlines $ prettyPrint hd : map prettyPrint imps) (unlines $ prettyPrint newhd : map prettyPrint newimps) [] | Module l (Just hd) _ imp _ <- [x] , let asNames = mapMaybe importAs imp , let expNames = [x | EModuleContents _ x <- childrenBi hd] , let imps = [i | i@ImportDecl{importAs=Nothing,importQualified=False,importModule=name} <- imp ,name `notElem_` asNames, name `elem_` expNames] , length imps >= 3 , let newname = ModuleName an $ head $ map return ("XYZ" ++ ['A'..]) \\ [x | ModuleName (_ :: S) x <- universeBi hd ++ universeBi imp] , let reexport (EModuleContents _ x) = x `notElem_` map importModule imps reexport x = True , let newhd = descendBi (\xs -> filter reexport xs ++ [EModuleContents an newname]) hd , let newimps = [i{importAs=Just newname} | i <- imps] ] hlint-1.8.53/src/Hint/Extensions.hs0000644000000000000000000001544512220306165015306 0ustar0000000000000000{- Suggest removal of unnecessary extensions i.e. They have {-# LANGUAGE RecursiveDo #-} but no mdo keywords {-# LANGUAGE Arrows #-} \ f = id -- {-# LANGUAGE TotallyUnknown #-} \ f = id {-# LANGUAGE Foo, Generics, ParallelListComp, ImplicitParams #-} \ f = [(a,c) | a <- b | c <- d] -- {-# LANGUAGE Foo, ParallelListComp #-} {-# LANGUAGE EmptyDataDecls #-} \ data Foo {-# LANGUAGE TemplateHaskell #-} \ $(deriveNewtypes typeInfo) {-# LANGUAGE TemplateHaskell #-} \ main = foo ''Bar {-# LANGUAGE PatternGuards #-} \ test = case x of _ | y <- z -> w {-# LANGUAGE TemplateHaskell,EmptyDataDecls #-} \ $(fmap return $ dataD (return []) (mkName "Void") [] [] []) {-# LANGUAGE RecursiveDo #-} \ main = mdo x <- y; return y {-# LANGUAGE ImplicitParams, BangPatterns #-} \ sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] \ sort !f = undefined {-# LANGUAGE KindSignatures #-} \ data Set (cxt :: * -> *) a = Set [a] {-# LANGUAGE RecordWildCards #-} \ record field = Record{..} {-# LANGUAGE RecordWildCards #-} \ record = 1 -- {-# LANGUAGE UnboxedTuples #-} \ record = 1 -- {-# LANGUAGE TemplateHaskell #-} \ foo {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ record = 1 -- {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ newtype Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ data Foo = Foo Int deriving Data -- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ newtype Foo = Foo Int deriving Class -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} \ data Foo = Foo Int deriving Class -- {-# LANGUAGE DeriveFunctor #-} \ data Foo = Foo Int deriving Functor {-# LANGUAGE DeriveFunctor #-} \ newtype Foo = Foo Int deriving Functor -- {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \ deriving instance Functor Bar {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, StandaloneDeriving #-} \ deriving instance Show Bar -- {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} \ newtype Micro = Micro Int deriving Generic -- {-# LANGUAGE DeriveGeneric #-} -} module Hint.Extensions where import Hint.Type import Data.Maybe import Data.List import Util extensionsHint :: ModuHint extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" (toSrcLoc sl) (prettyPrint o) (if null new then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) new) (warnings old new) | not $ used TemplateHaskell x -- if TH is on, can use all other extensions programmatically , o@(LanguagePragma sl exts) <- modulePragmas x , let old = map (parseExtension . prettyPrint) exts , let new = minimalExtensions x old , sort new /= sort old] minimalExtensions :: Module_ -> [Extension] -> [Extension] minimalExtensions x es = nub $ concatMap f es where f e = [e | usedExt e x] -- RecordWildCards implies DisambiguateRecordFields, but most people probably don't want it warnings old new | wildcards `elem` old && wildcards `notElem` new = [Note "you may need to add DisambiguateRecordFields"] where wildcards = EnableExtension RecordWildCards warnings _ _ = [] usedExt :: Extension -> Module_ -> Bool usedExt (UnknownExtension "DeriveGeneric") = hasDerive True ["Generic","Generic1"] usedExt (EnableExtension x) = used x usedExt _ = const True used :: KnownExtension -> Module_ -> Bool used RecursiveDo = hasS isMDo used ParallelListComp = hasS isParComp used FunctionalDependencies = hasT (un :: FunDep S) used ImplicitParams = hasT (un :: IPName S) used EmptyDataDecls = hasS f where f (DataDecl _ _ _ _ [] _) = True f (GDataDecl _ _ _ _ _ [] _) = True f _ = False used KindSignatures = hasT (un :: Kind S) used BangPatterns = hasS isPBangPat used TemplateHaskell = hasT2 (un :: (Bracket S, Splice S)) & hasS f & hasS isSpliceDecl where f VarQuote{} = True f TypQuote{} = True f _ = False used ForeignFunctionInterface = hasT (un :: CallConv S) used Generics = hasS isPExplTypeArg used PatternGuards = hasS f1 & hasS f2 where f1 (GuardedRhs _ xs _) = g xs f2 (GuardedAlt _ xs _) = g xs g [] = False g [Qualifier{}] = False g _ = True used StandaloneDeriving = hasS isDerivDecl used PatternSignatures = hasS isPatTypeSig used RecordWildCards = hasS isPFieldWildcard & hasS isFieldWildcard used RecordPuns = hasS isPFieldPun & hasS isFieldPun used UnboxedTuples = has isBoxed 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 = not . null . filter (`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 Arrows = hasS f where f Proc{} = True f LeftArrApp{} = True f RightArrApp{} = True f LeftArrHighApp{} = True f RightArrHighApp{} = True f _ = False used TransformListComp = hasS f where f QualStmt{} = False f _ = True -- for forwards compatibility, if things ever get added to the extension enumeration 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 where (new,dat) = derives m -- | What is derived on newtype, and on data type -- 'deriving' declarations may be on either, so we approximate derives :: Module_ -> ([String],[String]) derives = concatUnzip . map f . childrenBi where f :: Decl_ -> ([String], [String]) f (DataDecl _ dn _ _ _ ds) = g dn ds f (GDataDecl _ dn _ _ _ _ ds) = g dn ds f (DataInsDecl _ dn _ _ ds) = g dn ds f (GDataInsDecl _ dn _ _ _ ds) = g dn ds f (DerivDecl _ _ hd) = (xs, xs) -- don't know whether this was on newtype or not where xs = [h hd] f _ = ([], []) g dn ds = if isNewType dn then (xs,[]) else ([],xs) where xs = maybe [] (map h . fromDeriving) ds h (IHead _ a _) = prettyPrint $ unqual a h (IHInfix _ _ a _) = prettyPrint $ unqual a h (IHParen _ a) = h a un = undefined (&) f g x = f x || g x 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 hasS test = any test . universeBi has f = any f . universeBi hlint-1.8.53/src/Hint/Duplicate.hs0000644000000000000000000000513512220306165015054 0ustar0000000000000000{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} {- Find bindings within a let, and lists of statements If you have n the same, error out main = do a; a; a; a main = do a; a; a; a; a; a -- ??? main = do a; a; a; a; a; a; a -- ??? main = do (do b; a; a; a); do (do c; a; a; a) -- ??? main = do a; a; a; b; a; a; a -- ??? main = do a; a; a; b; a; a foo = a where {a = 1; b = 2; c = 3}; bar = a where {a = 1; b = 2; c = 3} -- ??? -} module Hint.Duplicate(duplicateHint) where import Hint.Type import Control.Arrow import Data.List hiding (find) import qualified Data.Map as Map duplicateHint :: CrossHint duplicateHint ms = dupes [y | Do _ y :: Exp S <- universeBi modu] ++ dupes [y | BDecls l y :: Binds S <- universeBi modu] where modu = map snd ms dupes ys = [rawIdea (if length xs >= 5 then Error else Warning) "Reduce duplication" p1 (unlines $ map (prettyPrint . fmap (const p1)) xs) ("Combine with " ++ showSrcLoc p2) [] | (p1,p2,xs) <- duplicateOrdered 3 $ map (map (toSrcLoc . ann &&& dropAnn)) ys] --------------------------------------------------------------------- -- DUPLICATE FINDING -- | The position to return if we match at this point, and the map of where to go next -- If two runs have the same vals, always use the first pos you find data Dupe pos val = Dupe pos (Map.Map val (Dupe pos val)) find :: Ord val => [val] -> Dupe pos val -> (pos, Int) find (v:vs) (Dupe p mp) | Just d <- Map.lookup v mp = second (+1) $ find vs d find _ (Dupe p mp) = (p, 0) add :: Ord val => pos -> [val] -> Dupe pos val -> Dupe pos val add pos [] d = d add pos (v:vs) (Dupe p mp) = Dupe p $ Map.insertWith f v (add pos vs $ Dupe pos Map.empty) mp where f new old = add pos vs old duplicateOrdered :: Ord val => Int -> [[(SrcLoc,val)]] -> [(SrcLoc,SrcLoc,[val])] duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe nullSrcLoc Map.empty) xs where f d xs = second overlaps $ mapAccumL (g pos) d $ takeWhile ((>= threshold) . length) $ tails xs where pos = Map.fromList $ zip (map fst xs) [0..] g pos d xs = (d2, res) where res = [(p,pme,take mx vs) | i >= threshold ,let mx = maybe i (\x -> min i $ (pos Map.! pme) - x) $ Map.lookup p pos ,mx >= threshold] vs = map snd xs (p,i) = find vs d pme = fst $ head xs d2 = add pme vs d overlaps (x@((_,_,n):_):xs) = x : overlaps (drop (length n - 1) xs) overlaps (x:xs) = x : overlaps xs overlaps [] = [] hlint-1.8.53/src/Hint/Bracket.hs0000644000000000000000000001004612220306165014512 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} {- Raise an error if you are bracketing an atom, or are enclosed be a list bracket -- expression bracket reduction yes = (f x) x -- @Warning f x x no = f (x x) yes = (foo) -- foo yes = (foo bar) -- @Warning foo bar yes = foo (bar) -- @Error bar yes = foo ((x x)) -- @Error (x x) yes = (f x) ||| y -- @Warning f x ||| y yes = if (f x) then y else z -- @Warning if f x then y else z yes = if x then (f y) else z -- @Warning if x then f y else z yes = (a foo) :: Int -- @Warning a foo :: Int yes = [(foo bar)] -- @Warning [foo bar] yes = foo ((x y), z) -- @Warning (x y, z) 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) main = do f; (print x) -- @Warning do f print x -- type bracket reduction foo :: (Int -> Int) -> Int foo :: Int -> (Int -> Int) -- @Warning Int -> Int -> Int foo :: (Maybe Int) -> a -- @Warning Maybe Int -> a instance Named (DeclHead S) data Foo = Foo {foo :: (Maybe Foo)} -- @Warning foo :: Maybe Foo -- pattern bracket reduction foo (True) = 1 foo ((True)) = 1 -- @Error True -- dollar reduction tests no = groupFsts . sortFst $ mr yes = split "to" $ names -- split "to" names yes = white $ keysymbol -- white keysymbol yes = operator foo $ operator -- operator foo operator no = operator foo $ operator bar yes = return $ Record{a=b} -- return Record{a=b} -- $/bracket rotation tests yes = (b $ c d) ++ e -- b (c d) ++ e yes = (a b $ c d) ++ e -- a b (c d) ++ e no = (f . g $ a) ++ e no = quickCheck ((\h -> cySucc h == succ h) :: Hygiene -> Bool) foo = (case x of y -> z; q -> w) :: Int -- backup fixity resolution main = do a += b . c; return $ a . b -- annotations main = 1; {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} main = 1; {-# ANN module (1 + (2)) #-} -- 2 -} module Hint.Bracket where import Hint.Type bracketHint :: DeclHint bracketHint _ _ x = concatMap (\x -> bracket True x ++ dollar x) (childrenBi (descendBi annotations x) :: [Exp_]) ++ concatMap (bracket False) (childrenBi x :: [Type_]) ++ concatMap (bracket False) (childrenBi x :: [Pat_]) ++ concatMap fieldDecl (childrenBi x) where -- Brackets at the roots of annotations are fine, so we strip them annotations :: Annotation S -> Annotation S annotations = descendBi $ \x -> case (x :: Exp_) of Paren _ x -> x x -> x bracket :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Bool -> a S -> [Idea] bracket bad = f Nothing where msg = "Redundant bracket" -- f (Maybe (index, parent, gen)) child f :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea] f Just{} o@(remParen -> Just x) | isAtom x = err msg o x : g x f Nothing o@(remParen -> Just x) | bad = warn msg o x : g x f (Just (i,o,gen)) (remParen -> Just x) | not $ needBracket i o x = warn msg o (gen x) : g x f _ x = g x g :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea] g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o] fieldDecl :: FieldDecl S -> [Idea] fieldDecl o@(FieldDecl a b (UnBangedTy c (TyParen _ d))) = [warn "Redundant bracket" o (FieldDecl a b (UnBangedTy c d))] fieldDecl _ = [] dollar :: Exp_ -> [Idea] dollar = concatMap f . universe where msg = warn "Redundant $" 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)) <- 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 splitInfix :: Exp_ -> [(Exp_ -> Exp_, Exp_)] splitInfix (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)] splitInfix _ = [] hlint-1.8.53/src/Hint/All.hs0000644000000000000000000000165112220306165013651 0ustar0000000000000000 module Hint.All( Hint(..), DeclHint, ModuHint, staticHints, dynamicHints ) where import Settings import Hint.Type import Hint.Match import Hint.List import Hint.ListRec import Hint.Monad import Hint.Lambda import Hint.Bracket import Hint.Naming import Hint.Structure import Hint.Import import Hint.Pragma import Hint.Extensions import Hint.Duplicate staticHints :: [(String,Hint)] staticHints = ["List" ! listHint ,"ListRec" ! listRecHint ,"Monad" ! monadHint ,"Lambda" ! lambdaHint ,"Bracket" ! bracketHint ,"Naming" ! namingHint ,"Structure" ! structureHint ,"Import" + importHint ,"Pragma" + pragmaHint ,"Extensions" + extensionsHint ,"Duplicate" * duplicateHint ] where x!y = (x,DeclHint y) x+y = (x,ModuHint y) x*y = (x,CrossHint y) dynamicHints :: [Setting] -> Hint dynamicHints = DeclHint . readMatch hlint-1.8.53/data/0000755000000000000000000000000012220306165012022 5ustar0000000000000000hlint-1.8.53/data/Test.hs0000644000000000000000000000417512220306165013304 0ustar0000000000000000-- These hints are for test purposes, and are not intended to -- be used for real. -- FIXME: Should make this module modules in one file, so can easily test lots of -- things without them overlapping module HLint.Test where import "hint" HLint.Builtin.Naming error = Prelude.readFile ==> bad error = (x :: Int) ==> (x :: Int32) where _ = notTypeSafe error "Test1" = scanr ==> scanr error "Test2" = filter ==> filter error "Test3" = foldr ==> foldr error "Test4" = foldl ==> foldl ignore "Test1" = "" ignore "Test3" ignore "Test2" = ignoreTest warn = ignoreTest3 ignore = Ignore_Test {-# ANN module "HLint: ignore Test4" #-} {-# ANN annTest2 "HLint: error" #-} {-# ANN annTest3 ("HLint: warn" :: String) #-} {-# ANN type Ann_Test ("HLint: ignore") #-} error = concat (map f x) ==> Data.List.concatMap f x infix 9 + error = a * (b+c) ==> undefined error = Array.head ==> head error = tail ==> Array.tail error = zip [1..length x] x ==> zipFrom 1 x {- main = readFile "foo" >>= putStr \ -- bad import Prelude hiding(readFile) \ import Data.ByteString.Char8(readFile) \ test = readFile "foo" >>= putStr import Prelude as Prelude2 \ yes = Prelude2.readFile "foo" >>= putStr \ -- bad yes = 32 :: Int -- 32 :: Int32 ignoreTest = filter -- @Ignore ??? ignoreTest2 = filter -- @Error ??? ignoreTest3 = filter -- @Warning ??? ignoreAny = scanr -- @Ignore ??? ignoreNew = foldr -- @Ignore ??? type Ignore_Test = Int -- @Ignore ??? annTest = foldl -- @Ignore ??? annTest2 = foldl -- @Error ??? annTest3 = scanr -- @Warning ??? type Ann_Test = Int -- @Ignore ??? concatMap f x = concat (map f x) concatMop f x = concat (map f x) -- Data.List.concatMap f x yes = 1 * 2+3 -- undefined import Foo; test = Foo.id 1 test = head import Array; test = Array.head -- head test = Array.head -- head test = head import qualified Array; test = head import Array(tail); test = head import Array(head); test = head -- head import Array as A; test = A.head -- head test = tail -- Array.tail import qualified Array as B; test = tail -- B.tail zip [1..length x] zip [1..length x] x -- zipFrom 1 x -} hlint-1.8.53/data/report_template.html0000644000000000000000000000656712220306165016134 0ustar0000000000000000 HLint Report

    All hints

      $HINTS

    All files

      $FILES

    Report generated by HLint $VERSION - a tool to suggest improvements to your Haskell code.

    $CONTENT
    hlint-1.8.53/data/hs-lint.el0000644000000000000000000000762312220306165013732 0ustar0000000000000000;;; hs-lint.el --- minor mode for HLint code checking ;; Copyright 2009 (C) Alex Ott ;; ;; Author: Alex Ott ;; Keywords: haskell, lint, HLint ;; Requirements: ;; Status: distributed under terms of GPL2 or above ;; Typical message from HLint looks like: ;; ;; /Users/ott/projects/lang-exp/haskell/test.hs:52:1: Eta reduce ;; Found: ;; count1 p l = length (filter p l) ;; Why not: ;; count1 p = length . filter p (require 'compile) (defgroup hs-lint nil "Run HLint as inferior of Emacs, parse error messages." :group 'tools :group 'haskell) (defcustom hs-lint-command "hlint" "The default hs-lint command for \\[hlint]." :type 'string :group 'hs-lint) (defcustom hs-lint-save-files t "Save modified files when run HLint or no (ask user)" :type 'boolean :group 'hs-lint) (defcustom hs-lint-replace-with-suggestions nil "Replace user's code with suggested replacements" :type 'boolean :group 'hs-lint) (defcustom hs-lint-replace-without-ask nil "Replace user's code with suggested replacements automatically" :type 'boolean :group 'hs-lint) (defun hs-lint-process-setup () "Setup compilation variables and buffer for `hlint'." (run-hooks 'hs-lint-setup-hook)) ;; regex for replace suggestions ;; ;; ^\(.*?\):\([0-9]+\):\([0-9]+\): .* ;; Found: ;; \s +\(.*\) ;; Why not: ;; \s +\(.*\) (defvar hs-lint-regex "^\\(.*?\\):\\([0-9]+\\):\\([0-9]+\\): .*[\n\C-m]Found:[\n\C-m]\\s +\\(.*\\)[\n\C-m]Why not:[\n\C-m]\\s +\\(.*\\)[\n\C-m]" "Regex for HLint messages") (defun make-short-string (str maxlen) (if (< (length str) maxlen) str (concat (substring str 0 (- maxlen 3)) "..."))) (defun hs-lint-replace-suggestions () "Perform actual replacement of suggestions" (goto-char (point-min)) (while (re-search-forward hs-lint-regex nil t) (let* ((fname (match-string 1)) (fline (string-to-number (match-string 2))) (old-code (match-string 4)) (new-code (match-string 5)) (msg (concat "Replace '" (make-short-string old-code 30) "' with '" (make-short-string new-code 30) "'")) (bline 0) (eline 0) (spos 0) (new-old-code "")) (save-excursion (switch-to-buffer (get-file-buffer fname)) (goto-line fline) (beginning-of-line) (setf bline (point)) (when (or hs-lint-replace-without-ask (yes-or-no-p msg)) (end-of-line) (setf eline (point)) (beginning-of-line) (setf old-code (regexp-quote old-code)) (while (string-match "\\\\ " old-code spos) (setf new-old-code (concat new-old-code (substring old-code spos (match-beginning 0)) "\\ *")) (setf spos (match-end 0))) (setf new-old-code (concat new-old-code (substring old-code spos))) (remove-text-properties bline eline '(composition nil)) (when (re-search-forward new-old-code eline t) (replace-match new-code nil t))))))) (defun hs-lint-finish-hook (buf msg) "Function, that is executed at the end of HLint execution" (if hs-lint-replace-with-suggestions (hs-lint-replace-suggestions) (next-error 1 t))) (define-compilation-mode hs-lint-mode "HLint" "Mode for check Haskell source code." (set (make-local-variable 'compilation-process-setup-function) 'hs-lint-process-setup) (set (make-local-variable 'compilation-disable-input) t) (set (make-local-variable 'compilation-scroll-output) nil) (set (make-local-variable 'compilation-finish-functions) (list 'hs-lint-finish-hook)) ) (defun hs-lint () "Run HLint for current buffer with haskell source" (interactive) (save-some-buffers hs-lint-save-files) (compilation-start (concat hs-lint-command " \"" buffer-file-name "\"") 'hs-lint-mode)) (provide 'hs-lint) ;;; hs-lint.el ends here hlint-1.8.53/data/HLint.hs0000644000000000000000000000012712220306165013374 0ustar0000000000000000 module HLint.HLint where import "hint" HLint.Default import "hint" HLint.Builtin.All hlint-1.8.53/data/hlint.ghci0000644000000000000000000000243312220306165013776 0ustar0000000000000000-- -*- mode: haskell; -*- -- Begin copied material. -- :{ :def redir \varcmd -> return $ case break Data.Char.isSpace varcmd of (var,_:cmd) -> unlines [":set -fno-print-bind-result" ,"tmp <- System.Directory.getTemporaryDirectory" ,"(f,h) <- System.IO.openTempFile tmp \"ghci\"" ,"sto <- GHC.Handle.hDuplicate System.IO.stdout" ,"GHC.Handle.hDuplicateTo h System.IO.stdout" ,"System.IO.hClose h" ,cmd ,"GHC.Handle.hDuplicateTo sto System.IO.stdout" ,"let readFileNow f = readFile f >>= \\t->Data.List.length t `seq` return t" ,var++" <- readFileNow f" ,"System.Directory.removeFile f" ] _ -> "putStrLn \"usage: :redir \"" :} --- Integration with the hlint code style tool :{ :def hlint \extra -> return $ unlines [":unset +t +s" ,":set -w" ,":redir hlintvar1 :show modules" ,":cmd return $ \":! hlint \" ++ unwords (map (takeWhile (/=',') . drop 2 . dropWhile (/= '(')) $ lines hlintvar1) ++ \" \" ++ " ++ show extra ,":set +t +s -Wall" ] :} hlint-1.8.53/data/hlint.10000644000000000000000000000242512220306165013225 0ustar0000000000000000.TH HLINT "1" "July 2009" "HLint (C) Neil Mitchell 2006-2009" "User Commands" .SH NAME HLint \- haskell source code suggestions .SH SYNOPSIS .B hlint [\fIfiles/directories\fR] [\fIoptions\fR] .SH DESCRIPTION \fIHLint\fR is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. .SH OPTIONS .TP \fB\-?\fR \fB\-\-help\fR Display help message .TP \fB\-v\fR \fB\-\-version\fR Display version information .TP \fB\-r[file]\fR \fB\-\-report\fR[=\fIfile\fR] Generate a report in HTML .TP \fB\-h\fR \fIfile\fR \fB\-\-hint\fR=\fIfile\fR Hint/ignore file to use .TP \fB\-c\fR \fB\-\-color\fR, \fB\-\-colour\fR Color the output (requires ANSI terminal) .TP \fB\-i\fR \fImessage\fR \fB\-\-ignore\fR=\fImessage\fR Ignore a particular hint .TP \fB\-s\fR \fB\-\-show\fR Show all ignored ideas .TP \fB\-t\fR \fB\-\-test\fR Run in test mode .SH EXAMPLE "To check all Haskell files in 'src' and generate a report type:" .IP hlint src \fB\-\-report\fR .SH "SEE ALSO" The full documentation for .B HLint is available in \fI/usr/share/doc/hlint/hlint.html\fI. .SH AUTHOR This manual page was written by Joachim Breitner for the Debian system (but may be used by others). hlint-1.8.53/data/Generalise.hs0000644000000000000000000000027212220306165014435 0ustar0000000000000000 module HLint.Generalise where import Data.Monoid import Control.Monad warn = concatMap ==> (=<<) warn = liftM ==> fmap warn = map ==> fmap warn = a ++ b ==> a `Data.Monoid.mappend` b hlint-1.8.53/data/Dollar.hs0000644000000000000000000000022012220306165013565 0ustar0000000000000000 module HLint.Dollar where error = a $ b $ c ==> a . b $ c {- yes = concat $ concat $ map f x -- concat . concat $ map f x -} hlint-1.8.53/data/Default.hs0000644000000000000000000005740512220306165013755 0ustar0000000000000000 module HLint.Default where import Control.Arrow import Control.Exception import Control.Monad import Control.Monad.State import qualified Data.Foldable import Data.Foldable(asum, sequenceA_, traverse_, for_) import Data.Traversable(traverse, for) import Control.Applicative import Data.Function import Data.Int import Data.Char import Data.List as Data.List import Data.List as X import Data.Maybe import Data.Monoid import System.IO import Control.Concurrent.Chan import System.Mem.Weak import Control.Exception.Base import System.Exit import Data.Either import Numeric import IO as System.IO import List as Data.List import Maybe as Data.Maybe import Monad as Control.Monad import Char as Data.Char -- I/O error = putStrLn (show x) ==> print x error = mapM_ putChar ==> putStr error = hGetChar stdin ==> getChar error = hGetLine stdin ==> getLine error = hGetContents stdin ==> getContents error = hPutChar stdout ==> putChar error = hPutStr stdout ==> putStr error = hPutStrLn stdout ==> putStrLn error = hPrint stdout ==> print error = hWaitForInput a 0 ==> hReady a error = hPutStrLn a (show b) ==> hPrint a b error = hIsEOF stdin ==> isEOF -- EXIT error = exitWith ExitSuccess ==> exitSuccess -- ORD error = not (a == b) ==> a /= b where note = "incorrect if either value is NaN" error = not (a /= b) ==> a == b where note = "incorrect if either value is NaN" error = not (a > b) ==> a <= b where note = "incorrect if either value is NaN" error = not (a >= b) ==> a < b where note = "incorrect if either value is NaN" error = not (a < b) ==> a >= b where note = "incorrect if either value is NaN" error = not (a <= b) ==> a > b where note = "incorrect if either value is NaN" error = compare x y /= GT ==> x <= y error = compare x y == LT ==> x < y error = compare x y /= LT ==> x >= y error = compare x y == GT ==> x > y error = x == a || x == b || x == c ==> x `elem` [a,b,c] where note = ValidInstance "Eq" x error = x /= a && x /= b && x /= c ==> x `notElem` [a,b,c] where note = ValidInstance "Eq" x --error = compare (f x) (f y) ==> Data.Ord.comparing f x y -- not that great --error = on compare f ==> Data.Ord.comparing f -- not that great error = head (sort x) ==> minimum x error = last (sort x) ==> maximum x error = head (sortBy f x) ==> minimumBy f x error = last (sortBy f x) ==> maximumBy f x error "Avoid reverse" = reverse (sort x) ==> sortBy (flip compare) x error "Avoid reverse" = reverse (sortBy f x) ==> sortBy (flip f) x warn = flip (g `on` h) ==> flip g `on` h warn = (f `on` g) `on` h ==> f `on` (g . h) -- READ/SHOW error = showsPrec 0 x "" ==> show x error = readsPrec 0 ==> reads error = showsPrec 0 ==> shows warn = showIntAtBase 16 intToDigit ==> showHex warn = showIntAtBase 8 intToDigit ==> showOct -- LIST error = concat (map f x) ==> concatMap f x warn = concat [a, b] ==> a ++ b warn "Use map once" = map f (map g x) ==> map (f . g) x warn = x !! 0 ==> head x error = take n (repeat x) ==> replicate n x error = map f (replicate n x) ==> replicate n (f x) error = map f (repeat x) ==> repeat (f x) error = head (reverse x) ==> last x error = head (drop n x) ==> x !! n where _ = isNat n error = reverse (tail (reverse x)) ==> init x where note = IncreasesLaziness error "Avoid reverse" = reverse (reverse x) ==> x where note = IncreasesLaziness -- error = take (length x - 1) x ==> init x -- not true for x == [] error = isPrefixOf (reverse x) (reverse y) ==> isSuffixOf x y error = foldr (++) [] ==> concat error = foldl (++) [] ==> concat where note = IncreasesLaziness error = span (not . p) ==> break p error = break (not . p) ==> span p error = (takeWhile p x, dropWhile p x) ==> span p x error = fst (span p x) ==> takeWhile p x error = snd (span p x) ==> dropWhile p x error = fst (break p x) ==> takeWhile (not . p) x error = snd (break p x) ==> dropWhile (not . p) x error = concatMap (++ "\n") ==> unlines error = map id ==> id error = or (map p x) ==> any p x error = and (map p x) ==> all p x error = zipWith (,) ==> zip error = zipWith3 (,,) ==> zip3 warn = length x == 0 ==> null x where note = IncreasesLaziness warn = x == [] ==> null x warn "Use null" = length x /= 0 ==> not (null x) where note = IncreasesLaziness warn "Use :" = (\x -> [x]) ==> (:[]) error = map (uncurry f) (zip x y) ==> zipWith f x y warn = map f (zip x y) ==> zipWith (curry f) x y where _ = isVar f error = not (elem x y) ==> notElem x y warn = foldr f z (map g x) ==> foldr (f . g) z x error = x ++ concatMap (' ':) y ==> unwords (x:y) error = intercalate " " ==> unwords warn = concat (intersperse x y) ==> intercalate x y where _ = notEq x " " warn = concat (intersperse " " x) ==> unwords x error "Use any" = null (filter f x) ==> not (any f x) error "Use any" = filter f x == [] ==> not (any f x) error = filter f x /= [] ==> any f x error = any id ==> or error = all id ==> and error = any ((==) a) ==> elem a where note = ValidInstance "Eq" a error = any (== a) ==> elem a error = any (a ==) ==> elem a where note = ValidInstance "Eq" a error = all ((/=) a) ==> notElem a where note = ValidInstance "Eq" a error = all (/= a) ==> notElem a where note = ValidInstance "Eq" a error = all (a /=) ==> notElem a where note = ValidInstance "Eq" a error = elem True ==> or error = notElem False ==> and error = findIndex ((==) a) ==> elemIndex a error = findIndex (a ==) ==> elemIndex a error = findIndex (== a) ==> elemIndex a error = findIndices ((==) a) ==> elemIndices a error = findIndices (a ==) ==> elemIndices a error = findIndices (== a) ==> elemIndices a error = lookup b (zip l [0..]) ==> elemIndex b l warn "Length always non-negative" = length x >= 0 ==> True warn "Use null" = length x > 0 ==> not (null x) where note = IncreasesLaziness warn "Use null" = length x >= 1 ==> not (null x) where note = IncreasesLaziness error "Take on a non-positive" = take i x ==> [] where _ = isNegZero i error "Drop on a non-positive" = drop i x ==> x where _ = isNegZero i -- FOLDS error = foldr (>>) (return ()) ==> sequence_ error = foldr (&&) True ==> and error = foldl (&&) True ==> and where note = IncreasesLaziness error = foldr1 (&&) ==> and where note = RemovesError "on []" error = foldl1 (&&) ==> and where note = RemovesError "on []" error = foldr (||) False ==> or error = foldl (||) False ==> or where note = IncreasesLaziness error = foldr1 (||) ==> or where note = RemovesError "on []" error = foldl1 (||) ==> or where note = RemovesError "on []" error = foldl (+) 0 ==> sum error = foldr (+) 0 ==> sum error = foldl1 (+) ==> sum where note = RemovesError "on []" error = foldr1 (+) ==> sum where note = RemovesError "on []" error = foldl (*) 1 ==> product error = foldr (*) 1 ==> product error = foldl1 (*) ==> product where note = RemovesError "on []" error = foldr1 (*) ==> product where note = RemovesError "on []" error = foldl1 max ==> maximum error = foldr1 max ==> maximum error = foldl1 min ==> minimum error = foldr1 min ==> minimum error = foldr mplus mzero ==> msum -- FUNCTION error = (\x -> x) ==> id error = (\x y -> x) ==> const error = (\(x,y) -> y) ==> snd error = (\(x,y) -> x) ==> fst warn "Use curry" = (\x y -> f (x,y)) ==> curry f warn "Use uncurry" = (\(x,y) -> f x y) ==> uncurry f where note = IncreasesLaziness error "Redundant $" = (($) . f) ==> f error "Redundant $" = (f $) ==> f warn = (\x -> y) ==> const y where _ = isAtom y error "Redundant flip" = flip f x y ==> f y x where _ = isApp original warn = (\a b -> g (f a) (f b)) ==> g `Data.Function.on` f -- CHAR error = a >= 'a' && a <= 'z' ==> isAsciiLower a error = a >= 'A' && a <= 'Z' ==> isAsciiUpper a error = a >= '0' && a <= '9' ==> isDigit a error = a >= '0' && a <= '7' ==> isOctDigit a error = not (isControl a) ==> isPrint a error = isLower a || isUpper a ==> isAlpha a error = isAlpha a || isDigit a ==> isAlphaNum a -- BOOL error "Redundant ==" = x == True ==> x warn "Redundant ==" = x == False ==> not x error "Redundant ==" = True == a ==> a warn "Redundant ==" = False == a ==> not a error "Redundant /=" = a /= True ==> not a warn "Redundant /=" = a /= False ==> a error "Redundant /=" = True /= a ==> not a warn "Redundant /=" = False /= a ==> a error "Redundant if" = (if a then x else x) ==> x where note = IncreasesLaziness error "Redundant if" = (if a then True else False) ==> a error "Redundant if" = (if a then False else True) ==> not a error "Redundant if" = (if a then t else (if b then t else f)) ==> if a || b then t else f error "Redundant if" = (if a then (if b then t else f) else f) ==> if a && b then t else f error "Redundant if" = (if x then True else y) ==> x || y where _ = notEq y False error "Redundant if" = (if x then y else False) ==> x && y where _ = notEq y True warn "Use if" = case a of {True -> t; False -> f} ==> if a then t else f warn "Use if" = case a of {False -> f; True -> t} ==> if a then t else f warn "Use if" = case a of {True -> t; _ -> f} ==> if a then t else f warn "Use if" = case a of {False -> f; _ -> t} ==> if a then t else f warn "Redundant if" = (if c then (True, x) else (False, x)) ==> (c, x) where note = IncreasesLaziness warn "Redundant if" = (if c then (False, x) else (True, x)) ==> (not c, x) where note = IncreasesLaziness warn = or [x, y] ==> x || y warn = or [x, y, z] ==> x || y || z warn = and [x, y] ==> x && y warn = and [x, y, z] ==> x && y && z error "Redundant if" = (if x then False else y) ==> not x && y where _ = notEq y True error "Redundant if" = (if x then y else True) ==> not x || y where _ = notEq y False error "Redundant not" = not (not x) ==> x error "Too strict if" = (if c then f x else f y) ==> f (if c then x else y) where note = IncreasesLaziness -- ARROW error = id *** g ==> second g error = f *** id ==> first f error = zip (map f x) (map g x) ==> map (f Control.Arrow.&&& g) x warn = (\(x,y) -> (f x, g y)) ==> f Control.Arrow.*** g warn = (\x -> (f x, g x)) ==> f Control.Arrow.&&& g warn = (\(x,y) -> (f x,y)) ==> Control.Arrow.first f warn = (\(x,y) -> (x,f y)) ==> Control.Arrow.second f warn = (f (fst x), g (snd x)) ==> (f Control.Arrow.*** g) x warn "Redundant pair" = (fst x, snd x) ==> x where note = DecreasesLaziness -- FUNCTOR error "Functor law" = fmap f (fmap g x) ==> fmap (f . g) x error "Functor law" = fmap id ==> id -- MONAD error "Monad law, left identity" = return a >>= f ==> f a error "Monad law, right identity" = m >>= return ==> m warn = m >>= return . f ==> Control.Monad.liftM f m -- cannot be fmap, because is in Functor not Monad error = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y) error = (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y error = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y) error = (if x then return () else y) ==> Control.Monad.unless x y where _ = isAtom y error = sequence (map f x) ==> mapM f x error = sequence_ (map f x) ==> mapM_ f x warn = flip mapM ==> Control.Monad.forM warn = flip mapM_ ==> Control.Monad.forM_ warn = flip forM ==> mapM warn = flip forM_ ==> mapM_ error = when (not x) ==> unless x error = x >>= id ==> Control.Monad.join x error = liftM f (liftM g x) ==> liftM (f . g) x error = fmap f (fmap g x) ==> fmap (f . g) x warn = a >> return () ==> void a warn = fmap (const ()) ==> void error = flip (>=>) ==> (<=<) error = flip (<=<) ==> (>=>) error = (\x -> f x >>= g) ==> f Control.Monad.>=> g error = (\x -> f =<< g x) ==> f Control.Monad.<=< g error = a >> forever a ==> forever a warn = liftM2 id ==> ap error = mapM (uncurry f) (zip l m) ==> zipWithM f l m -- STATE MONAD error = fst (runState x y) ==> evalState x y error = snd (runState x y) ==> execState x y -- MONAD LIST error = liftM unzip (mapM f x) ==> Control.Monad.mapAndUnzipM f x error = sequence (zipWith f x y) ==> Control.Monad.zipWithM f x y error = sequence_ (zipWith f x y) ==> Control.Monad.zipWithM_ f x y error = sequence (replicate n x) ==> Control.Monad.replicateM n x error = sequence_ (replicate n x) ==> Control.Monad.replicateM_ n x error = mapM f (replicate n x) ==> Control.Monad.replicateM n (f x) error = mapM_ f (replicate n x) ==> Control.Monad.replicateM_ n (f x) error = mapM f (map g x) ==> mapM (f . g) x error = mapM_ f (map g x) ==> mapM_ (f . g) x error = mapM id ==> sequence error = mapM_ id ==> sequence_ -- APPLICATIVE / TRAVERSABLE error = flip traverse ==> for error = flip for ==> traverse error = flip traverse_ ==> for_ error = flip for_ ==> traverse_ error = foldr (*>) (pure ()) ==> sequenceA_ error = foldr (<|>) empty ==> asum error = liftA2 (flip ($)) ==> (<**>) error = Just <$> a <|> pure Nothing ==> optional a -- LIST COMP warn "Use list comprehension" = (if b then [x] else []) ==> [x | b] warn "Redundant list comprehension" = [x | x <- y] ==> y where _ = isVar x -- SEQ error "Redundant seq" = x `seq` x ==> x error "Redundant $!" = id $! x ==> x error "Redundant seq" = x `seq` y ==> y where _ = isWHNF x error "Redundant $!" = f $! x ==> f x where _ = isWHNF x error "Redundant evaluate" = evaluate x ==> return x where _ = isWHNF x -- MAYBE error = maybe x id ==> Data.Maybe.fromMaybe x error = maybe False (const True) ==> Data.Maybe.isJust error = maybe True (const False) ==> Data.Maybe.isNothing error = not (isNothing x) ==> isJust x error = not (isJust x) ==> isNothing x error = maybe [] (:[]) ==> maybeToList error = catMaybes (map f x) ==> mapMaybe f x warn = (case x of Nothing -> y; Just a -> a) ==> fromMaybe y x error = (if isNothing x then y else f (fromJust x)) ==> maybe y f x error = (if isJust x then f (fromJust x) else y) ==> maybe y f x error = maybe Nothing (Just . f) ==> fmap f warn = map fromJust . filter isJust ==> Data.Maybe.catMaybes error = x == Nothing ==> isNothing x error = Nothing == x ==> isNothing x error = x /= Nothing ==> Data.Maybe.isJust x error = Nothing /= x ==> Data.Maybe.isJust x error = concatMap (maybeToList . f) ==> Data.Maybe.mapMaybe f error = concatMap maybeToList ==> catMaybes error = maybe n Just x ==> Control.Monad.mplus x n warn = (case x of Just a -> a; Nothing -> y) ==> fromMaybe y x error = (if isNothing x then y else fromJust x) ==> fromMaybe y x error = (if isJust x then fromJust x else y) ==> fromMaybe y x error = isJust x && (fromJust x == y) ==> x == Just y error = mapMaybe f (map g x) ==> mapMaybe (f . g) x error = fromMaybe a (fmap f x) ==> maybe a f x warn = [x | Just x <- a] ==> Data.Maybe.catMaybes a warn = (case m of Nothing -> Nothing; Just x -> x) ==> Control.Monad.join m warn = maybe Nothing id ==> join warn "Too strict maybe" = maybe (f x) (f . g) ==> f . maybe x g where note = IncreasesLaziness -- EITHER error = [a | Left a <- a] ==> lefts a error = [a | Right a <- a] ==> rights a -- INFIX warn "Use infix" = X.elem x y ==> x `X.elem` y where _ = not (isInfixApp original) && not (isParen result) warn "Use infix" = X.notElem x y ==> x `X.notElem` y where _ = not (isInfixApp original) && not (isParen result) warn "Use infix" = X.isInfixOf x y ==> x `X.isInfixOf` y where _ = not (isInfixApp original) && not (isParen result) warn "Use infix" = X.isSuffixOf x y ==> x `X.isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result) warn "Use infix" = X.isPrefixOf x y ==> x `X.isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result) warn "Use infix" = X.union x y ==> x `X.union` y where _ = not (isInfixApp original) && not (isParen result) warn "Use infix" = X.intersect x y ==> x `X.intersect` y where _ = not (isInfixApp original) && not (isParen result) -- MATHS error "Redundant fromIntegral" = fromIntegral x ==> x where _ = isLitInt x error "Redundant fromInteger" = fromInteger x ==> x where _ = isLitInt x warn = x + negate y ==> x - y warn = 0 - x ==> negate x warn = log y / log x ==> logBase x y warn = sin x / cos x ==> tan x warn = sinh x / cosh x ==> tanh x warn = n `rem` 2 == 0 ==> even n warn = n `rem` 2 /= 0 ==> odd n warn = not (even x) ==> odd x warn = not (odd x) ==> even x warn = x ** 0.5 ==> sqrt x warn "Use 1" = x ^ 0 ==> 1 warn = round (x - 0.5) ==> floor x -- CONCURRENT warn = mapM_ (writeChan a) ==> writeList2Chan a -- EXCEPTION warn = flip Control.Exception.catch ==> handle warn = flip handle ==> Control.Exception.catch warn = flip (catchJust p) ==> handleJust p warn = flip (handleJust p) ==> catchJust p warn = Control.Exception.bracket b (const a) (const t) ==> Control.Exception.bracket_ b a t warn = Control.Exception.bracket (openFile x y) hClose ==> withFile x y warn = Control.Exception.bracket (openBinaryFile x y) hClose ==> withBinaryFile x y warn = throw (ErrorCall a) ==> error a error = a `seq` return a ==> Control.Exception.evaluate a error = toException NonTermination ==> nonTermination error = toException NestedAtomically ==> nestedAtomically -- WEAK POINTERS error = mkWeak a a b ==> mkWeakPtr a b error = mkWeak a (a, b) c ==> mkWeakPair a b c -- FOLDABLE error "Use Foldable.forM_" = (case m of Nothing -> return (); Just x -> f x) ==> Data.Foldable.forM_ m f error "Use Foldable.forM_" = when (isJust m) (f (fromJust m)) ==> Data.Foldable.forM_ m f -- EVALUATE -- TODO: These should be moved in to HSE\Evaluate.hs and applied -- through a special evaluate hint mechanism error "Evaluate" = True && x ==> x error "Evaluate" = False && x ==> False error "Evaluate" = True || x ==> True error "Evaluate" = False || x ==> x error "Evaluate" = not True ==> False error "Evaluate" = not False ==> True error "Evaluate" = Nothing >>= k ==> Nothing error "Evaluate" = either f g (Left x) ==> f x error "Evaluate" = either f g (Right y) ==> g y error "Evaluate" = fst (x,y) ==> x error "Evaluate" = snd (x,y) ==> y error "Evaluate" = f (fst p) (snd p) ==> uncurry f p error "Evaluate" = init [x] ==> [] error "Evaluate" = null [] ==> True error "Evaluate" = length [] ==> 0 error "Evaluate" = foldl f z [] ==> z error "Evaluate" = foldr f z [] ==> z error "Evaluate" = foldr1 f [x] ==> x error "Evaluate" = scanr f z [] ==> [z] error "Evaluate" = scanr1 f [] ==> [] error "Evaluate" = scanr1 f [x] ==> [x] error "Evaluate" = take n [] ==> [] where note = IncreasesLaziness error "Evaluate" = drop n [] ==> [] where note = IncreasesLaziness error "Evaluate" = takeWhile p [] ==> [] error "Evaluate" = dropWhile p [] ==> [] error "Evaluate" = span p [] ==> ([],[]) error "Evaluate" = lines "" ==> [] error "Evaluate" = unwords [] ==> "" error "Evaluate" = x - 0 ==> x error "Evaluate" = x * 1 ==> x error "Evaluate" = x / 1 ==> x error "Evaluate" = concat [a] ==> a error "Evaluate" = concat [] ==> [] error "Evaluate" = zip [] [] ==> [] error "Evaluate" = id x ==> x error "Evaluate" = const x y ==> x -- COMPLEX {- -- these would be a good idea, but we have not yet proven them and they seem to have side conditions error "Use isPrefixOf" = take (length t) s == t ==> t `Data.List.isPrefixOf` s error "Use isPrefixOf" = (take i s == t) ==> _eval_ ((i >= length t) && (t `Data.List.isPrefixOf` s)) where _ = (isList t || isLit t) && isPos i -} {- -- clever hint, but not actually a good idea warn = (do a <- f; g a) ==> f >>= g where _ = (isAtom f || isApp f) -} test = hints named test are to allow people to put test code within hint files testPrefix = and any prefix also works {- yes = concat . map f -- concatMap f yes = foo . bar . concat . map f . baz . bar -- concatMap f . baz . bar yes = map f (map g x) -- map (f . g) x yes = concat.map (\x->if x==e then l' else [x]) -- concatMap (\x->if x==e then l' else [x]) yes = f x where f x = concat . map head -- concatMap head yes = concat . map f . g -- concatMap f . g yes = concat $ map f x -- concatMap f x yes = "test" ++ concatMap (' ':) ["of","this"] -- unwords ("test":["of","this"]) yes = if f a then True else b -- f a || b yes = not (a == b) -- a /= b yes = not (a /= b) -- a == b yes = if a then 1 else if b then 1 else 2 -- if a || b then 1 else 2 no = if a then 1 else if b then 3 else 2 yes = a >>= return . id -- Control.Monad.liftM id a yes = (x !! 0) + (x !! 2) -- head x yes = if b < 42 then [a] else [] -- [a | b < 42] no = take n (foo xs) == "hello" yes = head (reverse xs) -- last xs yes = reverse xs `isPrefixOf` reverse ys -- isSuffixOf xs ys no = putStrLn $ show (length xs) ++ "Test" yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- toUpper Control.Arrow.*** urlEncode yes = map (\(a,b) -> a) xs -- fst yes = map (\(a,_) -> a) xs -- fst yes = readFile $ args !! 0 -- head args yes = if Debug `elem` opts then ["--debug"] else [] -- ["--debug" | Debug `elem` opts] yes = if nullPS s then return False else if headPS s /= '\n' then return False else alter_input tailPS >> return True \ -- if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () \ -- Control.Monad.when foo $ do stuff ; moreStuff ; lastOfTheStuff yes = if foo then stuff else return () -- Control.Monad.when foo stuff yes = foo $ \(a, b) -> (a, y + b) -- Control.Arrow.second ((+) y) no = foo $ \(a, b) -> (a, a + b) yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (+) [1 .. 5] [6 .. 10] no = do iter <- textBufferGetTextIter tb ; textBufferSelectRange tb iter iter no = flip f x $ \y -> y*y+y no = \x -> f x (g x) no = foo (\ v -> f v . g) yes = concat . intersperse " " -- unwords yes = Prelude.concat $ intersperse " " xs -- unwords xs yes = concat $ Data.List.intersperse " " xs -- unwords xs yes = if a then True else False -- a yes = if x then true else False -- x && true yes = elem x y -- x `elem` y yes = foo (elem x y) -- x `elem` y no = x `elem` y no = elem 1 [] : [] test a = foo (\x -> True) -- const True h a = flip f x (y z) -- f (y z) x h a = flip f x $ y z yes x = case x of {True -> a ; False -> b} -- if x then a else b yes x = case x of {False -> a ; _ -> b} -- if x then b else a no = const . ok . toResponse $ "saved" yes = case x z of Nothing -> y z; Just pattern -> pattern -- fromMaybe (y z) (x z) yes = if p then s else return () -- Control.Monad.when p s error = a $$$$ b $$$$ c ==> a . b $$$$$ c yes = when (not . null $ asdf) -- unless (null asdf) yes = id 1 -- 1 yes = case concat (map f x) of [] -> [] -- concatMap f x yes = Map.union a b -- a `Map.union` b yes = [v | v <- xs] -- xs no = [Left x | Left x <- xs] yes = Map.union a b -- a `Map.union` b when p s = if p then s else return () no = x ^^ 18.5 instance Arrow (->) where first f = f *** id yes = fromInteger 12 -- 12 import Prelude hiding (catch); no = catch import Control.Exception as E; no = E.catch main = do f; putStrLn $ show x -- print x main = map (writer,) $ map arcObj $ filter (rdfPredEq (Res dctreferences)) ts -- map ((writer,) . arcObj) (filter (rdfPredEq (Res dctreferences)) ts) h x y = return $! (x, y) -- return (x, y) h x y = return $! x getInt = do { x <- readIO "0"; return $! (x :: Int) } foo = evaluate [12] -- return [12] test = \ a -> f a >>= \ b -> return (a, b) fooer input = catMaybes . map Just $ input -- mapMaybe Just main = print $ map (\_->5) [2,3,5] -- const 5 main = x == a || x == b || x == c -- x `elem` [a,b,c] main = head $ drop n x main = head $ drop (-3) x -- x main = head $ drop 2 x -- x !! 2 main = drop 0 x -- x main = take 0 x -- [] main = take (-5) x -- [] main = take (-y) x main = take 4 x main = let (first, rest) = (takeWhile p l, dropWhile p l) in rest -- span p l main = map $ \ d -> ([| $d |], [| $d |]) import Prelude \ yes = flip mapM -- Control.Monad.forM import Control.Monad \ yes = flip mapM -- forM import Control.Monad(forM) \ yes = flip mapM -- forM import Control.Monad(forM_) \ yes = flip mapM -- Control.Monad.forM import qualified Control.Monad \ yes = flip mapM -- Control.Monad.forM import qualified Control.Monad as CM \ yes = flip mapM -- CM.forM import qualified Control.Monad as CM(forM,filterM) \ yes = flip mapM -- CM.forM import Control.Monad as CM(forM,filterM) \ yes = flip mapM -- forM import Control.Monad hiding (forM) \ yes = flip mapM -- Control.Monad.forM import Control.Monad hiding (filterM) \ yes = flip mapM -- forM import qualified Data.Text.Lazy as DTL \ main = DTL.concat $ map (`DTL.snoc` '-') [DTL.pack "one", DTL.pack "two", DTL.pack "three"] import Text.Blaze.Html5.Attributes as A \ main = A.id (stringValue id') -}