module Apply(applyHints, applyHintFile, applyHintFiles) where
import Control.Applicative
import Data.Monoid
import GHC.All
import Hint.All
import GHC.Util
import Data.Generics.Uniplate.DataOnly
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 GHC.Types.SrcLoc
import GHC.Hs
import Language.Haskell.GhclibParserEx.GHC.Hs
import qualified Data.HashSet as Set
import Prelude
import Util
applyHintFile :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO [Idea]
applyHintFile :: ParseFlags -> [Setting] -> FilePath -> Maybe FilePath -> IO [Idea]
applyHintFile ParseFlags
flags [Setting]
s FilePath
file Maybe FilePath
src = do
Either Idea ModuleEx
res <- ParseFlags
-> [Setting]
-> FilePath
-> Maybe FilePath
-> IO (Either Idea ModuleEx)
parseModuleApply ParseFlags
flags [Setting]
s FilePath
file Maybe FilePath
src
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either Idea ModuleEx
res of
Left Idea
err -> [Idea
err]
Right ModuleEx
m -> [Setting] -> [ModuleEx] -> [Idea]
executeHints [Setting]
s [ModuleEx
m]
applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea]
applyHintFiles :: ParseFlags -> [Setting] -> [FilePath] -> IO [Idea]
applyHintFiles ParseFlags
flags [Setting]
s [FilePath]
files = do
([Idea]
err, [ModuleEx]
ms) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\FilePath
file -> ParseFlags
-> [Setting]
-> FilePath
-> Maybe FilePath
-> IO (Either Idea ModuleEx)
parseModuleApply ParseFlags
flags [Setting]
s FilePath
file forall a. Maybe a
Nothing) [FilePath]
files
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Idea]
err forall a. [a] -> [a] -> [a]
++ [Setting] -> [ModuleEx] -> [Idea]
executeHints [Setting]
s [ModuleEx]
ms
applyHints :: [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints :: [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints [Classify]
cs = [Setting] -> Hint -> [ModuleEx] -> [Idea]
applyHintsReal forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Classify -> Setting
SettingClassify [Classify]
cs
applyHintsReal :: [Setting] -> Hint -> [ModuleEx] -> [Idea]
applyHintsReal :: [Setting] -> Hint -> [ModuleEx] -> [Idea]
applyHintsReal [Setting]
settings Hint
hints_ [ModuleEx]
ms = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ forall a b. (a -> b) -> [a] -> [b]
map ([Classify] -> Idea -> Idea
classify [Classify]
classifiers forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleEx -> Idea -> Idea
removeRequiresExtensionNotes ModuleEx
m) forall a b. (a -> b) -> a -> b
$
[FilePath] -> [Idea] -> [Idea]
order [] (Hint -> [Setting] -> Scope -> ModuleEx -> [Idea]
hintModule Hint
hints [Setting]
settings Scope
nm ModuleEx
m) [Idea] -> [Idea] -> [Idea]
`merge`
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath] -> [Idea] -> [Idea]
order (forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ LHsDecl GhcPs -> Maybe FilePath
declName GenLocated SrcSpanAnnA (HsDecl GhcPs)
d) forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [Idea]
decHints GenLocated SrcSpanAnnA (HsDecl GhcPs)
d | GenLocated SrcSpanAnnA (HsDecl GhcPs)
d <- HsModule -> [LHsDecl GhcPs]
hsmodDecls forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ ModuleEx -> Located HsModule
ghcModule ModuleEx
m]
| (Scope
nm,ModuleEx
m) <- [(Scope, ModuleEx)]
mns
, let classifiers :: [Classify]
classifiers = [Classify]
cls forall a. [a] -> [a] -> [a]
++ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AnnDecl GhcPs -> Maybe Classify
readPragma (forall from to. Biplate from to => from -> [to]
universeBi (ModuleEx -> Located HsModule
ghcModule ModuleEx
m)) forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LEpaComment -> [Classify]
readComment (ModuleEx -> [LEpaComment]
ghcComments ModuleEx
m)
, seq :: forall a b. a -> b -> b
seq (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Classify]
classifiers) Bool
True
, let decHints :: LHsDecl GhcPs -> [Idea]
decHints = Hint -> [Setting] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]
hintDecl Hint
hints [Setting]
settings Scope
nm ModuleEx
m
, let order :: [FilePath] -> [Idea] -> [Idea]
order [FilePath]
n = forall a b. (a -> b) -> [a] -> [b]
map (\Idea
i -> Idea
i{ideaModule :: [FilePath]
ideaModule = [FilePath] -> [FilePath]
f forall a b. (a -> b) -> a -> b
$ Located HsModule -> FilePath
modName (ModuleEx -> Located HsModule
ghcModule ModuleEx
m) forall a. a -> [a] -> [a]
: Idea -> [FilePath]
ideaModule Idea
i, ideaDecl :: [FilePath]
ideaDecl = [FilePath] -> [FilePath]
f forall a b. (a -> b) -> a -> b
$ [FilePath]
n forall a. [a] -> [a] -> [a]
++ Idea -> [FilePath]
ideaDecl Idea
i}) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (SrcSpan -> SrcSpanD
SrcSpanD forall b c a. (b -> c) -> (a -> b) -> a -> c
. Idea -> SrcSpan
ideaSpan)
, let merge :: [Idea] -> [Idea] -> [Idea]
merge = forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (SrcSpan -> SrcSpanD
SrcSpanD forall b c a. (b -> c) -> (a -> b) -> a -> c
. Idea -> SrcSpan
ideaSpan))] forall a. [a] -> [a] -> [a]
++
[forall a b. (a -> b) -> [a] -> [b]
map ([Classify] -> Idea -> Idea
classify [Classify]
cls) (Hint -> [Setting] -> [(Scope, ModuleEx)] -> [Idea]
hintModules Hint
hints [Setting]
settings [(Scope, ModuleEx)]
mns)]
where
f :: [FilePath] -> [FilePath]
f = forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= FilePath
"")
cls :: [Classify]
cls = [Classify
x | SettingClassify Classify
x <- [Setting]
settings]
mns :: [(Scope, ModuleEx)]
mns = forall a b. (a -> b) -> [a] -> [b]
map (\ModuleEx
x -> (HsModule -> Scope
scopeCreate (forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ ModuleEx -> Located HsModule
ghcModule ModuleEx
x), ModuleEx
x)) [ModuleEx]
ms
hints :: Hint
hints = (if forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleEx]
ms forall a. Ord a => a -> a -> Bool
<= Int
1 then Hint -> Hint
noModules else forall a. a -> a
id) Hint
hints_
noModules :: Hint -> Hint
noModules Hint
h = Hint
h{hintModules :: [Setting] -> [(Scope, ModuleEx)] -> [Idea]
hintModules = \[Setting]
_ [(Scope, ModuleEx)]
_ -> []} forall a. Monoid a => a -> a -> a
`mappend` forall a. Monoid a => a
mempty{hintModule :: [Setting] -> Scope -> ModuleEx -> [Idea]
hintModule = \[Setting]
s Scope
a ModuleEx
b -> Hint -> [Setting] -> [(Scope, ModuleEx)] -> [Idea]
hintModules Hint
h [Setting]
s [(Scope
a,ModuleEx
b)]}
removeRequiresExtensionNotes :: ModuleEx -> Idea -> Idea
removeRequiresExtensionNotes :: ModuleEx -> Idea -> Idea
removeRequiresExtensionNotes ModuleEx
m = \Idea
x -> Idea
x{ideaNote :: [Note]
ideaNote = forall a. (a -> Bool) -> [a] -> [a]
filter Note -> Bool
keep forall a b. (a -> b) -> a -> b
$ Idea -> [Note]
ideaNote Idea
x}
where
exts :: HashSet FilePath
exts = forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ [(LEpaComment, FilePath)] -> [(LEpaComment, [FilePath])]
languagePragmas forall a b. (a -> b) -> a -> b
$ EpAnnComments -> [(LEpaComment, FilePath)]
pragmas (forall ann. EpAnn ann -> EpAnnComments
comments (HsModule -> EpAnn AnnsModule
hsmodAnn (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleEx -> Located HsModule
ghcModule forall a b. (a -> b) -> a -> b
$ ModuleEx
m)))
keep :: Note -> Bool
keep (RequiresExtension FilePath
x) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FilePath
x forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet FilePath
exts
keep Note
_ = Bool
True
executeHints :: [Setting] -> [ModuleEx] -> [Idea]
executeHints :: [Setting] -> [ModuleEx] -> [Idea]
executeHints [Setting]
s = [Setting] -> Hint -> [ModuleEx] -> [Idea]
applyHintsReal [Setting]
s ([Setting] -> Hint
allHints [Setting]
s)
parseModuleApply :: ParseFlags -> [Setting] -> FilePath -> Maybe String -> IO (Either Idea ModuleEx)
parseModuleApply :: ParseFlags
-> [Setting]
-> FilePath
-> Maybe FilePath
-> IO (Either Idea ModuleEx)
parseModuleApply ParseFlags
flags [Setting]
s FilePath
file Maybe FilePath
src = do
Either ParseError ModuleEx
res <- ParseFlags
-> FilePath -> Maybe FilePath -> IO (Either ParseError ModuleEx)
parseModuleEx ([FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities [FixityInfo
x | Infix FixityInfo
x <- [Setting]
s] ParseFlags
flags) FilePath
file Maybe FilePath
src
case Either ParseError ModuleEx
res of
Right ModuleEx
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ModuleEx
r
Left (ParseError SrcSpan
sl FilePath
msg FilePath
ctxt) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Classify] -> Idea -> Idea
classify [Classify
x | SettingClassify Classify
x <- [Setting]
s] forall a b. (a -> b) -> a -> b
$ Severity
-> FilePath
-> SrcSpan
-> FilePath
-> Maybe FilePath
-> [Note]
-> Idea
rawIdeaN Severity
Error (FilePath -> FilePath
adjustMessage FilePath
msg) SrcSpan
sl FilePath
ctxt forall a. Maybe a
Nothing []
where
adjustMessage :: String -> String
adjustMessage :: FilePath -> FilePath
adjustMessage FilePath
x = FilePath
"Parse error: " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
dropBrackets (
case forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix FilePath
"parse error " FilePath
x of
Maybe (FilePath, FilePath)
Nothing -> FilePath
x
Just (FilePath
prefix, FilePath
_) ->
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix (FilePath
prefix forall a. [a] -> [a] -> [a]
++ FilePath
"parse error ") FilePath
x
)
dropBrackets :: FilePath -> FilePath
dropBrackets (Char
'(':FilePath
xs) | Just (FilePath
xs,Char
')') <- forall a. [a] -> Maybe ([a], a)
unsnoc FilePath
xs = FilePath
xs
dropBrackets FilePath
xs = FilePath
xs
allHints :: [Setting] -> Hint
allHints :: [Setting] -> Hint
allHints [Setting]
xs = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ [HintRule] -> Hint
hintRules [HintRule
x | SettingMatchExp HintRule
x <- [Setting]
xs] forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Hint
f [FilePath]
builtin
where builtin :: [FilePath]
builtin = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [if FilePath
x forall a. Eq a => a -> a -> Bool
== FilePath
"All" then forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(FilePath, Hint)]
builtinHints else [FilePath
x] | Builtin FilePath
x <- [Setting]
xs]
f :: FilePath -> Hint
f FilePath
x = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Unknown builtin hints: HLint.Builtin." forall a. [a] -> [a] -> [a]
++ FilePath
x) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
x [(FilePath, Hint)]
builtinHints
classify :: [Classify] -> Idea -> Idea
classify :: [Classify] -> Idea -> Idea
classify [Classify]
xs Idea
i = let s :: Severity
s = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Idea -> Severity -> Classify -> Severity
f Idea
i) (Idea -> Severity
ideaSeverity Idea
i) [Classify]
xs in Severity
s seq :: forall a b. a -> b -> b
`seq` Idea
i{ideaSeverity :: Severity
ideaSeverity=Severity
s}
where
f :: Idea -> Severity -> Classify -> Severity
f :: Idea -> Severity -> Classify -> Severity
f Idea
i Severity
r Classify
c | Classify -> FilePath
classifyHint Classify
c FilePath -> FilePath -> Bool
~~= Idea -> FilePath
ideaHint Idea
i Bool -> Bool -> Bool
&& Classify -> FilePath
classifyModule Classify
c forall {t :: * -> *}. Foldable t => FilePath -> t FilePath -> Bool
~= Idea -> [FilePath]
ideaModule Idea
i Bool -> Bool -> Bool
&& Classify -> FilePath
classifyDecl Classify
c forall {t :: * -> *}. Foldable t => FilePath -> t FilePath -> Bool
~= Idea -> [FilePath]
ideaDecl Idea
i = Classify -> Severity
classifySeverity Classify
c
| Bool
otherwise = Severity
r
FilePath
x ~= :: FilePath -> t FilePath -> Bool
~= t FilePath
y = FilePath
x forall a. Eq a => a -> a -> Bool
== FilePath
"" Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
wildcardMatch FilePath
x) t FilePath
y
FilePath
x ~~= :: FilePath -> FilePath -> Bool
~~= FilePath
y = FilePath
x forall a. Eq a => a -> a -> Bool
== FilePath
"" Bool -> Bool -> Bool
|| FilePath
x forall a. Eq a => a -> a -> Bool
== FilePath
y Bool -> Bool -> Bool
|| ((FilePath
x forall a. [a] -> [a] -> [a]
++ FilePath
":") forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
y)