{-# 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 ApiAnnotation
import SrcLoc
import GHC.Util
import DynFlags
pragmaHint :: ModuHint
pragmaHint _ modu =
let ps = pragmas (ghcAnnotations modu)
opts = flags ps
lang = languagePragmas ps in
languageDupes lang ++ optToPragma opts lang
optToPragma :: [(Located AnnotationComment, [String])]
-> [(Located AnnotationComment, [String])]
-> [Idea]
optToPragma flags languagePragmas =
[pragmaIdea (OptionsToComment (fst <$> old2) ys rs) | Just old2 <- [NE.nonEmpty old]]
where
(old, new, ns, rs) =
unzip4 [(old, new, ns, r)
| old <- flags, Just (new, ns) <- [optToLanguage old ls]
, let r = mkRefact old new ns]
ls = concatMap snd languagePragmas
ns2 = nubOrd (concat ns) \\ ls
ys = [mkLanguagePragmas noSrcSpan ns2 | ns2 /= []] ++ catMaybes new
mkRefact :: (Located AnnotationComment, [String])
-> Maybe (Located AnnotationComment)
-> [String]
-> Refactoring R.SrcSpan
mkRefact old (maybe "" comment -> new) ns =
let ns' = map (\n -> comment (mkLanguagePragmas noSrcSpan [n])) ns
in ModifyComment (toSS' (fst old)) (intercalate "\n" (filter (not . null) (new : ns')))
data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment)
| MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)
| OptionsToComment (NE.NonEmpty (Located AnnotationComment)) [Located AnnotationComment] [Refactoring R.SrcSpan]
pragmaIdea :: PragmaIdea -> Idea
pragmaIdea pidea =
case pidea of
SingleComment old new ->
mkFewer (getLoc old) (comment old) (Just $ comment new) []
[ModifyComment (toSS' old) (comment new)]
MultiComment repl delete new ->
mkFewer (getLoc repl)
(f [repl, delete]) (Just $ comment new) []
[ ModifyComment (toSS' repl) (comment new)
, ModifyComment (toSS' delete) ""]
OptionsToComment old new r ->
mkLanguage (getLoc . NE.head $ old)
(f $ NE.toList old) (Just $ f new) []
r
where
f = unlines . map comment
mkFewer = rawIdea' Hint.Type.Warning "Use fewer LANGUAGE pragmas"
mkLanguage = rawIdea' Hint.Type.Warning "Use LANGUAGE pragmas"
languageDupes :: [(Located AnnotationComment, [String])] -> [Idea]
languageDupes ( (a@(L l _), les) : cs ) =
(if nubOrd les /= les
then [pragmaIdea (SingleComment a (mkLanguagePragmas l $ nubOrd les))]
else [pragmaIdea (MultiComment a b (mkLanguagePragmas l (nubOrd $ les ++ les'))) | ( b@(L _ _), les' ) <- cs, not $ disjoint les les']
) ++ languageDupes cs
languageDupes _ = []
strToLanguage :: String -> Maybe [String]
strToLanguage "-cpp" = Just ["CPP"]
strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x]
strToLanguage "-fglasgow-exts" = Just $ map show glasgowExtsFlags
strToLanguage _ = Nothing
optToLanguage :: (Located AnnotationComment, [String])
-> [String]
-> Maybe (Maybe (Located AnnotationComment), [String])
optToLanguage (L loc _, flags) languagePragmas
| any isJust vs =
let ls = filter (not . (`elem` languagePragmas)) (concat $ catMaybes vs) in
Just (res, ls)
where
vs = map strToLanguage flags
keep = concat $ zipWith (\v f -> [f | isNothing v]) vs flags
res = if null keep then Nothing else Just (mkFlags loc keep)
optToLanguage _ _ = Nothing