1{-# LANGUAGE ViewPatterns #-} 2{-# LANGUAGE FlexibleContexts #-} 3 4{- 5 Suggest better pragmas 6 OPTIONS_GHC -cpp => LANGUAGE CPP 7 OPTIONS_GHC -fglasgow-exts => LANGUAGE ... (in HSE) 8 OPTIONS_GHC -XFoo => LANGUAGE Foo 9 LANGUAGE A, A => LANGUAGE A 10 -- do not do LANGUAGE A, LANGUAGE B to combine 11 12<TEST> 13{-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-} 14{-# OPTIONS -cpp #-} -- {-# LANGUAGE CPP #-} 15{-# OPTIONS_YHC -cpp #-} 16{-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-} 17{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor: refactor output has one LANGUAGE pragma per extension, while hlint suggestion has a single LANGUAGE pragma 18{-# LANGUAGE RebindableSyntax, EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-} 19{-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields #-} 20{-# LANGUAGE RebindableSyntax #-} 21{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} @NoRefactor -foo is not a valid flag 22{-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-} 23{-# OPTIONS_GHC -cpp #-} \ 24{-# LANGUAGE CPP, Text #-} -- 25{-# LANGUAGE RebindableSyntax #-} \ 26{-# LANGUAGE DuplicateRecordFields #-} 27{-# LANGUAGE RebindableSyntax #-} \ 28{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-} 29</TEST> 30-} 31 32 33module Hint.Pragma(pragmaHint) where 34 35import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS,rawIdea) 36import Data.List.Extra 37import qualified Data.List.NonEmpty as NE 38import Data.Maybe 39import Refact.Types 40import qualified Refact.Types as R 41 42import ApiAnnotation 43import SrcLoc 44 45import GHC.Util 46import DynFlags 47 48pragmaHint :: ModuHint 49pragmaHint _ modu = 50 let ps = pragmas (ghcAnnotations modu) 51 opts = flags ps 52 lang = languagePragmas ps in 53 languageDupes lang ++ optToPragma opts lang 54 55optToPragma :: [(Located AnnotationComment, [String])] 56 -> [(Located AnnotationComment, [String])] 57 -> [Idea] 58optToPragma flags languagePragmas = 59 [pragmaIdea (OptionsToComment (fst <$> old2) ys rs) | Just old2 <- [NE.nonEmpty old]] 60 where 61 (old, new, ns, rs) = 62 unzip4 [(old, new, ns, r) 63 | old <- flags, Just (new, ns) <- [optToLanguage old ls] 64 , let r = mkRefact old new ns] 65 66 ls = concatMap snd languagePragmas 67 ns2 = nubOrd (concat ns) \\ ls 68 69 ys = [mkLanguagePragmas noSrcSpan ns2 | ns2 /= []] ++ catMaybes new 70 mkRefact :: (Located AnnotationComment, [String]) 71 -> Maybe (Located AnnotationComment) 72 -> [String] 73 -> Refactoring R.SrcSpan 74 mkRefact old (maybe "" comment -> new) ns = 75 let ns' = map (\n -> comment (mkLanguagePragmas noSrcSpan [n])) ns 76 in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new))) 77 78data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment) 79 | MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment) 80 | OptionsToComment (NE.NonEmpty (Located AnnotationComment)) [Located AnnotationComment] [Refactoring R.SrcSpan] 81 82pragmaIdea :: PragmaIdea -> Idea 83pragmaIdea pidea = 84 case pidea of 85 SingleComment old new -> 86 mkFewer (getLoc old) (comment old) (Just $ comment new) [] 87 [ModifyComment (toSS old) (comment new)] 88 MultiComment repl delete new -> 89 mkFewer (getLoc repl) 90 (f [repl, delete]) (Just $ comment new) [] 91 [ ModifyComment (toSS repl) (comment new) 92 , ModifyComment (toSS delete) ""] 93 OptionsToComment old new r -> 94 mkLanguage (getLoc . NE.head $ old) 95 (f $ NE.toList old) (Just $ f new) [] 96 r 97 where 98 f = unlines . map comment 99 mkFewer = rawIdea Hint.Type.Warning "Use fewer LANGUAGE pragmas" 100 mkLanguage = rawIdea Hint.Type.Warning "Use LANGUAGE pragmas" 101 102languageDupes :: [(Located AnnotationComment, [String])] -> [Idea] 103languageDupes ( (a@(L l _), les) : cs ) = 104 (if nubOrd les /= les 105 then [pragmaIdea (SingleComment a (mkLanguagePragmas l $ nubOrd les))] 106 else [pragmaIdea (MultiComment a b (mkLanguagePragmas l (nubOrd $ les ++ les'))) | ( b@(L _ _), les' ) <- cs, not $ disjoint les les'] 107 ) ++ languageDupes cs 108languageDupes _ = [] 109 110-- Given a pragma, can you extract some language features out? 111strToLanguage :: String -> Maybe [String] 112strToLanguage "-cpp" = Just ["CPP"] 113strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x] 114strToLanguage "-fglasgow-exts" = Just $ map show glasgowExtsFlags 115strToLanguage _ = Nothing 116 117-- In 'optToLanguage p langexts', 'p' is an 'OPTIONS_GHC' pragma, 118-- 'langexts' a list of all language extensions in the module enabled 119-- by 'LANGUAGE' pragmas. 120-- 121-- If ALL of the flags in the pragma enable language extensions, 122-- 'return Nothing'. 123-- 124-- If some (or all) of the flags enable options that are not language 125-- extensions, compute a new options pragma with only non-language 126-- extension enabling flags. Return that together with a list of any 127-- language extensions enabled by this pragma that are not otherwise 128-- enabled by LANGUAGE pragmas in the module. 129optToLanguage :: (Located AnnotationComment, [String]) 130 -> [String] 131 -> Maybe (Maybe (Located AnnotationComment), [String]) 132optToLanguage (L loc _, flags) languagePragmas 133 | any isJust vs = 134 -- 'ls' is a list of language features enabled by this 135 -- OPTIONS_GHC pragma that are not enabled by LANGUAGE pragmas 136 -- in this module. 137 let ls = filter (not . (`elem` languagePragmas)) (concat $ catMaybes vs) in 138 Just (res, ls) 139 where 140 -- Try reinterpreting each flag as a list of language features 141 -- (e.g. via '-X'..., '-fglasgow-exts'). 142 vs = map strToLanguage flags -- e.g. '[Nothing, Just ["ScopedTypeVariables"], Nothing, ...]' 143 -- Keep any flag that does not enable language extensions. 144 keep = concat $ zipWith (\v f -> [f | isNothing v]) vs flags 145 -- If there are flags to keep, 'res' is a new pragma setting just those flags. 146 res = if null keep then Nothing else Just (mkFlags loc keep) 147optToLanguage _ _ = Nothing 148