{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}

{-
    Suggest better pragmas
    OPTIONS_GHC -cpp => LANGUAGE CPP
    OPTIONS_GHC -fglasgow-exts => LANGUAGE ... (in HSE)
    OPTIONS_GHC -XFoo => LANGUAGE Foo
    LANGUAGE A, A => LANGUAGE A
    -- do not do LANGUAGE A, LANGUAGE B to combine

<TEST>
{-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-}
{-# OPTIONS     -cpp #-} -- {-# LANGUAGE CPP #-}
{-# OPTIONS_YHC -cpp #-}
{-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-}
{-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor: refactor output has one LANGUAGE pragma per extension, while hlint suggestion has a single LANGUAGE pragma
{-# LANGUAGE RebindableSyntax, EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-}
{-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields #-}
{-# LANGUAGE RebindableSyntax #-}
{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} @NoRefactor -foo is not a valid flag
{-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-}
{-# OPTIONS_GHC -cpp #-} \
{-# LANGUAGE CPP, Text #-} --
{-# LANGUAGE RebindableSyntax #-} \
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RebindableSyntax #-} \
{-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE EmptyCase, RebindableSyntax #-}
</TEST>
-}


module Hint.Pragma(pragmaHint) where

import Hint.Type(ModuHint,Idea(..),Severity(..),toSSAnc,rawIdea,modComments,firstDeclComments)
import Data.List.Extra
import Data.List.NonEmpty qualified as NE
import Data.Maybe
import Refact.Types
import Refact.Types qualified as R

import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Data.FastString

import GHC.Util
import GHC.Driver.Session

pragmaHint :: ModuHint
pragmaHint :: ModuHint
pragmaHint Scope
_ ModuleEx
modu =
  -- Comments appearing without a line-break before the first
  -- declaration in a module are now associated with the declaration
  -- not the module so to be safe, look also at `firstDeclComments
  -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
  let ps :: [(LEpaComment, String)]
ps = EpAnnComments -> [(LEpaComment, String)]
pragmas (ModuleEx -> EpAnnComments
modComments ModuleEx
modu) forall a. [a] -> [a] -> [a]
++ EpAnnComments -> [(LEpaComment, String)]
pragmas (ModuleEx -> EpAnnComments
firstDeclComments ModuleEx
modu)
      opts :: [(LEpaComment, [String])]
opts = [(LEpaComment, String)] -> [(LEpaComment, [String])]
flags [(LEpaComment, String)]
ps
      lang :: [(LEpaComment, [String])]
lang = [(LEpaComment, String)] -> [(LEpaComment, [String])]
languagePragmas [(LEpaComment, String)]
ps in
    [(LEpaComment, [String])] -> [Idea]
languageDupes [(LEpaComment, [String])]
lang forall a. [a] -> [a] -> [a]
++ [(LEpaComment, [String])] -> [(LEpaComment, [String])] -> [Idea]
optToPragma [(LEpaComment, [String])]
opts [(LEpaComment, [String])]
lang

optToPragma :: [(LEpaComment, [String])]
             -> [(LEpaComment, [String])]
             -> [Idea]
optToPragma :: [(LEpaComment, [String])] -> [(LEpaComment, [String])] -> [Idea]
optToPragma [(LEpaComment, [String])]
flags [(LEpaComment, [String])]
languagePragmas =
  [PragmaIdea -> Idea
pragmaIdea (NonEmpty LEpaComment
-> [LEpaComment] -> [Refactoring SrcSpan] -> PragmaIdea
OptionsToComment (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (LEpaComment, [String])
old2) [LEpaComment]
ys [Refactoring SrcSpan]
rs) | Just NonEmpty (LEpaComment, [String])
old2 <- [forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(LEpaComment, [String])]
old]]
  where
      ([(LEpaComment, [String])]
old, [Maybe LEpaComment]
new, [[String]]
ns, [Refactoring SrcSpan]
rs) =
        forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [((LEpaComment, [String])
old, Maybe LEpaComment
new, [String]
ns, Refactoring SrcSpan
r)
               | (LEpaComment, [String])
old <- [(LEpaComment, [String])]
flags, Just (Maybe LEpaComment
new, [String]
ns) <- [(LEpaComment, [String])
-> [String] -> Maybe (Maybe LEpaComment, [String])
optToLanguage (LEpaComment, [String])
old [String]
ls]
               , let r :: Refactoring SrcSpan
r = (LEpaComment, [String])
-> Maybe LEpaComment -> [String] -> Refactoring SrcSpan
mkRefact (LEpaComment, [String])
old Maybe LEpaComment
new [String]
ns]

      ls :: [String]
ls = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(LEpaComment, [String])]
languagePragmas
      ns2 :: [String]
ns2 = forall a. Ord a => [a] -> [a]
nubOrd (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
ns) forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
ls

      dummyLoc :: RealSrcLoc
dummyLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
"dummy") Int
1 Int
1
      dummySpan :: RealSrcSpan
dummySpan = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
dummyLoc RealSrcLoc
dummyLoc
      dummyAnchor :: Anchor
dummyAnchor = RealSrcSpan -> Anchor
realSpanAsAnchor RealSrcSpan
dummySpan

      ys :: [LEpaComment]
ys = [Anchor -> [String] -> LEpaComment
mkLanguagePragmas Anchor
dummyAnchor [String]
ns2 | [String]
ns2 forall a. Eq a => a -> a -> Bool
/= []] forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [Maybe LEpaComment]
new
      mkRefact :: (LEpaComment, [String])
               -> Maybe LEpaComment
               -> [String]
               -> Refactoring R.SrcSpan
      mkRefact :: (LEpaComment, [String])
-> Maybe LEpaComment -> [String] -> Refactoring SrcSpan
mkRefact (LEpaComment, [String])
old (forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" LEpaComment -> String
comment_ -> String
new) [String]
ns =
        let ns' :: [String]
ns' = forall a b. (a -> b) -> [a] -> [b]
map (\String
n -> LEpaComment -> String
comment_ (Anchor -> [String] -> LEpaComment
mkLanguagePragmas Anchor
dummyAnchor [String
n])) [String]
ns
        in forall a. a -> String -> Refactoring a
ModifyComment (forall e. GenLocated Anchor e -> SrcSpan
toSSAnc (forall a b. (a, b) -> a
fst (LEpaComment, [String])
old)) (forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String]
ns' forall a. [a] -> a -> [a]
`snoc` String
new)))

data PragmaIdea = SingleComment LEpaComment LEpaComment
                 | MultiComment LEpaComment LEpaComment LEpaComment
                 | OptionsToComment (NE.NonEmpty LEpaComment) [LEpaComment] [Refactoring R.SrcSpan]

pragmaIdea :: PragmaIdea -> Idea
pragmaIdea :: PragmaIdea -> Idea
pragmaIdea PragmaIdea
pidea =
  case PragmaIdea
pidea of
    SingleComment LEpaComment
old LEpaComment
new ->
      SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkFewer (forall a. GenLocated Anchor a -> SrcSpan
getAncLoc LEpaComment
old) (LEpaComment -> String
comment_ LEpaComment
old) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ LEpaComment -> String
comment_ LEpaComment
new) []
      [forall a. a -> String -> Refactoring a
ModifyComment (forall e. GenLocated Anchor e -> SrcSpan
toSSAnc LEpaComment
old) (LEpaComment -> String
comment_ LEpaComment
new)]
    MultiComment LEpaComment
repl LEpaComment
delete LEpaComment
new ->
      SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkFewer (forall a. GenLocated Anchor a -> SrcSpan
getAncLoc LEpaComment
repl)
        ([LEpaComment] -> String
f [LEpaComment
repl, LEpaComment
delete]) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ LEpaComment -> String
comment_ LEpaComment
new) []
        [ forall a. a -> String -> Refactoring a
ModifyComment (forall e. GenLocated Anchor e -> SrcSpan
toSSAnc LEpaComment
repl) (LEpaComment -> String
comment_ LEpaComment
new)
        , forall a. a -> String -> Refactoring a
ModifyComment (forall e. GenLocated Anchor e -> SrcSpan
toSSAnc LEpaComment
delete) String
""]
    OptionsToComment NonEmpty LEpaComment
old [LEpaComment]
new [Refactoring SrcSpan]
r ->
      SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkLanguage (forall a. GenLocated Anchor a -> SrcSpan
getAncLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head forall a b. (a -> b) -> a -> b
$ NonEmpty LEpaComment
old)
        ([LEpaComment] -> String
f forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty LEpaComment
old) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [LEpaComment] -> String
f [LEpaComment]
new) []
        [Refactoring SrcSpan]
r
    where
          f :: [LEpaComment] -> String
f = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LEpaComment -> 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 :: [(LEpaComment, [String])] -> [Idea]
languageDupes :: [(LEpaComment, [String])] -> [Idea]
languageDupes ( (a :: LEpaComment
a@(L Anchor
l EpaComment
_), [String]
les) : [(LEpaComment, [String])]
cs ) =
  (if forall a. Ord a => [a] -> [a]
nubOrd [String]
les forall a. Eq a => a -> a -> Bool
/= [String]
les
       then [PragmaIdea -> Idea
pragmaIdea (LEpaComment -> LEpaComment -> PragmaIdea
SingleComment LEpaComment
a (Anchor -> [String] -> LEpaComment
mkLanguagePragmas Anchor
l forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
nubOrd [String]
les))]
       else [PragmaIdea -> Idea
pragmaIdea (LEpaComment -> LEpaComment -> LEpaComment -> PragmaIdea
MultiComment LEpaComment
a LEpaComment
b (Anchor -> [String] -> LEpaComment
mkLanguagePragmas Anchor
l (forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ [String]
les forall a. [a] -> [a] -> [a]
++ [String]
les'))) | ( b :: LEpaComment
b@(L Anchor
_ EpaComment
_), [String]
les' ) <- [(LEpaComment, [String])]
cs, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Bool
disjoint [String]
les [String]
les']
  ) forall a. [a] -> [a] -> [a]
++ [(LEpaComment, [String])] -> [Idea]
languageDupes [(LEpaComment, [String])]
cs
languageDupes [(LEpaComment, [String])]
_ = []

-- Given a pragma, can you extract some language features out?
strToLanguage :: String -> Maybe [String]
strToLanguage :: String -> Maybe [String]
strToLanguage String
"-cpp" = forall a. a -> Maybe a
Just [String
"CPP"]
strToLanguage String
x | String
"-X" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x = forall a. a -> Maybe a
Just [forall a. Int -> [a] -> [a]
drop Int
2 String
x]
strToLanguage String
"-fglasgow-exts" = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Extension]
glasgowExtsFlags
strToLanguage String
_ = forall a. Maybe a
Nothing

-- In 'optToLanguage p langexts', 'p' is an 'OPTIONS_GHC' pragma,
-- 'langexts' a list of all language extensions in the module enabled
-- by 'LANGUAGE' pragmas.
--
--  If ALL of the flags in the pragma enable language extensions,
-- 'return Nothing'.
--
-- If some (or all) of the flags enable options that are not language
-- extensions, compute a new options pragma with only non-language
-- extension enabling flags. Return that together with a list of any
-- language extensions enabled by this pragma that are not otherwise
-- enabled by LANGUAGE pragmas in the module.
optToLanguage :: (LEpaComment, [String])
               -> [String]
               -> Maybe (Maybe LEpaComment, [String])
optToLanguage :: (LEpaComment, [String])
-> [String] -> Maybe (Maybe LEpaComment, [String])
optToLanguage (L Anchor
loc EpaComment
_, [String]
flags) [String]
languagePragmas
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isJust [Maybe [String]]
vs =
      -- 'ls' is a list of language features enabled by this
      -- OPTIONS_GHC pragma that are not enabled by LANGUAGE pragmas
      -- in this module.
      let ls :: [String]
ls = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
languagePragmas)) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe [String]]
vs) in
      forall a. a -> Maybe a
Just (Maybe LEpaComment
res, [String]
ls)
  where
    -- Try reinterpreting each flag as a list of language features
    -- (e.g. via '-X'..., '-fglasgow-exts').
    vs :: [Maybe [String]]
vs = forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe [String]
strToLanguage [String]
flags -- e.g. '[Nothing, Just ["ScopedTypeVariables"], Nothing, ...]'
    -- Keep any flag that does not enable language extensions.
    keep :: [String]
keep = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Maybe [String]
v String
f -> [String
f | forall a. Maybe a -> Bool
isNothing Maybe [String]
v]) [Maybe [String]]
vs [String]
flags
    -- If there are flags to keep, 'res' is a new pragma setting just those flags.
    res :: Maybe LEpaComment
res = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
keep then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Anchor -> [String] -> LEpaComment
mkFlags Anchor
loc [String]
keep)
optToLanguage (LEpaComment, [String])
_ [String]
_ = forall a. Maybe a
Nothing