{-# 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 RebindableSyntax, EmptyCase #-}
</TEST>
-}


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 = 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 :: 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])]
_ = []

-- Given a pragma, can you extract some language features out?
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

-- 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 :: (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 =
      -- '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 = (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
    -- Try reinterpreting each flag as a list of language features
    -- (e.g. via '-X'..., '-fglasgow-exts').
    vs :: [Maybe [String]]
vs = (String -> Maybe [String]) -> [String] -> [Maybe [String]]
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 = [[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
    -- If there are flags to keep, 'res' is a new pragma setting just those 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