{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
module Hint.Pragma(pragmaHint) where
import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS,rawIdea)
import Data.List.Extra
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Refact.Types
import qualified Refact.Types as R
import GHC.Parser.Annotation
import GHC.Types.SrcLoc
import GHC.Util
import GHC.Driver.Session
pragmaHint :: ModuHint
pragmaHint :: ModuHint
pragmaHint Scope
_ ModuleEx
modu =
let ps :: [(Located AnnotationComment, String)]
ps = ApiAnns -> [(Located AnnotationComment, String)]
pragmas (ModuleEx -> ApiAnns
ghcAnnotations ModuleEx
modu)
opts :: [(Located AnnotationComment, [String])]
opts = [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
flags [(Located AnnotationComment, String)]
ps
lang :: [(Located AnnotationComment, [String])]
lang = [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
languagePragmas [(Located AnnotationComment, String)]
ps in
[(Located AnnotationComment, [String])] -> [Idea]
languageDupes [(Located AnnotationComment, [String])]
lang [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ [(Located AnnotationComment, [String])]
-> [(Located AnnotationComment, [String])] -> [Idea]
optToPragma [(Located AnnotationComment, [String])]
opts [(Located AnnotationComment, [String])]
lang
optToPragma :: [(Located AnnotationComment, [String])]
-> [(Located AnnotationComment, [String])]
-> [Idea]
optToPragma :: [(Located AnnotationComment, [String])]
-> [(Located AnnotationComment, [String])] -> [Idea]
optToPragma [(Located AnnotationComment, [String])]
flags [(Located AnnotationComment, [String])]
languagePragmas =
[PragmaIdea -> Idea
pragmaIdea (NonEmpty (Located AnnotationComment)
-> [Located AnnotationComment]
-> [Refactoring SrcSpan]
-> PragmaIdea
OptionsToComment ((Located AnnotationComment, [String]) -> Located AnnotationComment
forall a b. (a, b) -> a
fst ((Located AnnotationComment, [String])
-> Located AnnotationComment)
-> NonEmpty (Located AnnotationComment, [String])
-> NonEmpty (Located AnnotationComment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Located AnnotationComment, [String])
old2) [Located AnnotationComment]
ys [Refactoring SrcSpan]
rs) | Just NonEmpty (Located AnnotationComment, [String])
old2 <- [[(Located AnnotationComment, [String])]
-> Maybe (NonEmpty (Located AnnotationComment, [String]))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(Located AnnotationComment, [String])]
old]]
where
([(Located AnnotationComment, [String])]
old, [Maybe (Located AnnotationComment)]
new, [[String]]
ns, [Refactoring SrcSpan]
rs) =
[((Located AnnotationComment, [String]),
Maybe (Located AnnotationComment), [String], Refactoring SrcSpan)]
-> ([(Located AnnotationComment, [String])],
[Maybe (Located AnnotationComment)], [[String]],
[Refactoring SrcSpan])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [((Located AnnotationComment, [String])
old, Maybe (Located AnnotationComment)
new, [String]
ns, Refactoring SrcSpan
r)
| (Located AnnotationComment, [String])
old <- [(Located AnnotationComment, [String])]
flags, Just (Maybe (Located AnnotationComment)
new, [String]
ns) <- [(Located AnnotationComment, [String])
-> [String] -> Maybe (Maybe (Located AnnotationComment), [String])
optToLanguage (Located AnnotationComment, [String])
old [String]
ls]
, let r :: Refactoring SrcSpan
r = (Located AnnotationComment, [String])
-> Maybe (Located AnnotationComment)
-> [String]
-> Refactoring SrcSpan
mkRefact (Located AnnotationComment, [String])
old Maybe (Located AnnotationComment)
new [String]
ns]
ls :: [String]
ls = ((Located AnnotationComment, [String]) -> [String])
-> [(Located AnnotationComment, [String])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Located AnnotationComment, [String]) -> [String]
forall a b. (a, b) -> b
snd [(Located AnnotationComment, [String])]
languagePragmas
ns2 :: [String]
ns2 = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
ns) [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
ls
ys :: [Located AnnotationComment]
ys = [SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas SrcSpan
noSrcSpan [String]
ns2 | [String]
ns2 [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []] [Located AnnotationComment]
-> [Located AnnotationComment] -> [Located AnnotationComment]
forall a. [a] -> [a] -> [a]
++ [Maybe (Located AnnotationComment)] -> [Located AnnotationComment]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Located AnnotationComment)]
new
mkRefact :: (Located AnnotationComment, [String])
-> Maybe (Located AnnotationComment)
-> [String]
-> Refactoring R.SrcSpan
mkRefact :: (Located AnnotationComment, [String])
-> Maybe (Located AnnotationComment)
-> [String]
-> Refactoring SrcSpan
mkRefact (Located AnnotationComment, [String])
old (String
-> (Located AnnotationComment -> String)
-> Maybe (Located AnnotationComment)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Located AnnotationComment -> String
comment -> String
new) [String]
ns =
let ns' :: [String]
ns' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
n -> Located AnnotationComment -> String
comment (SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas SrcSpan
noSrcSpan [String
n])) [String]
ns
in SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
ModifyComment (Located AnnotationComment -> SrcSpan
forall a. Located a -> SrcSpan
toSS ((Located AnnotationComment, [String]) -> Located AnnotationComment
forall a b. (a, b) -> a
fst (Located AnnotationComment, [String])
old)) (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String]
ns' [String] -> String -> [String]
forall a. [a] -> a -> [a]
`snoc` String
new)))
data PragmaIdea = (Located AnnotationComment) (Located AnnotationComment)
| (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)
| (NE.NonEmpty (Located AnnotationComment)) [Located AnnotationComment] [Refactoring R.SrcSpan]
pragmaIdea :: PragmaIdea -> Idea
pragmaIdea :: PragmaIdea -> Idea
pragmaIdea PragmaIdea
pidea =
case PragmaIdea
pidea of
SingleComment Located AnnotationComment
old Located AnnotationComment
new ->
SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkFewer (Located AnnotationComment -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located AnnotationComment
old) (Located AnnotationComment -> String
comment Located AnnotationComment
old) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Located AnnotationComment -> String
comment Located AnnotationComment
new) []
[SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
ModifyComment (Located AnnotationComment -> SrcSpan
forall a. Located a -> SrcSpan
toSS Located AnnotationComment
old) (Located AnnotationComment -> String
comment Located AnnotationComment
new)]
MultiComment Located AnnotationComment
repl Located AnnotationComment
delete Located AnnotationComment
new ->
SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkFewer (Located AnnotationComment -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located AnnotationComment
repl)
([Located AnnotationComment] -> String
f [Located AnnotationComment
repl, Located AnnotationComment
delete]) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Located AnnotationComment -> String
comment Located AnnotationComment
new) []
[ SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
ModifyComment (Located AnnotationComment -> SrcSpan
forall a. Located a -> SrcSpan
toSS Located AnnotationComment
repl) (Located AnnotationComment -> String
comment Located AnnotationComment
new)
, SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
ModifyComment (Located AnnotationComment -> SrcSpan
forall a. Located a -> SrcSpan
toSS Located AnnotationComment
delete) String
""]
OptionsToComment NonEmpty (Located AnnotationComment)
old [Located AnnotationComment]
new [Refactoring SrcSpan]
r ->
SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkLanguage (Located AnnotationComment -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (Located AnnotationComment -> SrcSpan)
-> (NonEmpty (Located AnnotationComment)
-> Located AnnotationComment)
-> NonEmpty (Located AnnotationComment)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Located AnnotationComment) -> Located AnnotationComment
forall a. NonEmpty a -> a
NE.head (NonEmpty (Located AnnotationComment) -> SrcSpan)
-> NonEmpty (Located AnnotationComment) -> SrcSpan
forall a b. (a -> b) -> a -> b
$ NonEmpty (Located AnnotationComment)
old)
([Located AnnotationComment] -> String
f ([Located AnnotationComment] -> String)
-> [Located AnnotationComment] -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty (Located AnnotationComment) -> [Located AnnotationComment]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Located AnnotationComment)
old) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [Located AnnotationComment] -> String
f [Located AnnotationComment]
new) []
[Refactoring SrcSpan]
r
where
f :: [Located AnnotationComment] -> String
f = [String] -> String
unlines ([String] -> String)
-> ([Located AnnotationComment] -> [String])
-> [Located AnnotationComment]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located AnnotationComment -> String)
-> [Located AnnotationComment] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located AnnotationComment -> String
comment
mkFewer :: SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkFewer = Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Hint.Type.Warning String
"Use fewer LANGUAGE pragmas"
mkLanguage :: SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkLanguage = Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Hint.Type.Warning String
"Use LANGUAGE pragmas"
languageDupes :: [(Located AnnotationComment, [String])] -> [Idea]
languageDupes :: [(Located AnnotationComment, [String])] -> [Idea]
languageDupes ( (a :: Located AnnotationComment
a@(L SrcSpan
l AnnotationComment
_), [String]
les) : [(Located AnnotationComment, [String])]
cs ) =
(if [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
les [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [String]
les
then [PragmaIdea -> Idea
pragmaIdea (Located AnnotationComment
-> Located AnnotationComment -> PragmaIdea
SingleComment Located AnnotationComment
a (SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas SrcSpan
l ([String] -> Located AnnotationComment)
-> [String] -> Located AnnotationComment
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
les))]
else [PragmaIdea -> Idea
pragmaIdea (Located AnnotationComment
-> Located AnnotationComment
-> Located AnnotationComment
-> PragmaIdea
MultiComment Located AnnotationComment
a Located AnnotationComment
b (SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas SrcSpan
l ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
les [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
les'))) | ( b :: Located AnnotationComment
b@(L SrcSpan
_ AnnotationComment
_), [String]
les' ) <- [(Located AnnotationComment, [String])]
cs, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
disjoint [String]
les [String]
les']
) [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ [(Located AnnotationComment, [String])] -> [Idea]
languageDupes [(Located AnnotationComment, [String])]
cs
languageDupes [(Located AnnotationComment, [String])]
_ = []
strToLanguage :: String -> Maybe [String]
strToLanguage :: String -> Maybe [String]
strToLanguage String
"-cpp" = [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String
"CPP"]
strToLanguage String
x | String
"-X" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x = [String] -> Maybe [String]
forall a. a -> Maybe a
Just [Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
x]
strToLanguage String
"-fglasgow-exts" = [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show [Extension]
glasgowExtsFlags
strToLanguage String
_ = Maybe [String]
forall a. Maybe a
Nothing
optToLanguage :: (Located AnnotationComment, [String])
-> [String]
-> Maybe (Maybe (Located AnnotationComment), [String])
optToLanguage :: (Located AnnotationComment, [String])
-> [String] -> Maybe (Maybe (Located AnnotationComment), [String])
optToLanguage (L SrcSpan
loc AnnotationComment
_, [String]
flags) [String]
languagePragmas
| (Maybe [String] -> Bool) -> [Maybe [String]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust [Maybe [String]]
vs =
let ls :: [String]
ls = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
languagePragmas)) ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ [Maybe [String]] -> [[String]]
forall a. [Maybe a] -> [a]
catMaybes [Maybe [String]]
vs) in
(Maybe (Located AnnotationComment), [String])
-> Maybe (Maybe (Located AnnotationComment), [String])
forall a. a -> Maybe a
Just (Maybe (Located AnnotationComment)
res, [String]
ls)
where
vs :: [Maybe [String]]
vs = (String -> Maybe [String]) -> [String] -> [Maybe [String]]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe [String]
strToLanguage [String]
flags
keep :: [String]
keep = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (Maybe [String] -> String -> [String])
-> [Maybe [String]] -> [String] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Maybe [String]
v String
f -> [String
f | Maybe [String] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [String]
v]) [Maybe [String]]
vs [String]
flags
res :: Maybe (Located AnnotationComment)
res = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
keep then Maybe (Located AnnotationComment)
forall a. Maybe a
Nothing else Located AnnotationComment -> Maybe (Located AnnotationComment)
forall a. a -> Maybe a
Just (SrcSpan -> [String] -> Located AnnotationComment
mkFlags SrcSpan
loc [String]
keep)
optToLanguage (Located AnnotationComment, [String])
_ [String]
_ = Maybe (Maybe (Located AnnotationComment), [String])
forall a. Maybe a
Nothing