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