module Apply(applyHints, applyHintFile, applyHintFiles) where
import Control.Applicative
import Data.Monoid
import HSE.All
import Hint.All
import Idea
import Data.Tuple.Extra
import Data.Either
import Data.List.Extra
import Data.Maybe
import Data.Ord
import Config.Type
import Config.Haskell
import qualified Data.HashSet as Set
import Prelude
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]
applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea]
applyHintFiles flags s files = do
(err, ms) <- partitionEithers <$> mapM (\file -> parseModuleApply flags s file Nothing) files
return $ err ++ executeHints s ms
applyHints :: [Classify] -> Hint -> [(Module SrcSpanInfo, [Comment])] -> [Idea]
applyHints cs = applyHintsReal $ map SettingClassify cs
applyHintsReal :: [Setting] -> Hint -> [(Module_, [Comment])] -> [Idea]
applyHintsReal settings hints_ ms = concat $
[ map (classify (cls ++ mapMaybe readPragma (universeBi m) ++ concatMap readComment cs) . removeRequiresExtensionNotes m) $
order [] (hintModule hints settings nm m) `merge`
concat [order [fromNamed d] $ decHints d | d <- moduleDecls m] `merge`
concat [order [] $ hintComment hints settings c | c <- cs]
| (nm,(m,cs)) <- mns
, let decHints = hintDecl hints settings nm m
, let order n = map (\i -> i{ideaModule= f $ moduleName m : ideaModule i, ideaDecl= f $ n ++ ideaDecl i}) . sortOn ideaSpan
, let merge = mergeBy (comparing ideaSpan)] ++
[map (classify cls) (hintModules hints settings $ map (second fst) mns)]
where
f = nubOrd . filter (/= "")
cls = [x | SettingClassify x <- settings]
mns = map (scopeCreate . fst &&& id) ms
hints = (if length ms <= 1 then noModules else id) hints_
noModules h = h{hintModules = \_ _ -> []} `mappend` mempty{hintModule = \s a b -> hintModules h s [(a,b)]}
removeRequiresExtensionNotes :: Module_ -> Idea -> Idea
removeRequiresExtensionNotes m = \x -> x{ideaNote = filter keep $ ideaNote x}
where
exts = Set.fromList $ map fromNamed $ moduleExtensions m
keep (RequiresExtension x) = not $ x `Set.member` exts
keep _ = True
executeHints :: [Setting] -> [(Module_, [Comment])] -> [Idea]
executeHints s = applyHintsReal s (allHints s)
parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea (Module_, [Comment]))
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) ->
return $ Left $ classify [x | SettingClassify x <- s] $ rawIdeaN Error "Parse error" (mkSrcSpan sl sl) ctxt Nothing []
allHints :: [Setting] -> Hint
allHints xs = mconcat $ hintRules [x | SettingMatchExp x <- xs] : map f builtin
where builtin = nubOrd $ 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
classify :: [Classify] -> Idea -> Idea
classify xs i = let s = foldl' (f i) (ideaSeverity i) xs in s `seq` i{ideaSeverity=s}
where
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
x ~= y = null x || x `elem` y