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