packages feed

hlint 2.0.9 → 2.0.10

raw patch · 26 files changed

+608/−518 lines, 26 filesdep +aesondep +data-defaultdep +haskell-src-exts-utilPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, data-default, haskell-src-exts-util

API changes (from Hackage documentation)

Files

CHANGES.txt view
@@ -1,5 +1,18 @@ Changelog for HLint +2.0.10+    #377, suggest lambda case+    Add CodeClimate support+    #378, suggest map for degenerate foldr+    #395, suggest x $> y from x *> pure y and x *> return y+    #395, suggest x <$ y from pure x <* y and return x <* y+    #393, suggest f <$> m from m >>= pure . f and pure . f =<<+    #366, avoid the github API for prebuilt hlint, is rate limited+    #352, suggest maybe for fromMaybe d (f <$> x)+    #338, warn about things imported hidden but not used+    #337, add --git flag to additionally check files in git+    #353, suggest _ <- mapM to mapM_+    #357, warn on unnecessary use of MagicHash 2.0.9     #346, don't suggest explicit export lists     #344, fix the API so it works with hlint.yaml by default
README.md view
@@ -9,7 +9,7 @@  ### Acknowledgements -This program has only been made possible by the presence of the [haskell-src-exts](https://github.com/haskell-suite/haskell-src-exts) package, and many improvements have been made by [Niklas Broberg](http://www.nbroberg.se) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann, Iustin Pop, Steve Purcell and others.+This program has only been made possible by the presence of the [haskell-src-exts](https://github.com/haskell-suite/haskell-src-exts) package, and many improvements have been made by [Niklas Broberg](http://www.nbroberg.se) in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott, Andy Stewart, Roman Leshchinskiy, Johannes Lippmann, Iustin Pop, Steve Purcell, Mitchell Rosen and others.  ### Bugs and limitations @@ -74,6 +74,15 @@  The arguments inside `@()` are passed to `hlint`, so add new arguments surrounded by `'`, space separated - e.g. `@('.' '--report')`. +### Integrations++HLint is integrated into lots of places:++* Lots of editors have HLint plugins (quite a few have more than one HLint plugin).+* HLint is part of the multiple editor plugins [ghc-mod](https://hackage.haskell.org/package/ghc-mod) and [Intero](https://github.com/commercialhaskell/intero).+* [Code Climate](https://docs.codeclimate.com/v1.0/docs/hlint) is a CI for analysis which integrates HLint.+* [Danger](http://allocinit.io/haskell/danger-and-hlint/) can be used to automatically comment on pull requests with HLint suggestions.+ ### Automatically Applying Hints  By supplying the `--refactor` flag hlint can automatically apply most@@ -166,17 +175,35 @@  * __Increases laziness__ - for example `foldl (&&) True` suggests `and` including this note. The new code will work on infinite lists, while the old code would not. Increasing laziness is usually a good idea. * __Decreases laziness__ - for example `(fst a, snd a)` suggests a including this note. On evaluation the new code will raise an error if a is an error, while the old code would produce a pair containing two error values. Only a small number of hints decrease laziness, and anyone relying on the laziness of the original code would be advised to include a comment.-* __Removes error__ - for example `foldr1 (&&)` suggests and including the note `Removes error on []`. The new code will produce `True` on the empty list, while the old code would raise an error. Unless you are relying on the exception thrown by the empty list, this hint is safe - and if you do rely on the exception, you would be advised to add a comment. +* __Removes error__ - for example `foldr1 (&&)` suggests and including the note `Removes error on []`. The new code will produce `True` on the empty list, while the old code would raise an error. Unless you are relying on the exception thrown by the empty list, this hint is safe - and if you do rely on the exception, you would be advised to add a comment.  ### What is the difference between error/warning/suggestion?  Every hint has a severity level: -* __Error__ - by default only used for parse errors. +* __Error__ - by default only used for parse errors. * __Warning__ - for example `concat (map f x)` suggests `concatMap f x` as a "warning" severity hint. From a style point of view, you should always replace a combination of `concat` and `map` with `concatMap`. * __Suggestion__ - for example `x !! 0` suggests `head x` as a "suggestion" severity hint. Typically `head` is a simpler way of expressing the first element of a list, especially if you are treating the list inductively. However, in the expression `f (x !! 4) (x !! 0) (x !! 7)`, replacing the middle argument with `head` makes it harder to follow the pattern, and is probably a bad idea. Suggestion hints are often worthwhile, but should not be applied blindly.  The difference between warning and suggestion 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 warning hints before suggestion hints.++### Is it possible to use pragma annotations in code that is read by `ghci` (conflicts with `OverloadedStrings`)?++Short answer: yes, it is!++If the language extension `OverloadedStrings` is enabled, `ghci` may however report error messages such as:+```+Ambiguous type variable ‘t0’ arising from an annotation+prevents the constraint ‘(Data.Data.Data t0)’ from being solved.+```++In this case, a solution is to add the `:: String` type annotation.  For example:++```+{-# ANN someFunc ("HLint: ignore Use fmap" :: String) #-}+```++See discussion in [issue #372](https://github.com/ndmitchell/hlint/issues/372).  ## Customizing the hints
data/hlint.yaml view
@@ -119,6 +119,7 @@     - warn: {lhs: foldl (++) "", rhs: concat, note: IncreasesLaziness}     - warn: {lhs: foldl f (head x) (tail x), rhs: foldl1 f x}     - warn: {lhs: foldr f (last x) (init x), rhs: foldr1 f x}+    - warn: {lhs: "foldr (\\c a -> x : a) []", rhs: "map (\\c -> x)"}     - warn: {lhs: span (not . p), rhs: break p}     - warn: {lhs: break (not . p), rhs: span p}     - warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x}@@ -302,6 +303,10 @@     - warn: {lhs: id <$> x, rhs: x, name: Functor law}     - hint: {lhs: fmap f $ x, rhs: f Control.Applicative.<$> x, side: isApp x || isAtom x}     - hint: {lhs: \x -> a <$> b x, rhs: fmap a . b}+    - hint: {lhs: x *> pure y, rhs: x Data.Functor.$> y}+    - hint: {lhs: x *> return y, rhs: x Data.Functor.$> y}+    - hint: {lhs: pure x <* y, rhs: x Data.Functor.<$ y}+    - hint: {lhs: return x <* y, rhs: x Data.Functor.<$ y}      # MONAD @@ -311,8 +316,8 @@     - warn: {lhs: return =<< m, rhs: m, name: "Monad law, right identity"}     - warn: {lhs: liftM, rhs: fmap}     - warn: {lhs: liftA, rhs: fmap}-    - hint: {lhs: m >>= return . f, rhs: fmap f m}-    - hint: {lhs: return . f =<< m, rhs: fmap f m}+    - hint: {lhs: m >>= return . f, rhs: f <$> m}+    - hint: {lhs: return . f =<< m, rhs: f <$> m}     - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x $ _noParen_ y, side: not (isAtom y)}     - warn: {lhs: if x then y else return (), rhs: Control.Monad.when x y, side: isAtom y}     - warn: {lhs: if x then return () else y, rhs: Control.Monad.unless x $ _noParen_ y, side: isAtom y}@@ -374,6 +379,8 @@     - warn: {lhs: foldr (<|>) empty, rhs: asum}     - warn: {lhs: liftA2 (flip ($)), rhs: (<**>)}     - warn: {lhs: Just <$> a <|> pure Nothing, rhs: optional a}+    - hint: {lhs: m >>= pure . f, rhs: f <$> m}+    - hint: {lhs: pure . f =<< m, rhs: f <$> m}       # LIST COMP@@ -424,6 +431,7 @@     - warn: {lhs: isJust x && (fromJust x == y), rhs: x == Just y}     - warn: {lhs: mapMaybe f (map g x), rhs: mapMaybe (f . g) x}     - warn: {lhs: fromMaybe a (fmap f x), rhs: maybe a f x}+    - warn: {lhs: fromMaybe a (f <$> x), rhs: maybe a f x}     - warn: {lhs: mapMaybe id, rhs: catMaybes}     - hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a}     - hint: {lhs: case m of Nothing -> Nothing; Just x -> x, rhs: Control.Monad.join m}@@ -621,7 +629,14 @@ # yes = not . (/= a) -- (== a) # 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 . bob -- fmap bob a+# yes = a >>= return . bob -- bob <$> a+# yes = return . bob =<< a -- bob <$> a+# yes = m alice >>= pure . b -- b <$> m alice+# yes = pure .b =<< m alice -- b <$> m alice+# yes = asciiCI "hi" *> pure Hi -- asciiCI "hi" Data.Functor.$> Hi+# yes = asciiCI "bye" *> return Bye -- asciiCI "bye" Data.Functor.$> Bye+# yes = pure x <* y -- x Data.Functor.<$ y+# yes = return x <* y -- x Data.Functor.<$ y # yes = (x !! 0) + (x !! 2) -- head x # yes = if b < 42 then [a] else [] -- [a | b < 42] # no  = take n (foo xs) == "hello"@@ -733,7 +748,9 @@ # {-# LANGUAGE TypeApplications #-} \ # foo = id @Int # foo = id 12 -- 12-# +# yes = foldr (\ curr acc -> (+ 1) curr : acc) [] -- map (\ curr -> (+ 1) curr)+# yes = foldr (\ curr acc -> curr + curr : acc) [] -- map (\ curr -> curr + curr)+# # import Prelude \ # yes = flip mapM -- Control.Monad.forM # import Control.Monad \
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            2.0.9+version:            2.0.10 license:            BSD3 license-file:       LICENSE category:           Development@@ -27,7 +27,7 @@ extra-doc-files:     README.md     CHANGES.txt-tested-with:        GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+tested-with:        GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2  source-repository head     type:     git@@ -48,14 +48,16 @@     build-depends:         base == 4.*, process, filepath, directory, containers,         unordered-containers, yaml, vector, text, bytestring,-        transformers,+        transformers, data-default,         cpphs >= 1.20.1,         cmdargs >= 0.10,         haskell-src-exts >= 1.18 && < 1.20,+        haskell-src-exts-util >= 0.2.1.2,         uniplate >= 1.5,         ansi-terminal >= 0.6.2,         extra >= 1.4.9,-        refact >= 0.3+        refact >= 0.3,+        aeson >= 1.1.2.0      if flag(gpl)         build-depends: hscolour >= 1.21@@ -78,18 +80,18 @@         Util         Parallel         Refact-        Config.All+        CC         Config.Compute         Config.Haskell+        Config.Read         Config.Type         Config.Yaml         HSE.All-        HSE.Bracket-        HSE.FreeVars         HSE.Match         HSE.Reduce         HSE.Scope         HSE.Type+        HSE.Unify         HSE.Util         Hint.All         Hint.Bracket
src/Apply.hs view
@@ -5,7 +5,7 @@ import Data.Monoid import HSE.All import Hint.All-import Hint.Type+import Idea import Data.Tuple.Extra import Data.Either import Data.List.Extra
+ src/CC.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+-- |+--+-- Utility for formatting @'Idea'@ data in accordance with the Code Climate+-- spec: <https://github.com/codeclimate/spec>+--+module CC+    ( printIssue+    , fromIdea+    ) where++import Data.Aeson (ToJSON(..), (.=), encode, object)+import Data.Char (toUpper)+import Data.Monoid ((<>))+import Data.Text (Text)+import Language.Haskell.Exts.SrcLoc (SrcSpan(..))++import qualified Data.Text as T+import qualified Data.ByteString.Lazy.Char8 as C8++import Idea (Idea(..), Severity(..))++data Issue = Issue+    { issueType :: Text+    , issueCheckName :: Text+    , issueDescription :: Text+    , issueContent :: Text+    , issueCategories :: [Text]+    , issueLocation :: Location+    , issueRemediationPoints :: Int+    }++data Location = Location FilePath Position Position+data Position = Position Int Int++instance ToJSON Issue where+    toJSON Issue{..} = object+        [ "type" .= issueType+        , "check_name" .= issueCheckName+        , "description" .= issueDescription+        , "content" .= object+            [ "body" .= issueContent+            ]+        , "categories" .= issueCategories+        , "location" .= issueLocation+        , "remediation_points" .= issueRemediationPoints+        ]++instance ToJSON Location where+    toJSON (Location path begin end) = object+        [ "path" .= path+        , "positions" .= object+            [ "begin" .= begin+            , "end" .= end+            ]+        ]++instance ToJSON Position where+    toJSON (Position line column) = object+        [ "line" .= line+        , "column" .= column+        ]++-- | Print an @'Issue'@ with trailing null-terminator and newline+--+-- The trailing newline will be ignored, but makes the output more readable+--+printIssue :: Issue -> IO ()+printIssue = C8.putStrLn . (<> "\0") . encode++-- | Convert an hlint @'Idea'@ to a datatype more easily serialized for CC+fromIdea :: Idea -> Issue+fromIdea Idea{..} = Issue+    { issueType = "issue"+    , issueCheckName = "HLint/" <> T.pack (camelize ideaHint)+    , issueDescription = T.pack ideaHint+    , issueContent = content ideaFrom ideaTo <> listNotes ideaNote+    , issueCategories = categories ideaHint+    , issueLocation = fromSrcSpan ideaSpan+    , issueRemediationPoints = points ideaSeverity+    }++  where+    content from Nothing = T.unlines+        [ "Found"+        , ""+        , "```"+        , T.pack from+        , "```"+        , ""+        , "remove it."+        ]++    content from (Just to) = T.unlines+        [ "Found"+        , ""+        , "```"+        , T.pack from+        , "```"+        , ""+        , "Why not"+        , ""+        , "```"+        , T.pack to+        , "```"+        ]++    listNotes [] = ""+    listNotes notes = T.unlines $+        [ ""+        , "Applying this change:"+        , ""+        ] ++ map (("* " <>) . T.pack . show) notes++    categories _ = ["Style"]++    points Ignore = 0+    points Suggestion = basePoints+    points Warning = 5 * basePoints+    points Error = 10 * basePoints++fromSrcSpan :: SrcSpan -> Location+fromSrcSpan SrcSpan{..} = Location+    (locationFileName srcSpanFilename)+    (Position srcSpanStartLine srcSpanStartColumn)+    (Position srcSpanEndLine srcSpanEndColumn)+  where+    locationFileName ('.':'/':x) = x+    locationFileName x = x++camelize :: String -> String+camelize = concatMap capitalize . words++capitalize :: String -> String+capitalize [] = []+capitalize (c:rest) = toUpper c : rest++-- "The baseline remediation points value is 50,000, which is the time it takes+-- to fix a trivial code style issue like a missing semicolon on a single line,+-- including the time for the developer to open the code, make the change, and+-- confidently commit the fix. All other remediation points values are expressed+-- in multiples of that Basic Remediation Point Value."+basePoints :: Int+basePoints = 50000
src/CmdLine.hs view
@@ -17,7 +17,9 @@ import System.Exit import System.FilePath import System.IO+import System.Process(readProcess) import Language.Preprocessor.Cpphs+import HSE.All(CppFlags(..)) import Language.Haskell.Exts(defaultParseMode, baseLanguage) import Language.Haskell.Exts.Extension import Data.Maybe@@ -36,13 +38,13 @@  automatic :: Cmd -> IO Cmd automatic cmd = case cmd of-    CmdMain{} -> dataDir $ path $ extension cmd-    CmdGrep{} -> return $ path $ extension cmd+    CmdMain{} -> dataDir =<< path =<< git =<< extension cmd+    CmdGrep{} -> path =<< extension cmd     CmdTest{} -> dataDir cmd     _ -> return cmd     where-        path cmd = if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd-        extension cmd = if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd+        path cmd = return $ if null $ cmdPath cmd then cmd{cmdPath=["."]} else cmd+        extension cmd = return $ if null $ cmdExtension cmd then cmd{cmdExtension=["hs","lhs"]} else cmd         dataDir cmd             | cmdDataDir cmd  /= "" = return cmd             | otherwise = do@@ -51,6 +53,17 @@                 if b then return cmd{cmdDataDir=x} else do                     exe <- getExecutablePath                     return cmd{cmdDataDir = takeDirectory exe </> "data"}+        git cmd+            | cmdGit cmd = do+                mgit <- findExecutable "git"+                case mgit of+                    Nothing -> error "Could not find git"+                    Just git -> do+                        let args = ["ls-files", "--cached", "--others", "--exclude-standard"] +++                                   map ("*." ++) (cmdExtension cmd)+                        files <- readProcess git args ""+                        return cmd{cmdFiles = cmdFiles cmd ++ lines files}+            | otherwise = return cmd   exitWithHelp :: IO a@@ -59,13 +72,6 @@     exitSuccess  --- | What C pre processor should be used.-data CppFlags-    = NoCpp -- ^ No pre processing is done.-    | CppSimple -- ^ Lines prefixed with @#@ are stripped.-    | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.-- -- | When to colour terminal output. data ColorMode     = Never  -- ^ Terminal output will never be coloured.@@ -84,6 +90,7 @@         ,cmdReports :: [FilePath]        -- ^ where to generate reports         ,cmdGivenHints :: [FilePath]     -- ^ which settignsfiles were explicitly given         ,cmdWithHints :: [String]        -- ^ hints that are given on the command line+        ,cmdGit :: Bool                  -- ^ use git ls-files to find files         ,cmdColor :: ColorMode           -- ^ color the result         ,cmdThreads :: Int              -- ^ Numbmer of threads to use, 0 = whatever GHC has         ,cmdIgnore :: [String]           -- ^ the hints to ignore@@ -101,6 +108,7 @@         ,cmdCppSimple :: Bool         ,cmdCppAnsi :: Bool         ,cmdJson :: Bool                -- ^ display hint data as JSON+        ,cmdCC :: Bool                  -- ^ display hint data as Code Climate Issues         ,cmdNoSummary :: Bool           -- ^ do not show the summary info         ,cmdOnly :: [String]            -- ^ specify which hints explicitly         ,cmdNoExitCode :: Bool@@ -143,6 +151,7 @@         ,cmdReports = nam "report" &= opt "report.html" &= typFile &= help "Generate a report in HTML"         ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use"         ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints to use"+        ,cmdGit = nam "git" &= help "Run on files tracked by git"         ,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires ANSI terminal; auto means on when $TERM is supported; by itself, selects always)"         ,cmdThreads = 1 &= name "threads" &= name "j" &= opt (0 :: Int) &= help "Number of threads to use (-j for all)"         ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint"@@ -160,6 +169,7 @@         ,cmdCppSimple = nam_ "cpp-simple" &= help "Use a simple CPP (strip # lines)"         ,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode"         ,cmdJson = nam_ "json" &= help "Display hint data as JSON"+        ,cmdCC = nam_ "cc" &= help "Display hint data as Code Climate Issues"         ,cmdNoSummary = nam_ "no-summary" &= help "Do not show summary information"         ,cmdOnly = nam "only" &= typ "HINT" &= help "Specify which hints explicitly"         ,cmdNoExitCode = nam_ "no-exit-code" &= help "Do not give a negative exit if hints"
− src/Config/All.hs 
@@ -1,17 +0,0 @@--module Config.All(readFilesConfig) where--import Config.Type-import Config.Haskell-import Config.Yaml-import Data.List.Extra-import System.FilePath---readFilesConfig :: [(FilePath, Maybe String)] -> IO [Setting]-readFilesConfig files = do-        yaml <- mapM (uncurry readFileConfigYaml) yaml-        haskell <- mapM (uncurry readFileConfigHaskell) haskell-        return $ concat haskell ++ settingsFromConfigYaml yaml-    where-        (yaml, haskell) = partition (\(x,_) -> lower (takeExtension x) `elem` [".yml",".yaml"]) files
+ src/Config/Read.hs view
@@ -0,0 +1,17 @@++module Config.Read(readFilesConfig) where++import Config.Type+import Config.Haskell+import Config.Yaml+import Data.List.Extra+import System.FilePath+++readFilesConfig :: [(FilePath, Maybe String)] -> IO [Setting]+readFilesConfig files = do+        yaml <- mapM (uncurry readFileConfigYaml) yaml+        haskell <- mapM (uncurry readFileConfigHaskell) haskell+        return $ concat haskell ++ settingsFromConfigYaml yaml+    where+        (yaml, haskell) = partition (\(x,_) -> lower (takeExtension x) `elem` [".yml",".yaml"]) files
src/HLint.hs view
@@ -22,7 +22,7 @@ import System.FilePath  import CmdLine-import Config.All+import Config.Read import Config.Type import Config.Compute import Report@@ -34,6 +34,7 @@ import Test.Proof import Parallel import HSE.All+import CC   -- | This function takes a list of command line arguments, and returns the given hints.@@ -159,6 +160,8 @@         ideas <- return $ if cmdShowAll then ideas else  filter (\i -> ideaSeverity i /= Ignore) ideas         if cmdJson then             putStrLn $ showIdeasJson ideas+         else if cmdCC then+            mapM_ (printIssue . fromIdea) ideas          else if cmdSerialise then do             hSetBuffering stdout NoBuffering             print $ map (show &&& ideaRefactoring) ideas
src/HSE/All.hs view
@@ -1,30 +1,46 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}  module HSE.All(     module X,-    ParseFlags(..), defaultParseFlags,+    CppFlags(..), ParseFlags(..), defaultParseFlags,     parseFlagsAddFixities, parseFlagsSetLanguage,-    parseModuleEx, ParseError(..)+    parseModuleEx, ParseError(..),+    freeVars, vars, varss, pvars     ) where +import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))+import qualified Language.Haskell.Exts.Util as X import HSE.Util as X import HSE.Reduce as X import HSE.Type as X-import HSE.Bracket as X import HSE.Match as X import HSE.Scope as X-import HSE.FreeVars as X import Util-import CmdLine import Data.Char import Data.List.Extra import Data.Maybe import Language.Preprocessor.Cpphs+import Data.Set (Set) import qualified Data.Map as Map+import qualified Data.Set as Set import System.IO.Extra import Data.Functor import Prelude +vars :: FreeVars a => a -> [String]+freeVars :: FreeVars a => a -> Set String+varss, pvars :: AllVars a => a -> [String]+vars  = Set.toList . Set.map prettyPrint . X.freeVars+varss = Set.toList . Set.map prettyPrint . X.free . X.allVars+pvars = Set.toList . Set.map prettyPrint . X.bound . X.allVars+freeVars = Set.map prettyPrint . X.freeVars++-- | What C pre processor should be used.+data CppFlags+    = NoCpp -- ^ No pre processing is done.+    | CppSimple -- ^ Lines prefixed with @#@ are stripped.+    | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.  -- | Created with 'defaultParseFlags', used by 'parseModuleEx'. data ParseFlags = ParseFlags
− src/HSE/Bracket.hs 
@@ -1,149 +0,0 @@-{-# LANGUAGE PatternGuards, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-overlapping-patterns -fno-warn-incomplete-patterns #-}--module HSE.Bracket(-    Brackets(..),-    paren, transformBracket, rebracket1, appsBracket-    ) 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--- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc.---        | 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-        PRec{} -> 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)
− src/HSE/FreeVars.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module HSE.FreeVars(FreeVars, freeVars, vars, varss, pvars) where--import Data.Monoid-import HSE.Type as HSE-import qualified Data.Set as Set-import Data.Set(Set)-import Prelude---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 (HSE.Alt S) where-    freeVars (HSE.Alt _ pat alt bind) = inFree pat $ inFree bind alt--instance FreeVars [HSE.Alt S] where-    freeVars = mconcat . map freeVars--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
src/HSE/Match.hs view
@@ -3,7 +3,7 @@ module HSE.Match(     View(..), Named(..),     (~=), isSym,-    App2(App2), PVar_(PVar_), Var_(Var_), PApp_(PApp_)+    App2(App2), LamConst1(LamConst1), PVar_(PVar_), Var_(Var_), PApp_(PApp_)     ) where  import Data.Char@@ -28,6 +28,13 @@ instance View Exp_ App1 where     view (fromParen -> App _ f x) = App1 f x     view _ = NoApp1++-- \_ -> body+data LamConst1 = NoLamConst1 | LamConst1 Exp_ deriving Show++instance View Exp_ LamConst1 where+    view (fromParen -> Lambda _ [PWildCard _] x) = LamConst1 x+    view _ = NoLamConst1  data PApp_ = NoPApp_ | PApp_ String [Pat_]
src/HSE/Reduce.hs view
@@ -6,7 +6,7 @@ import HSE.Match import HSE.Util import HSE.Type-import HSE.Bracket+import Language.Haskell.Exts.Util   reduce :: Exp_ -> Exp_
+ src/HSE/Unify.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}++module HSE.Unify(+    Subst, fromSubst,+    validSubst, substitute,+    unifyExp,+    ) where++import Control.Applicative+import Data.List.Extra+import Data.Maybe+import Data.Data+import Data.Monoid+import Config.Type+import Hint.Type+import Control.Monad+import Data.Tuple.Extra+import Util+import Prelude+++---------------------------------------------------------------------+-- SUBSTITUTION DATA TYPE++-- | A list of substitutions. A key may be duplicated, you need to call 'check'+--   to ensure the substitution is valid.+newtype Subst a = Subst [(String, a)]++-- | Unpack the substitution+fromSubst :: Subst a -> [(String, a)]+fromSubst (Subst xs) = xs++instance Functor Subst where+    fmap f (Subst xs) = Subst $ map (second f) xs++instance Pretty a => Show (Subst a) where+    show (Subst xs) = unlines [a ++ " = " ++ prettyPrint b | (a,b) <- xs]++instance Monoid (Subst a) where+    mempty = Subst []+    mappend (Subst xs) (Subst ys) = Subst $ xs ++ ys+++-- check the unification is valid and simplify it+validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)+validSubst eq = fmap Subst . mapM f . groupSort . fromSubst+    where f (x,y:ys) | all (eq y) ys = Just (x,y)+          f _ = Nothing+++-- | Perform a substitution+substitute :: Subst Exp_ -> Exp_ -> Exp_+substitute (Subst bind) = transformBracket exp . transformBi pat+    where+        exp (Var _ (fromNamed -> x)) = lookup x bind+        exp _ = Nothing++        pat (PVar _ (fromNamed -> x)) | Just y <- lookup x bind = toNamed $ fromNamed y+        pat x = x :: Pat_+++---------------------------------------------------------------------+-- UNIFICATION++type NameMatch = QName S -> QName S -> Bool++nmOp :: NameMatch -> QOp S -> QOp S -> Bool+nmOp nm (QVarOp _ x) (QVarOp _ y) = nm x y+nmOp nm (QConOp _ x) (QConOp _ y) = nm x y+nmOp nm  _ _ = False+++-- | Unification, obeys the property that if @unify a b = s@, then @substitute s a = b@.+unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe (Subst Exp_)+unify nm root x y+    | Just (x,y) <- cast (x,y) = unifyExp nm root x y+    | Just (x,y) <- cast (x,y) = unifyPat nm x y+    | Just (x :: S) <- cast x = Just mempty+    | otherwise = unifyDef nm x y+++unifyDef :: Data a => NameMatch -> a -> a -> Maybe (Subst Exp_)+unifyDef nm x y = fmap mconcat . 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 (Subst Exp_)+unifyExp nm root x y | isParen x || isParen y =+    fmap (rebracket y) <$> unifyExp nm root (fromParen x) (fromParen y)+    where+        rebracket (Paren l e') e | e' == e = Paren l e+        rebracket e e' = e'++unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just $ Subst [(v,y)]+unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just mempty++-- Options: match directly, and expand through .+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+            -- don't expand . if at the root, otherwise you can get duplicate matches+            -- because the matching engine auto-generates hints in dot-form+        InfixApp _ y11 dot y12 <- return $ fromParen y1+        guard $ isDot dot+        unifyExp nm root x (App an y11 (App an y12 y2)))++-- Options: match directly, then expand through $, then desugar infix+unifyExp nm root x (InfixApp _ lhs2 op2 rhs2)+    | InfixApp _ lhs1 op1 rhs1 <- x = guard (nmOp nm 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+    where+        -- types that are not already handled in unify+        {-# INLINE isOther #-}+        isOther Var{} = False+        isOther App{} = False+        isOther InfixApp{} = False+        isOther _ = True++unifyExp nm root _ _ = Nothing+++unifyPat :: NameMatch -> Pat_ -> Pat_ -> Maybe (Subst Exp_)+unifyPat nm (PVar _ x) (PVar _ y) = Just $ Subst [(fromNamed x, toNamed $ fromNamed y)]+unifyPat nm (PVar _ x) PWildCard{} = Just $ Subst [(fromNamed x, toNamed $ "_" ++ fromNamed x)]+unifyPat nm x y = unifyDef nm x y
src/HSE/Util.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE FlexibleContexts, ViewPatterns #-} -module HSE.Util(module HSE.Util) where+module HSE.Util(module HSE.Util, def) where  import Control.Monad+import Data.Default import Data.List+import Language.Haskell.Exts.Util() -- Orphan instances of Default for SrcLoc etc import Data.Maybe import Data.Data hiding (Fixity) import System.FilePath@@ -284,18 +286,11 @@           f (x:xs) = x : f xs           f [] = [] -nullSrcLoc :: SrcLoc-nullSrcLoc = SrcLoc "" 0 0--nullSrcSpan :: SrcSpan-nullSrcSpan = mkSrcSpan nullSrcLoc nullSrcLoc- an :: SrcSpanInfo-an = toSrcInfo nullSrcLoc [] nullSrcLoc+an = def -dropAnn :: Functor f => f s -> f ()+dropAnn :: Functor f => f SrcSpanInfo -> f () dropAnn = void-  --------------------------------------------------------------------- -- SRCLOC EQUALITY
src/Hint/Duplicate.hs view
@@ -60,7 +60,7 @@   duplicateOrdered :: Ord val => Int -> [[(SrcSpan,val)]] -> [(SrcSpan,SrcSpan,[val])]-duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe nullSrcSpan Map.empty) xs+duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe def 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..]
src/Hint/Extensions.hs view
@@ -98,6 +98,10 @@ data Foo = Foo deriving Bob {-# LANGUAGE DeriveAnyClass #-} \ data Foo a = Foo a deriving (Eq,Data,Functor) --+{-# LANGUAGE MagicHash #-} \+foo# = id+{-# LANGUAGE MagicHash #-} \+foo = id -- </TEST> -} @@ -213,6 +217,9 @@ used TransformListComp = hasS f     where f QualStmt{} = False           f _ = True+used MagicHash = hasS f+    where f (Ident _ s) = "#" `isSuffixOf` s+          f _ = False  -- for forwards compatibility, if things ever get added to the extension enumeration used x = usedExt $ UnknownExtension $ show x
src/Hint/Import.hs view
@@ -33,6 +33,73 @@ 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_)+import A hiding (a) -- import A+import A hiding (a, b); foo = a -- import A hiding (a)+import A hiding (a, b); foo = A.a -- import A hiding (a)+import A as B hiding (a) -- import A as B+import A as B hiding (a, b); foo = a -- import A as B hiding (a)+import A as B hiding (a, b); foo = B.a -- import A as B hiding (a)+import qualified A hiding (a) -- import qualified A+import qualified A hiding (a, b); foo = A.a -- import qualified A hiding (a)+import qualified A as B hiding (a, b); foo = B.a -- import qualified A as B hiding (a)+import A hiding ((+)) -- import A+import A hiding ((+), (*)); foo = (+) -- import A hiding ((+))+import A hiding ((+), (*)); foo = (+x) -- import A hiding ((+))+import A hiding ((+), (*)); foo = (x+) -- import A hiding ((+))+import A hiding ((+), (*)); foo = x+y -- import A hiding ((+))+import A hiding ((+), (*)); foo = (A.+) -- import A hiding ((+))+import A hiding ((+), (*)); foo = (A.+ x) -- import A hiding ((+))+import A hiding ((+), (*)); foo = (x A.+) -- import A hiding ((+))+import A hiding ((+), (*)); foo = x A.+ y -- import A hiding ((+))+import A as B hiding ((+)) -- import A as B+import A as B hiding ((+), (*)); foo = (+) -- import A as B hiding ((+))+import A as B hiding ((+), (*)); foo = (x+) -- import A as B hiding ((+))+import A as B hiding ((+), (*)); foo = (+x) -- import A as B hiding ((+))+import A as B hiding ((+), (*)); foo = x+y -- import A as B hiding ((+))+import A as B hiding ((+), (*)); foo = (B.+) -- import A as B hiding ((+))+import A as B hiding ((+), (*)); foo = (x B.+) -- import A as B hiding ((+))+import A as B hiding ((+), (*)); foo = (B.+ x) -- import A as B hiding ((+))+import A as B hiding ((+), (*)); foo = x B.+ y -- import A as B hiding ((+))+import qualified A hiding ((+)) -- import qualified A+import qualified A hiding ((+), (*)); foo = (A.+) -- import qualified A hiding ((+))+import qualified A hiding ((+), (*)); foo = (x A.+) -- import qualified A hiding ((+))+import qualified A hiding ((+), (*)); foo = (A.+ x) -- import qualified A hiding ((+))+import qualified A hiding ((+), (*)); foo = x A.+ y -- import qualified A hiding ((+))+import qualified A as B hiding ((+), (*)); foo = (B.+) -- import qualified A as B hiding ((+))+import qualified A as B hiding ((+), (*)); foo = (x B.+) -- import qualified A as B hiding ((+))+import qualified A as B hiding ((+), (*)); foo = (B.+ x) -- import qualified A as B hiding ((+))+import qualified A as B hiding ((+), (*)); foo = x B.+ y -- import qualified A as B hiding ((+))+module Foo (a) where; import A hiding (a)+module Foo (a) where; import A hiding (a, b) -- import A hiding (a)+module Foo (A.a) where; import A hiding (a, b) -- import A hiding (a)+module Foo (a) where; import A as B hiding (a)+module Foo (a) where; import A as B hiding (a, b) -- import A as B hiding (a)+module Foo (B.a) where; import A as B hiding (a, b) -- import A as B hiding (a)+module Foo (a) where; import qualified A hiding (a) -- import qualified A+module Foo (A.a) where; import qualified A hiding (a, b) -- import qualified A hiding (a)+module Foo (B.a) where; import qualified A as B hiding (a, b) -- import qualified A as B hiding (a)+module Foo (module A) where; import A hiding (a, b, c)+module Foo (module B) where; import A as B hiding (a, b, c)+module Foo (module A) where; import qualified A hiding (a, b, c) -- import qualified A+module Foo (module B) where; import qualified A as B hiding (a, b, c) -- import qualified A as B+module Foo ((+)) where; import A hiding ((+))+module Foo ((+)) where; import A hiding ((+), (*)) -- import A hiding ((+))+module Foo ((A.+)) where; import A hiding ((+), (*)) -- import A hiding ((+))+module Foo ((+)) where; import A as B hiding ((+))+module Foo ((+)) where; import A as B hiding ((+), (*)) -- import A as B hiding ((+))+module Foo ((B.+)) where; import A as B hiding ((+), (*)) -- import A as B hiding ((+))+module Foo ((+)) where; import qualified A hiding ((+)) -- import qualified A+module Foo ((A.+)) where; import qualified A hiding ((+), (*)) -- import qualified A hiding ((+))+module Foo ((B.+)) where; import qualified A as B hiding ((+), (*)) -- import qualified A as B hiding ((+))+module Foo (module A) where; import A hiding ((+), (*), (/))+module Foo (module B) where; import A as B hiding ((+), (*), (/))+module Foo (module A) where; import qualified A hiding ((+), (*), (/)) -- import qualified A+module Foo (module B) where; import qualified A as B hiding ((+), (*), (/)) -- import qualified A as B+{-# LANGUAGE QuasiQuotes #-}; import A hiding (a); [a||]+{-# LANGUAGE QuasiQuotes #-}; import A hiding (a); [A.a||]+{-# LANGUAGE QuasiQuotes #-}; import A as B hiding (a); [B.a||]+{-# LANGUAGE QuasiQuotes #-}; import qualified A hiding (a); [A.a||]+{-# LANGUAGE QuasiQuotes #-}; import qualified A as B hiding (a); [B.a||] </TEST> -} @@ -45,16 +112,53 @@ import Refact.Types hiding (ModuleName) import qualified Refact.Types as R import Data.List.Extra+import Data.Either (partitionEithers) import Data.Maybe import Prelude+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set   importHint :: ModuHint importHint _ x = concatMap (wrap . snd) (groupSort                  [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++-                 concatMap (\x -> hierarchy x ++ combine1 x) (universeBi x)+                 concatMap (\x -> hierarchy x ++ combine1 x ++ hidden reexported unqual quals x) (universeBi x)+    where+        -- Names of all re-exported modules+        reexported :: Set String+        reexported = Set.fromList [ fromModuleName n | EModuleContents _ n <- universeBi x ] +        -- Unqualified expressions and exported expressions+        unqual :: Set String+        unqual = Set.fromList (mapMaybe f qnames) `Set.union` Set.fromList qqUnqual+            where f :: QName S -> Maybe String+                  f (UnQual _ n) = Just (fromNamed n)+                  f _ = Nothing +        -- Qualified expressions and exported expressions+        quals :: Map String (Set String)+        quals = Map.fromListWith Set.union (map (second Set.singleton) qqQuals ++ mapMaybe f qnames)+            where f (Qual _ m n) = Just (fromModuleName m, Set.singleton (fromNamed n))+                  f _ = Nothing++        -- Unqualified quasi-quoters like [foo|...|]+        qqUnqual :: [String]+        -- Qualified quasi-quoters like [Foo.bar|...|]+        qqQuals :: [(String, String)]+        (qqUnqual, qqQuals) = partitionEithers [ f n | QuasiQuote (_ :: S) n _ <- universeBi x ]+            where f :: String -> Either String (String, String)+                  f n = maybe (Left n) Right (stripInfixEnd "." n)++        qnames :: [QName S]+        qnames = concat+            [ [ n | Var      (_ :: S) n <- universeBi x ]+            , [ n | VarQuote (_ :: S) n <- universeBi x ]+            , [ n | QVarOp   (_ :: S) n <- universeBi x ]+            , [ n | EVar     (_ :: S) n <- universeBi x ]+            ]+ wrap :: [ImportDecl S] -> [Idea] wrap o = [ rawIdea Warning "Use fewer imports" (srcInfoSpan $ ann $ head o) (f o) (Just $ f x) [] rs          | Just (x, rs) <- [simplify o]]@@ -65,7 +169,7 @@ simplify [] = Nothing simplify (x:xs) = case simplifyHead x xs of     Nothing -> first (x:) <$> simplify xs-    Just (xs, rs) -> Just $ fromMaybe (xs, rs) (second (++ rs) <$> simplify xs)+    Just (xs, rs) -> Just $ maybe (xs, rs) (second (++ rs)) $ simplify xs   simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan])@@ -96,7 +200,6 @@  combine _ _ = Nothing - combine1 :: ImportDecl S -> [Idea] combine1 i@ImportDecl{..}     | Just (dropAnn importModule) == fmap dropAnn importAs@@ -144,3 +247,36 @@ desugarQual :: ImportDecl S -> ImportDecl S desugarQual x | importQualified x && isNothing (importAs x) = x{importAs=Just (importModule x)}               | otherwise = x++-- Suggest removing unnecessary "hiding" clauses in imports. Currently this only+-- works for expressions.+hidden :: Set String -> Set String -> Map String (Set String) -> ImportDecl S -> [Idea]+hidden reexported unqual quals i@ImportDecl{importSpecs = Just (ImportSpecList loc True xs)}+    -- If the module is re-exported and not imported qualified, we can't prune+    -- any identifiers from the hiding clause+    | not (importQualified i) && as `Set.member` reexported = []+    | otherwise =+        case partition isUsed xs of+            (_, []) -> []+            ([], _) -> [suggest "Unnecessary hiding" i i{importSpecs = Nothing} [Delete Import (toSS i)]]+            (xs, _) ->+                let newImp = i{importSpecs = Just (ImportSpecList loc True xs)}+                in [suggest "Unnecessary hiding" i newImp [Replace Import (toSS i) [] (prettyPrint newImp)]]+    where+        isUsed :: ImportSpec S -> Bool+        isUsed (IVar _ n) = Set.member (fromNamed n) vars+        isUsed _ = True++        vars :: Set String+        vars =+          if importQualified i+            then qual+            else qual `Set.union` unqual++        qual :: Set String+        qual = fromMaybe Set.empty (Map.lookup as quals)++        as :: String+        as = fromModuleName (fromMaybe (importModule i) (importAs i))++hidden _ _ _ _ = []
src/Hint/Lambda.hs view
@@ -66,6 +66,8 @@ yes = foo (\x -> Just x) -- @Warning Just foo = bar (\x -> (x `f`)) -- f baz = bar (\x -> (x +)) -- (+)+yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b+no = blah (\ x -> case x of A -> a x; B -> b x) </TEST> -} @@ -142,6 +144,8 @@       munge ident p@(PWildCard _) = p       munge ident p = PVar (ann p) (Ident (ann p) [ident])       subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats)+lambdaExp p o@(Lambda _ [view -> PVar_ u] (Case _ (view -> Var_ v) alts))+    | u == v, u `notElem` vars alts = [suggestN "Use lambda-case" o $ LCase an alts] lambdaExp _ _ = []
src/Hint/Match.hs view
@@ -42,12 +42,11 @@ import Control.Applicative import Data.List.Extra import Data.Maybe-import Data.Data import Config.Type import Hint.Type import Control.Monad import Data.Tuple.Extra-import Util+import HSE.Unify import qualified Data.Set as Set import Prelude import qualified Refact.Types as R@@ -92,149 +91,33 @@  findIdeas :: [HintRule] -> Scope -> Module S -> Decl_ -> [Idea] findIdeas matches s _ decl =-  [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}-  | decl <- case decl of InstDecl{} -> children decl; _ -> [decl]-  , (parent,x) <- universeParentExp decl, not $ isParen x-  , m <- matches, Just (y,notes, subst, rule) <- [matchIdea s decl m parent x]-  , let r = R.Replace R.Expr (toSS x) subst (prettyPrint rule) ]+    [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}+    | decl <- case decl of InstDecl{} -> children decl; _ -> [decl]+    , (parent,x) <- universeParentExp decl, not $ isParen x+    , m <- matches, Just (y,notes, subst) <- [matchIdea s decl m parent x]+    , let r = R.Replace R.Expr (toSS x) subst (prettyPrint $ hintRuleRHS m) ] -matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_,[Note], [(String, R.SrcSpan)], Exp_)+matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_, [Note], [(String, R.SrcSpan)]) matchIdea s decl HintRule{..} parent x = do     let nm a b = scopeMatch (hintRuleScope,a) (s,b)     u <- unifyExp nm True hintRuleLHS x-    u <- check u+    u <- validSubst (=~=) u     -- need to check free vars before unqualification, but after subst (with e)     -- need to unqualify before substitution (with res)-    let e = subst u hintRuleRHS-        template = substT u hintRuleRHS-        res = addBracket parent $ performEval $ subst u $ unqualify hintRuleScope s u hintRuleRHS+    let e = substitute u hintRuleRHS+        res = addBracket parent $ performSpecial $ substitute u $ unqualify hintRuleScope s hintRuleRHS     guard $ (freeVars e Set.\\ Set.filter (not . isUnifyVar) (freeVars hintRuleRHS))             `Set.isSubsetOf` freeVars x         -- check no unexpected new free variables-    guard $ checkSide hintRuleSide $ ("original",x) : ("result",res) : u+    guard $ checkSide hintRuleSide $ ("original",x) : ("result",res) : fromSubst u     guard $ checkDefine decl parent res-    return (res,hintRuleNotes, [(s, toSS pos) | (s, pos) <- u, ann pos /= an], template)----- | Descend, and if something changes then add/remove brackets appropriately in both the template--- and the original expression.-descendBracketTemplate :: (Exp_ -> (Bool, (Exp_, Exp_))) -> Exp_ -> Exp_-descendBracketTemplate op x = descendIndex g x-    where-        g i y = if a then f i b else fst b-            where (a, b) = op y--        f i (v, y) | needBracket i x y = addParen v-        f i (v, y) = v--transformBracketTemplate :: (Exp_ -> Maybe (Exp_, Exp_)) -> Exp_ -> Exp_-transformBracketTemplate op = fst . snd . g-    where-        g :: Exp_ -> (Bool, (Exp_, Exp_))-        g = f . descendBracketTemplate g-        f :: Exp_ -> (Bool, (Exp_, Exp_))-        f x = maybe (False,(x, x)) ((,) True) (op x)---- perform a substitution-substT :: [(String,Exp_)] -> Exp_ -> Exp_-substT bind = transform g . transformBracketTemplate f-    where-        f v@(Var _ (fromNamed -> x)) | isUnifyVar x = case lookup x bind of-                                                        Just x -> if ann x == an then  Just (x, x)-                                                                                 else  Just (v, x)-                                                        Nothing -> Nothing-        f _ = Nothing--        g (App _ np x) | np ~= "_noParen_" = fromParen x-        g x = x--------------------------------------------------------------------------- UNIFICATION--type NameMatch = QName S -> QName S -> Bool--nmOp :: NameMatch -> QOp S -> QOp S -> Bool-nmOp nm (QVarOp _ x) (QVarOp _ y) = nm x y-nmOp nm (QConOp _ x) (QConOp _ y) = nm x y-nmOp nm  _ _ = False----- unify a b = c, a[c] = b-unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe [(String,Exp_)]-unify nm root x y | Just (x,y) <- cast (x,y) = unifyExp nm root x y-                  | Just (x,y) <- cast (x,y) = unifyPat nm x y-                  | Just (x :: S) <- cast x = Just []-                  | 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 =-  map (rebracket y) <$> unifyExp nm root (fromParen x) (fromParen y)-unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)]-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 (nmOp nm 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--rebracket (Paren l e') (v, e)-  | e' == e = (v, Paren l e)-rebracket e (v, e') = (v, e')---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 . groupSort-    where f (x,ys) = if checkSame ys then Just (x,head ys) else Nothing-          checkSame [] = True-          checkSame (x:xs) = all (x =~=) xs----- 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+    return (res, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst u, ann pos /= an])   --------------------------------------------------------------------- -- SIDE CONDITIONS -checkSide :: Maybe Exp_ -> [(String,Exp_)] -> Bool+checkSide :: Maybe Exp_ -> [(String, Exp_)] -> Bool checkSide x bind = maybe True f x     where         f (InfixApp _ x op y)@@ -290,18 +173,19 @@ -- TRANSFORMATION  -- if it has _eval_ do evaluation on it-performEval :: Exp_ -> Exp_-performEval (App _ e x) | e ~= "_eval_" = reduce x-performEval x = x+performSpecial :: Exp_ -> Exp_+performSpecial = transform fNoParen . fEval+    where+        fEval (App _ e x) | e ~= "_eval_" = reduce x+        fEval x = x +        fNoParen (App _ e x) | e ~= "_noParen_" = fromParen x+        fNoParen 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+unqualify :: Scope -> Scope -> Exp_ -> Exp_+unqualify from to = transformBi f     where-        f (Qual _ (ModuleName _ [m]) x) | Just y <- fromNamed <$> lookup [m] subs-            = if null y then UnQual an x else Qual an (ModuleName an y) x         f x@(UnQual _ (Ident _ s)) | isUnifyVar s = x         f x = scopeMove (from,x) to
src/Hint/Monad.hs view
@@ -11,6 +11,7 @@  <TEST> yes = do mapM print a; return b -- mapM_ print a+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)@@ -29,6 +30,7 @@ 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+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 main = "wait" ~> do f a $ sleep 10 main = f $ do g a $ sleep 10 -- g a $ sleep 10@@ -58,12 +60,14 @@ monadExp :: Decl_ -> (Maybe (Int, Exp_), Exp_) -> [Idea] monadExp decl (parent, x) = case x of         (view -> App2 op x1 x2) | op ~= ">>" -> f x1+        (view -> App2 op x1 (view -> LamConst1 _)) | op ~= ">>=" -> f x1         Do _ xs -> [warn "Redundant return" x (Do an y) rs | Just (y, rs) <- [monadReturn xs]] ++                    [warn "Use join" x (Do an y) rs | Just (y, rs) <- [monadJoin xs ['a'..'z']]] ++                    [warn "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"]                         | [Qualifier _ y] <- [xs], not $ doOperator parent y] ++                    [suggest "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++-                   concat [f x | Qualifier _ x <- init xs]+                   concat [f x | Qualifier _ x <- init xs] +++                   concat [f x | Generator _ (PWildCard _) x <- init xs]         _ -> []     where         f x = [warn ("Use " ++ name) x y r  | Just (name,y, r) <- [monadCall x], fromNamed decl /= name]
src/Language/Haskell/HLint3.hs view
@@ -30,11 +30,11 @@     ) where  import Config.Type-import Config.All+import Config.Read import Idea import Apply import HLint-import Hint.Type+import HSE.All import Hint.All import CmdLine import Paths_hlint
src/Test/All.hs view
@@ -13,7 +13,7 @@ import Prelude  import Config.Type-import Config.All+import Config.Read import CmdLine import HSE.All import Hint.All
src/Util.hs view
@@ -2,11 +2,10 @@  module Util(     defaultExtensions,-    gzip, universeParentBi, descendIndex,+    gzip, universeParentBi,     exitMessage, exitMessageImpure     ) where -import Control.Monad.Trans.State import Data.List import System.Exit import System.IO@@ -44,12 +43,6 @@  --------------------------------------------------------------------- -- 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