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