1 2module Apply(applyHints, applyHintFile, applyHintFiles) where 3 4import Control.Applicative 5import Data.Monoid 6import GHC.All 7import Hint.All 8import GHC.Util 9import Data.Generics.Uniplate.DataOnly 10import Idea 11import Data.Tuple.Extra 12import Data.Either 13import Data.List.Extra 14import Data.Maybe 15import Data.Ord 16import Config.Type 17import Config.Haskell 18import GHC.Types.SrcLoc 19import GHC.Hs 20import Language.Haskell.GhclibParserEx.GHC.Hs 21import qualified Data.HashSet as Set 22import Prelude 23import Util 24 25 26-- | Apply hints to a single file, you may have the contents of the file. 27applyHintFile :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO [Idea] 28applyHintFile flags s file src = do 29 res <- parseModuleApply flags s file src 30 pure $ case res of 31 Left err -> [err] 32 Right m -> executeHints s [m] 33 34 35-- | Apply hints to multiple files, allowing cross-file hints to fire. 36applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea] 37applyHintFiles flags s files = do 38 (err, ms) <- partitionEithers <$> mapM (\file -> parseModuleApply flags s file Nothing) files 39 pure $ err ++ executeHints s ms 40 41 42-- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's. 43-- The 'Idea' values will be ordered within a file. 44-- 45-- Given a set of modules, it may be faster to pass each to 'applyHints' in a singleton list. 46-- When given multiple modules at once this function attempts to find hints between modules, 47-- which is slower and often pointless (by default HLint passes modules singularly, using 48-- @--cross@ to pass all modules together). 49applyHints {- PUBLIC -} :: [Classify] -> Hint -> [ModuleEx] -> [Idea] 50applyHints cs = applyHintsReal $ map SettingClassify cs 51 52applyHintsReal :: [Setting] -> Hint -> [ModuleEx] -> [Idea] 53applyHintsReal settings hints_ ms = concat $ 54 [ map (classify classifiers . removeRequiresExtensionNotes m) $ 55 order [] (hintModule hints settings nm m) `merge` 56 concat [order (maybeToList $ declName d) $ decHints d | d <- hsmodDecls $ unLoc $ ghcModule m] 57 | (nm,m) <- mns 58 , let classifiers = cls ++ mapMaybe readPragma (universeBi (ghcModule m)) ++ concatMap readComment (ghcComments m) 59 , seq (length classifiers) True -- to force any errors from readPragma or readComment 60 , let decHints = hintDecl hints settings nm m -- partially apply 61 , let order n = map (\i -> i{ideaModule = f $ modName (ghcModule m) : ideaModule i, ideaDecl = f $ n ++ ideaDecl i}) . sortOn (SrcSpanD . ideaSpan) 62 , let merge = mergeBy (comparing (SrcSpanD . ideaSpan))] ++ 63 [map (classify cls) (hintModules hints settings mns)] 64 where 65 f = nubOrd . filter (/= "") 66 cls = [x | SettingClassify x <- settings] 67 mns = map (\x -> (scopeCreate (unLoc $ ghcModule x), x)) ms 68 hints = (if length ms <= 1 then noModules else id) hints_ 69 noModules h = h{hintModules = \_ _ -> []} `mappend` mempty{hintModule = \s a b -> hintModules h s [(a,b)]} 70 71-- If the hint has said you RequiresExtension Foo, but Foo is enabled, drop the note 72removeRequiresExtensionNotes :: ModuleEx -> Idea -> Idea 73removeRequiresExtensionNotes m = \x -> x{ideaNote = filter keep $ ideaNote x} 74 where 75 exts = Set.fromList $ concatMap snd $ languagePragmas $ pragmas $ ghcAnnotations m 76 keep (RequiresExtension x) = not $ x `Set.member` exts 77 keep _ = True 78 79-- | Given a list of settings (a way to classify) and a list of hints, run them over a list of modules. 80executeHints :: [Setting] -> [ModuleEx] -> [Idea] 81executeHints s = applyHintsReal s (allHints s) 82 83 84-- | Return either an idea (a parse error) or the module. In IO because might call the C pre processor. 85parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea ModuleEx) 86parseModuleApply flags s file src = do 87 res <- parseModuleEx (parseFlagsAddFixities [x | Infix x <- s] flags) file src 88 case res of 89 Right r -> pure $ Right r 90 Left (ParseError sl msg ctxt) -> 91 pure $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error (adjustMessage msg) sl ctxt Nothing [] 92 where 93 -- important the message has "Parse error:" as the prefix so "--ignore=Parse error" works 94 -- try and tidy up things like "parse error (mismatched brackets)" to not look silly 95 adjustMessage :: String -> String 96 adjustMessage x = "Parse error: " ++ dropBrackets (dropPrefix "parse error " x) 97 98 dropBrackets ('(':xs) | Just (xs,')') <- unsnoc xs = xs 99 dropBrackets xs = xs 100 101 102-- | Find which hints a list of settings implies. 103allHints :: [Setting] -> Hint 104allHints xs = mconcat $ hintRules [x | SettingMatchExp x <- xs] : map f builtin 105 where builtin = nubOrd $ concat [if x == "All" then map fst builtinHints else [x] | Builtin x <- xs] 106 f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x builtinHints 107 108 109-- | Given some settings, make sure the severity field of the Idea is correct. 110classify :: [Classify] -> Idea -> Idea 111classify xs i = let s = foldl' (f i) (ideaSeverity i) xs in s `seq` i{ideaSeverity=s} 112 where 113 -- figure out if we need to change the severity 114 f :: Idea -> Severity -> Classify -> Severity 115 f i r c | classifyHint c ~~= ideaHint i && classifyModule c ~= ideaModule i && classifyDecl c ~= ideaDecl i = classifySeverity c 116 | otherwise = r 117 x ~= y = x == "" || any (wildcardMatch x) y 118 x ~~= y = x == "" || x == y || ((x ++ ":") `isPrefixOf` y) 119