module Apply(applyHints, applyHintFile, applyHintFiles) where
import Control.Applicative
import Data.Monoid
import HSE.All
import Hint.All
import Data.Tuple.Extra
import Data.Either
import Data.List.Extra
import Data.Maybe
import Data.Ord
import Config.Type
import Config.Haskell
import Idea
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_, [Comment])] -> [Idea]
applyHints cls hints_ ms = concat $
[ map (classify $ cls ++ mapMaybe readPragma (universeBi m)) $
order "" (hintModule hints nm m) `merge`
concat [order (fromNamed d) $ decHints d | d <- moduleDecls m] `merge`
concat [order "" $ hintComment hints c | c <- cs]
| (nm,(m,cs)) <- mns
, let decHints = hintDecl hints nm m
, let order n = map (\i -> i{ideaModule=moduleName m, ideaDecl=n}) . sortBy (comparing ideaSpan)
, let merge = mergeBy (comparing ideaSpan)] ++
[map (classify cls) (hintModules hints $ map (second fst) mns)]
where
mns = map (scopeCreate . fst &&& id) ms
hints = (if length ms <= 1 then noModules else id) hints_
noModules h = h{hintModules = const []} `mappend` mempty{hintModule = \a b -> hintModules h [(a,b)]}
executeHints :: [Setting] -> [(Module_, [Comment])] -> [Idea]
executeHints s = applyHints [x | SettingClassify x <- 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) -> do
i <- return $ rawIdeaN Error "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}
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
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 == y