packages feed

hlint 1.8.56 → 1.8.57

raw patch · 24 files changed

+504/−381 lines, 24 files

Files

CHANGES.txt view
@@ -1,5 +1,8 @@ Changelog for HLint +1.8.57+    #6, add a preview of an API+    #331, improve parse error locations for literate Haskell 1.8.56     Remove support for GHC 6.12 and below     #317, tone down the void hint
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.8.56+version:            1.8.57 license:            BSD3 license-file:       LICENSE category:           Development@@ -47,6 +47,7 @@      hs-source-dirs:     src     exposed-modules:+        Temporary.API         Language.Haskell.HLint     other-modules:         Paths_hlint@@ -65,7 +66,7 @@         HSE.Evaluate         HSE.FreeVars         HSE.Match-        HSE.NameMatch+        HSE.Scope         HSE.Type         HSE.Util         Hint.All
src/Apply.hs view
@@ -1,32 +1,23 @@ -module Apply(applyHintFile, applyHintFiles, applyHintString) where+module Apply(applyHints, applyHintFile, applyHintFiles) where  import HSE.All import Hint.All import Control.Applicative import Control.Arrow-import Data.Char import Data.List import Data.Maybe+import Data.Monoid 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+-- | Apply hints to a single file, you may have the contents of the file.+applyHintFile :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO [Idea]+applyHintFile flags s file src = do+    res <- parseModuleApply flags s file src     return $ case res of         Left err -> [err]         Right m -> executeHints s [m]@@ -35,75 +26,57 @@ -- | Apply hints to multiple files, allowing cross-file hints to fire. applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea] applyHintFiles flags s files = do-    (err, ms) <- unzipEither <$> mapM (parseModuleFile flags s) files+    (err, ms) <- unzipEither <$> mapM (\file -> parseModuleApply flags s file Nothing) 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 (universeBi m)) $-        order "" [i | ModuHint h <- hints, i <- h nm m] ++-        concat [order (fromNamed d) [i | h <- decHints, i <- h d] | d <- moduleDecls m]+-- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's.+--   The 'Idea' values will be ordered within a file.+applyHints :: [Classify] -> Hint -> [Module SrcSpanInfo] -> [Idea]+applyHints cls hints_ ms = concat $+    [ map (classify $ cls ++ mapMaybe readPragma (universeBi m)) $+        order "" (hintModule hints nm m) +++        concat [order (fromNamed d) $ decHints 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]+    , let decHints = hintDecl hints nm m -- partially apply+    , let order n = map (\i -> i{ideaModule=moduleName m, ideaDecl=n}) . sortBy (comparing ideaSpan)] +++    [map (classify cls) (hintModules hints mns)]     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+        mns = map (scopeCreate &&& id) ms+        hints = (if length ms <= 1 then noModules else id) hints_+        noModules h = h{hintModules = \_ -> []} `mappend` mempty{hintModule = \a b -> hintModules h [(a,b)]}  --- | 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+-- | 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 = applyHints [x | SettingClassify x <- s] (allHints s)   -- | 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 = ["  ","  ","> ","  ","  "]+parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea Module_)+parseModuleApply flags s file src = do+    res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src+    case res of+        Right m -> return $ Right m+        Left (ParseError sl msg ctxt) -> do+            i <- return $ rawIdea Warning "Parse error" (mkSrcSpan sl sl) ctxt Nothing []+            i <- return $ classify [x | SettingClassify x <- s] i+            return $ Left i{ideaHint = if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg}   -- | 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+allHints :: [Setting] -> Hint+allHints xs = mconcat $ hintRules [x | SettingMatchExp x <- xs] : map f builtin+    where builtin = nub $ concat [if x == "All" then map fst builtinHints else [x] | Builtin x <- xs]+          f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x builtinHints   -- | 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}+classify :: [Classify] -> Idea -> Idea+classify xs i =  let s = foldl' (f i) (ideaSeverity i) xs in s `seq` i{ideaSeverity=s}     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+        f :: Idea -> Severity -> Classify -> Severity+        f i r c | classifyHint c ~= ideaHint i && classifyModule c ~= ideaModule i && classifyDecl c ~= ideaDecl i = classifySeverity 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
src/CmdLine.hs view
@@ -19,10 +19,11 @@ import Data.Version  +-- | What C pre processor should be used. data CppFlags-    = NoCpp-    | CppSimple-    | Cpphs CpphsOptions+    = NoCpp -- ^ No pre processing is done.+    | CppSimple -- ^ Lines prefixed with @#@ are stripped.+    | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.   -- FIXME: Hints vs GivenHints is horrible@@ -137,7 +138,7 @@             | EnableExtension CPP `elem` languages = Cpphs cpphs             | otherwise = NoCpp -    encoding <- newEncoding $ last $ "" : [x | Encoding x <- opt]+    encoding <- readEncoding $ last $ "" : [x | Encoding x <- opt]      return Cmd         {cmdTest = test
src/HLint.hs view
@@ -29,12 +29,12 @@  -- | From a suggestion, extract the file location it refers to. suggestionLocation :: Suggestion -> SrcLoc-suggestionLocation = loc . fromSuggestion+suggestionLocation = getPointLoc . ideaSpan . fromSuggestion   -- | From a suggestion, determine how severe it is. suggestionSeverity :: Suggestion -> Severity-suggestionSeverity = severity . fromSuggestion+suggestionSeverity = ideaSeverity . fromSuggestion   @@ -49,7 +49,7 @@ hlint :: [String] -> IO [Suggestion] hlint args = do     cmd@Cmd{..} <- getCmd args-    let flags = parseFlags{cppFlags=cmdCpp, encoding=cmdEncoding, language=cmdLanguage}+    let flags = parseFlagsSetExtensions cmdLanguage $ defaultParseFlags{cppFlags=cmdCpp, encoding=cmdEncoding}     if cmdTest then do         failed <- test (void . hlint) cmdDataDir cmdGivenHints         when (failed > 0) exitFailure@@ -60,7 +60,7 @@         mapM_ (proof reps s) cmdProof         return []      else if isNothing cmdFiles && notNull cmdFindHints then-        mapM_ (\x -> putStrLn . fst =<< findSettings flags x) cmdFindHints >> return []+        mapM_ (\x -> putStrLn . fst =<< findSettings2 flags x) cmdFindHints >> return []      else if isNothing cmdFiles then         exitWithHelp      else if cmdFiles == Just [] then@@ -70,9 +70,9 @@  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]+    settings1 <- readSettings2 cmdDataDir cmdHintFiles cmdWithHints+    settings2 <- concatMapM (fmap snd . findSettings2 flags) cmdFindHints+    settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore]     return $ settings1 ++ settings2 ++ settings3  @@ -84,8 +84,8 @@     let files = fromMaybe [] cmdFiles     ideas <- if cmdCross         then applyHintFiles flags settings files-        else concat <$> parallel [listM' =<< applyHintFile flags settings x | x <- files]-    let (showideas,hideideas) = partition (\i -> cmdShowAll || severity i /= Ignore) ideas+        else concat <$> parallel [listM' =<< applyHintFile flags settings x Nothing | x <- files]+    let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas     showItem <- if cmdColor then showANSI else return show     mapM_ (outStrLn . showItem) showideas
src/HSE/All.hs view
@@ -1,8 +1,9 @@+{-# LANGUAGE RecordWildCards #-}  module HSE.All(     module X,-    ParseFlags(..), parseFlags, parseFlagsNoLocations,-    parseFile, parseString, parseResult+    ParseFlags(..), defaultParseFlags, parseFlagsAddFixities, parseFlagsSetExtensions,+    parseModuleEx, ParseError(..)     ) where  import HSE.Util as X@@ -10,32 +11,41 @@ import HSE.Type as X import HSE.Bracket as X import HSE.Match as X-import HSE.NameMatch as X+import HSE.Scope as X import HSE.FreeVars as X import Util import CmdLine-import Control.Applicative+import Control.Exception+import Data.Char import Data.List import Data.Maybe import Language.Preprocessor.Cpphs import qualified Data.Map as Map  +-- | Created with 'defaultParseFlags', used by 'parseModuleEx'. data ParseFlags = ParseFlags-    {cppFlags :: CppFlags-    ,language :: [Extension]-    ,encoding :: Encoding-    ,infixes :: [Fixity]+    {encoding :: Encoding -- ^ How the file is read in (defaults to 'defaultEncoding').+    ,cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').+    ,hseFlags :: ParseMode -- ^ How the file is parsed (defaults to all fixities in the @base@ package and most non-conflicting extensions).     } -parseFlags :: ParseFlags-parseFlags = ParseFlags NoCpp defaultExtensions defaultEncoding []+-- | Default values for 'ParseFlags'.+defaultParseFlags :: ParseFlags+defaultParseFlags = ParseFlags defaultEncoding NoCpp defaultParseMode{fixities=Just baseFixities, ignoreLinePragmas=False, extensions=defaultExtensions}  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}} +parseFlagsAddFixities :: [Fixity] -> ParseFlags -> ParseFlags+parseFlagsAddFixities fx x = x{hseFlags=hse{fixities = Just $ fx ++ fromMaybe [] (fixities hse)}}+    where hse = hseFlags x +parseFlagsSetExtensions :: [Extension] -> ParseFlags -> ParseFlags+parseFlagsSetExtensions es x = x{hseFlags=(hseFlags x){extensions = es}}++ 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]@@ -45,32 +55,44 @@ --------------------------------------------------------------------- -- PARSING --- | Parse a Haskell module-parseString :: ParseFlags -> FilePath -> String -> IO (String, ParseResult Module_)-parseString flags file str = do+-- | A parse error from 'parseModuleEx'.+data ParseError = ParseError+    {parseErrorLocation :: SrcLoc -- ^ Location of the error.+    ,parseErrorMessage :: String -- ^ Message about the cause of the error.+    ,parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line.+    }++-- | Parse a Haskell module. Applies the C pre processor, and uses best-guess fixity resolution if there are ambiguities.+--   The filename @-@ is treated as @stdin@. Requires some flags (often 'defaultParseFlags'), the filename, and optionally the contents of that file.+parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo))+parseModuleEx flags file str = do+        str <- maybe (readFileEncoding (encoding flags) file) return str         ppstr <- runCpp (cppFlags flags) file str-        return (ppstr, applyFixity fixity <$> parseFileContentsWithMode mode ppstr)+        case parseFileContentsWithMode (mode flags) ppstr of+            ParseOk x -> return $ Right $ applyFixity fixity x+            ParseFailed sl msg -> do+                -- figure out the best line number to grab context from, by reparsing+                flags <- return $ parseFlagsNoLocations flags+                ppstr2 <- runCpp (cppFlags flags) file str+                pe <- return $ case parseFileContentsWithMode (mode flags) ppstr2 of+                    ParseFailed sl2 _ -> context (srcLine sl2) ppstr2+                    _ -> context (srcLine sl) ppstr+                Control.Exception.evaluate $ length pe -- if we fail to parse, we may be keeping the file handle alive+                return $ Left $ ParseError sl msg pe     where-        fixity = infixes flags ++ baseFixities-        mode = defaultParseMode+        fixity = fromMaybe [] $ fixities $ hseFlags flags+        mode flags = (hseFlags flags)             {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+-- | 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 = ["  ","  ","> ","  ","  "]   ---------------------------------------------------------------------
− src/HSE/NameMatch.hs 
@@ -1,101 +0,0 @@--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
+ src/HSE/Scope.hs view
@@ -0,0 +1,104 @@++module HSE.Scope(+    Scope, scopeCreate, scopeImports,+    scopeMatch, scopeMove+    ) where++import HSE.Type+import HSE.Util+import Data.List+import Data.Maybe+import Data.Monoid++{-+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+-}+++-- | Data type representing the modules in scope within a module.+--   Created with 'scopeCreate' and queried with 'scopeMatch' and 'scopeMove'.+newtype Scope = Scope [ImportDecl S]+             deriving Show++instance Monoid Scope where+    mempty = Scope []+    mappend (Scope xs) (Scope ys) = Scope $ xs ++ ys++-- | Create a 'Scope' value from a module, based on the modules imports.+scopeCreate :: Module SrcSpanInfo -> Scope+scopeCreate 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"+++scopeImports :: Scope -> [ImportDecl S]+scopeImports (Scope x) = x++++-- | Given a two names in scopes, could they possibly refer to the same thing.+--   This property is reflexive.+scopeMatch :: (Scope, QName SrcSpanInfo) -> (Scope, QName SrcSpanInfo) -> Bool+scopeMatch (a, x@Special{}) (b, y@Special{}) = x =~= y+scopeMatch (a, x) (b, y) | isSpecial x || isSpecial y = False+scopeMatch (a, x) (b, y) = unqual x =~= unqual y && not (null $ possModules a x `intersect` possModules b y)+++-- | Given a name in a scope, and a new scope, create a name for the new scope that will refer+--   to the same thing. If the resulting name is ambiguous, it picks a plausible candidate.+scopeMove :: (Scope, QName SrcSpanInfo) -> Scope -> QName SrcSpanInfo+scopeMove (a, x) (Scope b)+    | 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
src/HSE/Type.hs view
@@ -3,7 +3,7 @@  -- 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.Annotated as Export hiding (parse, loc, paren, Assoc(..)) import Language.Haskell.Exts as Export(Assoc(..)) import Data.Generics.Uniplate.Data as Export
src/HSE/Util.hs view
@@ -261,11 +261,17 @@           f (x:xs) = x : f xs           f [] = [] -toSrcLoc :: SrcInfo si => si -> SrcLoc+toSrcLoc :: SrcSpanInfo -> SrcLoc toSrcLoc = getPointLoc +toSrcSpan :: SrcSpanInfo -> SrcSpan+toSrcSpan (SrcSpanInfo x _) = x+ nullSrcLoc :: SrcLoc nullSrcLoc = SrcLoc "" 0 0++nullSrcSpan :: SrcSpan+nullSrcSpan = mkSrcSpan nullSrcLoc nullSrcLoc  an :: SrcSpanInfo an = toSrcInfo nullSrcLoc [] nullSrcLoc
src/Hint/All.hs view
@@ -1,10 +1,11 @@  module Hint.All(     Hint(..), DeclHint, ModuHint,-    staticHints, dynamicHints+    builtinHints, hintRules     ) where  import Settings+import Data.Monoid import Hint.Type  import Hint.Match@@ -21,8 +22,9 @@ import Hint.Duplicate  -staticHints :: [(String,Hint)]-staticHints =+-- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@.+builtinHints :: [(String,Hint)]+builtinHints =     ["List"       ! listHint     ,"ListRec"    ! listRecHint     ,"Monad"      ! monadHint@@ -36,9 +38,10 @@     ,"Duplicate"  * duplicateHint     ]     where-        x!y = (x,DeclHint y)-        x+y = (x,ModuHint y)-        x*y = (x,CrossHint y)+        x!y = (x,mempty{hintDecl=y})+        x+y = (x,mempty{hintModule=y})+        x*y = (x,mempty{hintModules=y}) -dynamicHints :: [Setting] -> Hint-dynamicHints = DeclHint . readMatch+-- | Transform a list of 'HintRule' into a 'Hint'.+hintRules :: [HintRule] -> Hint+hintRules xs = mempty{hintDecl=readMatch xs}
src/Hint/Duplicate.hs view
@@ -36,8 +36,8 @@         (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]+        (Just $ "Combine with " ++ showSrcLoc (getPointLoc p2)) []+    | (p1,p2,xs) <- duplicateOrdered 3 $ map (map (toSrcSpan . ann &&& dropAnn)) ys]   ---------------------------------------------------------------------@@ -59,8 +59,8 @@     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+duplicateOrdered :: Ord val => Int -> [[(SrcSpan,val)]] -> [(SrcSpan,SrcSpan,[val])]+duplicateOrdered threshold xs = concat $ concat $ snd $ mapAccumL f (Dupe nullSrcSpan 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
@@ -70,8 +70,8 @@   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)+extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" (toSrcSpan sl)+          (prettyPrint o) (Just $ 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
src/Hint/Import.hs view
@@ -57,7 +57,7 @@   wrap :: [ImportDecl S] -> [Idea]-wrap o = [ rawIdea Error "Use fewer imports" (toSrcLoc $ ann $ head o) (f o) (f x) []+wrap o = [ rawIdea Error "Use fewer imports" (toSrcSpan $ ann $ head o) (f o) (Just $ f x) []          | Just x <- [simplify o]]     where f = unlines . map prettyPrint @@ -122,8 +122,8 @@ -- 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)+    = [rawIdea Warning "Use hierarchical imports" (toSrcSpan $ ann i) (ltrim $ prettyPrint i) (+          Just $ 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}@@ -139,9 +139,9 @@  multiExport :: Module S -> [Idea] multiExport x =-    [ rawIdea Warning "Use import/export shortcut" (toSrcLoc $ ann hd)+    [ rawIdea Warning "Use import/export shortcut" (toSrcSpan $ ann hd)         (unlines $ prettyPrint hd : map prettyPrint imps)-        (unlines $ prettyPrint newhd : map prettyPrint newimps)+        (Just $ unlines $ prettyPrint newhd : map prettyPrint newimps)         []     | Module l (Just hd) _ imp _ <- [x]     , let asNames = mapMaybe importAs imp
src/Hint/Match.hs view
@@ -58,25 +58,24 @@ --------------------------------------------------------------------- -- READ THE RULE -readMatch :: [Setting] -> DeclHint+readMatch :: [HintRule] -> 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 /= [] && Set.notMember v1 (freeVars $ maybeToList side ++ l ++ r)+readRule :: HintRule -> [HintRule]+readRule (m@HintRule{hintRuleLHS=(fmapAn -> hintRuleLHS), hintRuleRHS=(fmapAn -> hintRuleRHS), hintRuleSide=(fmap fmapAn -> hintRuleSide)}) =+    (:) m{hintRuleLHS=hintRuleLHS,hintRuleSide=hintRuleSide,hintRuleRHS=hintRuleRHS} $ fromMaybe [] $ do+        (l,v1) <- dotVersion hintRuleLHS+        (r,v2) <- dotVersion hintRuleRHS+        guard $ v1 == v2 && l /= [] && Set.notMember v1 (freeVars $ maybeToList hintRuleSide ++ l ++ r)         if r /= [] then return-            [m{lhs=dotApps l, rhs=dotApps r, side=side}-            ,m{lhs=dotApps (l++[toNamed v1]), rhs=dotApps (r++[toNamed v1]), side=side}]+            [m{hintRuleLHS=dotApps l, hintRuleRHS=dotApps r, hintRuleSide=hintRuleSide}+            ,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=dotApps (r++[toNamed v1]), hintRuleSide=hintRuleSide}]          else if length l > 1 then return-            [m{lhs=dotApps l, rhs=toNamed "id", side=side}-            ,m{lhs=dotApps (l++[toNamed v1]), rhs=toNamed v1, side=side}]+            [m{hintRuleLHS=dotApps l, hintRuleRHS=toNamed "id", hintRuleSide=hintRuleSide}+            ,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=toNamed v1, hintRuleSide=hintRuleSide}]          else             Nothing-readRule _ = []   -- find a dot version of this rule, return the sequence of app prefixes, and the var@@ -89,30 +88,32 @@ --------------------------------------------------------------------- -- PERFORM THE MATCHING -findIdeas :: [Setting] -> Scope -> Module S -> Decl_ -> [Idea]+findIdeas :: [HintRule] -> Scope -> Module S -> Decl_ -> [Idea] findIdeas matches s _ decl =-  [ (idea (severityS m) (hintS m) x y){note=notes}+  [ (idea (hintRuleSeverity m) (hintRuleName m) x y){ideaNote=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+matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_,[Note])+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-    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+    let e = subst u hintRuleRHS+    let res = addBracket parent $ unqualify hintRuleScope s u $ performEval e+    guard $ (freeVars e Set.\\ freeVars hintRuleRHS) `Set.isSubsetOf` freeVars x -- check no unexpected new free variables+    guard $ checkSide hintRuleSide $ ("original",x) : ("result",res) : u     guard $ checkDefine decl parent res-    return (res,notes)+    return (res,hintRuleNotes)   --------------------------------------------------------------------- -- UNIFICATION +type NameMatch = QName S -> QName S -> Bool+ -- 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)@@ -247,7 +248,7 @@     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 = nameQualify from to x+        f x = scopeMove (from,x) to   addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_
src/Hint/Pragma.hs view
@@ -41,7 +41,7 @@   pragmaIdea :: [ModulePragma S] -> [ModulePragma S] -> Idea-pragmaIdea xs ys = rawIdea Error "Use better pragmas" (toSrcLoc $ ann $ head xs) (f xs) (f ys) []+pragmaIdea xs ys = rawIdea Error "Use better pragmas" (toSrcSpan $ ann $ head xs) (f xs) (Just $ f ys) []     where f = unlines . map prettyPrint
src/Hint/Type.hs view
@@ -3,12 +3,22 @@  import HSE.All import Idea+import Data.Monoid   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}+-- | Functions to generate hints, combined using the 'Monoid' instance.+data Hint = Hint+    {hintModules :: [(Scope, Module SrcSpanInfo)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.+    ,hintModule :: Scope -> Module SrcSpanInfo -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.+    ,hintDecl :: Scope -> Module SrcSpanInfo -> Decl SrcSpanInfo -> [Idea]+        -- ^ Given a declaration (with a module and scope) generate some 'Idea's.+        --   This function will be partially applied with one module/scope, then used on multiple 'Decl' values.+    }++instance Monoid Hint where+    mempty = Hint (\_ -> []) (\_ _ -> []) (\_ _ _ -> [])+    mappend (Hint x1 x2 x3) (Hint y1 y2 y3) = Hint (\a -> x1 a ++ y1 a) (\a b -> x2 a b ++ y2 a b) (\a b c -> x3 a b c ++ y3 a b c)
src/Idea.hs view
@@ -9,13 +9,18 @@ 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+-- | An idea suggest by a 'Hint'.+data Idea = Idea+    {ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints.+    ,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name.+    ,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'.+    ,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@.+    ,ideaSpan :: SrcSpan -- ^ The source code the idea relates to.+    ,ideaFrom :: String -- ^ The contents of the source code the idea relates to.+    ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).+    ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.+    }+    deriving (Eq,Ord)   instance Show Idea where@@ -29,20 +34,18 @@  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 /= ""]+    [showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint] +++    f "Found" (Just ideaFrom) ++ f "Why not" ideaTo +++    ["Note: " ++ n | let n = showNotes ideaNote, n /= ""]     where-        f msg x | null xs = [msg ++ " remove it."]-                | otherwise = (msg ++ ":") : map ("  "++) xs+        f msg Nothing = []+        f msg (Just 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) []+rawIdea = Idea "" ""+idea severity hint from to = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) []     where f = ltrim . prettyPrint warn = idea Warning err = idea Error
src/Proof.hs view
@@ -16,7 +16,7 @@   data Theorem = Theorem-    {original :: Maybe Setting+    {original :: Maybe HintRule     ,location :: String     ,lemma :: String     }@@ -26,7 +26,7 @@  instance Show Theorem where     show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n"-        where f MatchExp{..} = "(* " ++ prettyPrint lhs ++ " ==> " ++ prettyPrint rhs ++ " *)\n"+        where f HintRule{..} = "(* " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS ++ " *)\n"  proof :: [FilePath] -> [Setting] -> FilePath -> IO () proof reports hints thy = do@@ -74,10 +74,10 @@  -- | 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 Theorem{original = Just HintRule{..}}+    | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "case"+    | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "list-comp"+    | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name SrcSpanInfo) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v classifyMissing _ = "?unknown"  @@ -111,7 +111,7 @@   reparen :: Setting -> Setting-reparen m@MatchExp{..} = m{lhs = f False lhs, rhs = f True rhs}+reparen (SettingMatchExp m@HintRule{..}) = SettingMatchExp m{hintRuleLHS = f False hintRuleLHS, hintRuleRHS = f True hintRuleRHS}     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@@ -121,8 +121,8 @@ -- 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]+    [ Theorem (Just m) (loc $ ann hintRuleLHS) $ maybe "" assumes hintRuleSide ++ relationship hintRuleNotes a b+    | SettingMatchExp m@HintRule{..} <- map reparen xs, let a = exp1 $ typeclasses hintRuleNotes hintRuleLHS, let b = exp1 hintRuleRHS, a /= b]     where         loc (SrcSpanInfo (SrcSpan file ln _ _ _) _) = takeFileName file ++ ":" ++ show ln @@ -132,7 +132,7 @@         pre = flip elem $ words "eq neq dollar dollarBang"         cons = subs "True=TT False=FF" -        typeclasses notes x = foldr f x notes+        typeclasses hintRuleNotes x = foldr f x hintRuleNotes             where                 f (ValidInstance cls var) x = evalState (transformM g x) True                     where g v@Var{} | v ~= var = do@@ -141,8 +141,8 @@                           g v = return v :: State Bool Exp_                 f _  x = x -        relationship notes a b | any lazier notes = a ++ " \\<sqsubseteq> " ++ b-                               | DecreasesLaziness `elem` notes = b ++ " \\<sqsubseteq> " ++ a+        relationship hintRuleNotes a b | any lazier hintRuleNotes = a ++ " \\<sqsubseteq> " ++ b+                               | DecreasesLaziness `elem` hintRuleNotes = b ++ " \\<sqsubseteq> " ++ a                                | otherwise = a ++ " = " ++ b             where lazier IncreasesLaziness = True                   lazier RemovesError{} = True
src/Report.hs view
@@ -27,15 +27,15 @@     where         generateIds :: [String] -> [(String,Int)] -- sorted by name         generateIds = map (head &&& length) . group . sort-        files = generateIds $ map (srcFilename . loc) ideas+        files = generateIds $ map (srcSpanFilename . ideaSpan) ideas         hints = generateIds $ map hintName ideas-        hintName x = show (severity x) ++ ": " ++ hint x+        hintName x = show (ideaSeverity x) ++ ": " ++ ideaHint 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)+        getClass i = "hint" ++ f hints (hintName i) ++ " file" ++ f files (srcSpanFilename $ ideaSpan i)             where f xs x = show $ fromJust $ findIndex ((==) x . fst) xs          list mode xs = zipWith f [0..] xs@@ -51,23 +51,15 @@ writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} =     ["<div class=" ++ show cls ++ ">"-    ,escapeHTML (showSrcLoc loc ++ ": " ++ show severity ++ ": " ++ hint) ++ "<br/>"+    ,escapeHTML (showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "<br/>"     ,"Found<br/>"-    ,code from-    ,"Why not" ++ (if to == "" then " remove it." else "") ++ "<br/>"-    ,code to-    ,let n = showNotes note in if n /= "" then "<span class='note'>Note: " ++ n ++ "</span>" else ""-    ,"</div>"-    ,""]---writeIdea cls ParseError{..} =-    ["<div class=" ++ show cls ++ ">"-    ,escapeHTML (showSrcLoc loc ++ ": " ++ show severity ++ ": " ++ hint) ++ "<br/>"-    ,"Error message<br/>"-    ,"<pre>" ++ escapeHTML msg ++ "</pre>"-    ,"Code<br/>"-    ,code from+    ,code ideaFrom] +++    (case ideaTo of+        Nothing -> []+        Just to ->+            ["Why not" ++ (if to == "" then " remove it." else "") ++ "<br/>"+            ,code to]) +++    [let n = showNotes ideaNote in if n /= "" then "<span class='note'>Note: " ++ n ++ "</span>" else ""     ,"</div>"     ,""]
src/Settings.hs view
@@ -1,26 +1,30 @@-{-# LANGUAGE PatternGuards, ViewPatterns #-}+{-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards #-}  module Settings(-    Severity(..), Note(..), showNotes, FuncName, Setting(..), isClassify, isMatchExp,+    Severity(..), Classify(..), HintRule(..), Note(..), showNotes, Setting(..),     defaultHintName, isUnifyVar,-    readSettings, readPragma, findSettings+    findSettings, readSettings,+    readSettings2, readPragma, findSettings2     ) where  import HSE.All+import Control.Monad import Data.Char import Data.List+import Data.Monoid import System.FilePath import Util  +defaultHintName :: String defaultHintName = "Use alternative"  --- | How severe an error is.+-- | How severe an issue is. data Severity-    = Ignore -- ^ Ignored errors are only returned when @--show@ is passed.+    = Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas).     | 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.+    | Error -- ^ Errors are suggestions that are nearly always a good idea to apply.       deriving (Eq,Ord,Show,Read,Bounded,Enum)  getSeverity :: String -> Maybe Severity@@ -32,29 +36,26 @@ 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}+addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"]   --------------------------------------------------------------------- -- TYPE +-- | A note describing the impact of the replacement. data Note-    = IncreasesLaziness-    | DecreasesLaziness-    | RemovesError String -- RemovesError "on []", RemovesError "when x is negative"-    | ValidInstance String String -- ValidInstance "Eq" "x"-    | Note String+    = IncreasesLaziness -- ^ The replacement is increases laziness, for example replacing @reverse (reverse x)@ with @x@ makes the code lazier.+    | DecreasesLaziness -- ^ The replacement is decreases laziness, for example replacing @(fst x, snd x)@ with @x@ makes the code stricter.+    | RemovesError String -- ^ The replacement removes errors, for example replacing @foldr1 (+)@ with @sum@ removes an error on @[]@, and might contain the text @\"on []\"@.+    | ValidInstance String String -- ^ The replacement assumes standard type class lemmas, a hint with the note @ValidInstance \"Eq\" \"x\"@ might only be valid if+                                  --   the @x@ variable has a reflexive @Eq@ instance.+    | Note String -- ^ An arbitrary note.       deriving (Eq,Ord)  instance Show Note where@@ -70,56 +71,100 @@     where use ValidInstance{} = False -- Not important enough to tell an end user           use _ = True +-- | How to classify an 'Idea'. If any matching field is @\"\"@ then it matches everything.+data Classify = Classify+    {classifySeverity :: Severity -- ^ Severity to set the 'Idea' to.+    ,classifyHint :: String -- ^ 'ideaHint'.+    ,classifyModule :: String -- ^ 'ideaModule'.+    ,classifyDecl :: String -- ^ 'ideaDecl'.+    }+    deriving Show +-- | A @LHS ==> RHS@ style hint rule.+data HintRule = HintRule+    {hintRuleSeverity :: Severity -- ^ Default severity for the hint.+    ,hintRuleName :: String -- ^ Name for the hint.+    ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates.+    ,hintRuleLHS :: Exp SrcSpanInfo -- ^ LHS+    ,hintRuleRHS :: Exp SrcSpanInfo -- ^ RHS+    ,hintRuleSide :: Maybe (Exp SrcSpanInfo) -- ^ Side condition, typically specified with @where _ = ...@.+    ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.+    }+    deriving Show+ 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]}+    = SettingClassify Classify+    | SettingMatchExp HintRule     | 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+readSettings2 :: FilePath -> [FilePath] -> [String] -> IO [Setting]+readSettings2 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 $-                    [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m-    return $ map Builtin builtin ++ concatMap f mods+    return $ map Builtin builtin ++ concatMap moduleSettings_ mods +moduleSettings_ :: Module SrcSpanInfo -> [Setting]+moduleSettings_ m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $+                       [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m --- Read a hint file, and all hint files it imports+-- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions.+--   Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception.+readSettings :: Module SrcSpanInfo -> ([Classify], [HintRule])+readSettings m = ([x | SettingClassify x <- xs], [x | SettingMatchExp x <- xs])+    where xs = moduleSettings_ m++ 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+readHints datadir x = do+    (builtin,errs,ms) <- case x of+        Left src -> findSettings datadir "CommandLine" (Just src)+        Right file -> findSettings datadir file Nothing+    forM_ errs $ \(ParseError sl msg _) -> return $! fromParseResult $ ParseFailed sl msg+    return $ map Left builtin ++ map Right ms+++-- | Given the data directory (where the @hlint@ data files reside), and a filename to read, and optionally that file's+--   contents, produce a triple containing:+--+-- 1. Builtin hints to use, e.g. @"List"@, which should be resolved using 'builtinHints'.+--+-- 1. A list of parse errors produced while parsing settings files.+--+-- 1. A list of modules containing hints, suitable for processing with 'readSettings'.+findSettings :: FilePath -> FilePath -> Maybe String -> IO ([String], [ParseError], [Module SrcSpanInfo])+findSettings dataDir file contents = do+    let flags = addInfix defaultParseFlags+    res <- parseModuleEx flags file contents+    case res of+        Left err -> return ([], [err], [])+        Right m -> do+            ys <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]]+            return $ concat3 $ ([],[],[m]) : 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"+        f x | Just x <- "HLint.Builtin." `stripPrefix` x = return ([x],[],[])+            | Just x <- "HLint." `stripPrefix` x = findSettings dataDir (dataDir </> x <.> "hs") Nothing+            | otherwise = findSettings dataDir (x <.> "hs") Nothing   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]+        [SettingMatchExp $ HintRule severity (headDef defaultHintName names) s (fromParen lhs) (fromParen rhs) a b]+    | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod]     where         names = filter notNull $ getNames pats bod         names2 = ["" | null names] ++ names  readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = []-readSetting s (AnnPragma _ x) | Just y <- readPragma x = [y]+readSetting s (AnnPragma _ x) | Just y <- readPragma x = [SettingClassify 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]@@ -128,7 +173,7 @@   -- return Nothing if it is not an HLint pragma, otherwise all the settings-readPragma :: Annotation S -> Maybe Setting+readPragma :: Annotation S -> Maybe Classify readPragma o = case o of     Ann _ name x -> f (fromNamed name) x     TypeAnn _ name x -> f (fromNamed name) x@@ -137,7 +182,7 @@         f 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)+                    Just severity -> Just $ Classify severity (ltrim b) "" name             where (a,b) = break isSpace $ ltrim $ drop 6 s         f name (Paren _ x) = f name x         f name (ExpTypeSig _ x _) = f name x@@ -167,7 +212,7 @@   -- Note: Foo may be ("","Foo") or ("Foo",""), return both-readFuncs :: Exp_ -> [FuncName]+readFuncs :: Exp_ -> [(String, String)] readFuncs (App _ x y) = readFuncs x ++ readFuncs y readFuncs (Lit _ (String _ "" _)) = [("","")] readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)]@@ -200,16 +245,16 @@ -- 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 ->+findSettings2 :: ParseFlags -> FilePath -> IO (String, [Setting])+findSettings2 flags file = do+    x <- parseModuleEx flags file Nothing+    case x of+        Left (ParseError sl msg _) ->             return ("-- Parse error " ++ showSrcLoc sl ++ ": " ++ msg, [])-        ParseOk m -> do+        Right 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+                r = concatMap (readSetting mempty) xs             return (s,r)
+ src/Temporary/API.hs view
@@ -0,0 +1,40 @@++-- | /WARNING: This module represents the evolving API of HLint, do not use./+--+--   This module provides a way to apply HLint hints. To replicate the full @hlint@ experience you would:+--+-- 1. Use 'findSettings' to find and load the HLint settings files.+--+-- 1. Use 'readSettings' to interpret the settings files, producing 'HintRule' values (@LHS ==> RHS@ replacements)+--   and 'Classify' values to assign 'Severity' ratings to hints.+--+-- 1. Use 'builtinHints' and 'hintRules' to generate a 'Hint' value.+--+-- 1. Use 'parseModuleEx' to parse the input files, using any fixity declarations from 'findSettings'.+--+-- 1. Use 'applyHints' to execute the hints on the modules, generating 'Idea's.+module Temporary.API(+    applyHints,+    -- * Idea data type+    Idea(..), Severity(..), Note(..),+    -- * Settings+    Classify(..),+    findSettings, readSettings,+    -- * Hints+    Hint(..), builtinHints,+    HintRule(..), hintRules,+    -- * Scopes+    Scope, scopeCreate, scopeMatch, scopeMove,+    -- * Haskell-src-exts+    parseModuleEx, defaultParseFlags, ParseError(..), ParseFlags(..), CppFlags(..),+    -- * File encodings+    Encoding, defaultEncoding, readEncoding, useEncoding+    ) where++import Settings+import Idea+import Apply+import Hint.Type+import Hint.All+import Util+import CmdLine
src/Test.hs view
@@ -66,7 +66,7 @@  testHintFile :: FilePath -> FilePath -> IO Result testHintFile dataDir file = do-    hints <- readSettings dataDir [file] []+    hints <- readSettings2 dataDir [file] []     res <- results $ sequence $ nameCheckHints hints : checkAnnotations hints file :                                 [typeCheckHints hints | takeFileName file /= "Test.hs"]     progress@@ -75,7 +75,7 @@  testSourceFiles :: IO Result testSourceFiles = mconcat <$> sequence-    [checkAnnotations [Builtin name] ("src/Hint" </> name <.> "hs") | (name,h) <- staticHints]+    [checkAnnotations [Builtin name] ("src/Hint" </> name <.> "hs") | (name,h) <- builtinHints]   testInputOutput :: ([String] -> IO ()) -> IO Result@@ -89,12 +89,12 @@  nameCheckHints :: [Setting] -> IO Result nameCheckHints hints = do-    let bad = [failed ["No name for the hint " ++ prettyPrint (lhs x)] | x@MatchExp{} <- hints, hintS x == defaultHintName]+    let bad = [failed ["No name for the hint " ++ prettyPrint (hintRuleLHS x)] | SettingMatchExp x@HintRule{} <- hints, hintRuleName x == defaultHintName]     sequence_ bad     return $ Result (length bad) 0  --- | Given a set of hints, do all the MatchExp hints type check+-- | Given a set of hints, do all the HintRule hints type check typeCheckHints :: [Setting] -> IO Result typeCheckHints hints = bracket     (openTempFile "." "hlinttmp.hs")@@ -106,7 +106,7 @@         progress         return $ result $ res == ExitSuccess     where-        matches = filter isMatchExp hints+        matches = [x | SettingMatchExp x <- hints]          -- Hack around haskell98 not being compatible with base anymore         hackImport i@ImportDecl{importAs=Just a,importModule=b}@@ -115,14 +115,14 @@          contents =             ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"] ++-            concat [map (prettyPrint . hackImport) $ scopeImports $ scope x | x <- take 1 matches] +++            concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope 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)+            | (i, HintRule _ _ _ 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]@@ -144,12 +144,12 @@     return $ Result (length failures) (length tests)     where         f (Test loc inp out) = do-            ideas <- applyHintString parseFlags setting file inp+            ideas <- applyHintFile defaultParseFlags setting file $ Just 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)) &&+                              isJust (ideaTo $ head ideas) && -- detects parse failure                               match x (head ideas)             return $                 [failed $@@ -164,12 +164,12 @@                     ,"SRC: " ++ showSrcLoc loc                     ,"INPUT: " ++ inp                     ,"OUTPUT: " ++ show i]-                    | i@Idea{loc=SrcLoc{..}} <- ideas, srcFilename == "" || srcLine == 0 || srcColumn == 0]+                    | i@Idea{..} <- ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]          match "???" _ = True-        match x y | "@" `isPrefixOf` x = a == show (severity y) && match (ltrim b) y+        match x y | "@" `isPrefixOf` x = a == show (ideaSeverity y) && match (ltrim b) y             where (a,b) = break isSpace $ tail x-        match x y = on (==) norm (to y) x+        match x y = on (==) norm (fromMaybe "" $ ideaTo y) x          -- FIXME: Should use a better check for expected results         norm = filter $ \x -> not (isSpace x) && x /= ';'@@ -213,7 +213,7 @@         else if has "lhs" then return ["tests/" ++ pre <.> "lhs"]         else error "checkInputOutput, couldn't find or figure out flags" -    got <- fmap lines $ captureOutput $+    got <- fmap (map rtrim . lines) $ captureOutput $         handle (\(e::SomeException) -> print e) $         handle (\(e::ExitCode) -> return ()) $         main flags
src/Util.hs view
@@ -90,6 +90,9 @@ ltrim :: String -> String ltrim = dropWhile isSpace +rtrim :: String -> String+rtrim = reverse . ltrim . reverse+ trimBy :: (a -> Bool) -> [a] -> [a] trimBy f = reverse . dropWhile f . reverse . dropWhile f @@ -120,31 +123,48 @@ swap :: (a,b) -> (b,a) swap (a,b) = (b,a) +fst3 :: (a,b,c) -> a+fst3 (a,b,c) = a +snd3 :: (a,b,c) -> b+snd3 (a,b,c) = b++thd3 :: (a,b,c) -> c+thd3 (a,b,c) = c++concat3 :: [([a],[b],[c])] -> ([a],[b],[c])+concat3 xs = (concatMap fst3 xs, concatMap snd3 xs, concatMap thd3 xs)+ --------------------------------------------------------------------- -- SYSTEM.IO --- | An encoding is a function to change a handle to a particular encoding+-- | An 'Encoding' represents how characters are stored in a file. Created with+--   'defaultEncoding' or 'readEncoding' and used with 'useEncoding'. data Encoding = Encoding_Internal (Maybe (Handle -> IO ())) +-- | The system default encoding. defaultEncoding :: Encoding defaultEncoding = Encoding_Internal Nothing +-- | Apply an encoding to a 'Handle'.+useEncoding :: Handle -> Encoding -> IO ()+useEncoding h (Encoding_Internal x) = maybe (return ()) ($ h) x  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+readFileEncoding enc file = do+    h <- if file == "-" then return stdin else openFile file ReadMode+    useEncoding h enc+    hGetContents h  +-- | Create an encoding from a string, or throw an error if the encoding is not known.+--   Accepts many encodings including @locale@, @utf-8@ and all those supported by the+--   GHC @mkTextEncoding@ function.+readEncoding :: String -> IO Encoding -- 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-newEncoding enc+readEncoding "" = return defaultEncoding+readEncoding 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)