module Apply(applyHintFile, applyHintFiles, applyHintString) where
import HSE.All
import Hint.All
import Control.Arrow
import Data.Char
import Data.List
import Data.Maybe
import Data.Ord
import Settings
import Idea
import Util
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]
applyHintString :: ParseFlags -> [Setting] -> FilePath -> String -> IO [Idea]
applyHintString flags s file src = do
res <- parseModuleString 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) <- fmap unzipEither $ mapM (parseModuleFile flags s) files
return $ err ++ executeHints s ms
executeHints :: [Setting] -> [Module_] -> [Idea]
executeHints s ms = concat $
[ map (classify $ s ++ mapMaybe readPragma (moduleDecls m)) $
order "" [i | ModuHint h <- hints, i <- h nm m] ++
concat [order (fromNamed d) [i | h <- decHints, i <- h d] | d <- moduleDecls m]
| (nm,m) <- mns
, let decHints = [h nm m | DeclHint h <- hints]
, let order n = map (\i -> i{func = (moduleName m,n)}) . sortBy (comparing loc)] ++
[map (classify s) $ op mns | CrossHint op <- hints]
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
parseModuleFile :: ParseFlags -> [Setting] -> FilePath -> IO (Either Idea Module_)
parseModuleFile flags s file = do
src <- readFileEncoding (encoding flags) file
parseModuleString flags s file src
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
(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
context :: Int -> String -> String
context lineNo src =
unlines $ trimBy (all isSpace) $
zipWith (++) ticks $ take 5 $ drop (lineNo 3) $ lines src ++ [""]
where ticks = [" "," ","> "," "," "]
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
classify :: [Setting] -> Idea -> Idea
classify xs i = i{severity = foldl' (f i) (severity i) $ filter isClassify xs}
where
f :: Idea -> Severity -> Setting -> Severity
f i r c | matchHint (hintS c) (hint i) && matchFunc (funcS c) (func_ i) = severityS 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