{-# 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 #-} -- ???
{-# LANGUAGE A, B, C, A #-} -- {-# LANGUAGE A, B, C #-}
{-# LANGUAGE A #-}
{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-}
{-# OPTIONS_GHC -cpp #-} \
{-# LANGUAGE CPP, Text #-} --
{-# LANGUAGE A #-} \
{-# LANGUAGE B #-}
{-# LANGUAGE A #-} \
{-# LANGUAGE B, A #-} -- {-# LANGUAGE A, B #-}
</TEST>
-}


module Hint.Pragma(pragmaHint) where

import Hint.Type
import Data.List.Extra
import Data.Maybe
import Refact.Types
import qualified Refact.Types as R


pragmaHint :: ModuHint
pragmaHint :: ModuHint
pragmaHint _ x :: Module_
x = [ModulePragma S] -> [Idea]
languageDupes [ModulePragma S]
lang [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ Module_ -> [ModulePragma S] -> [Idea]
optToPragma Module_
x [ModulePragma S]
lang
    where
        lang :: [ModulePragma S]
lang = [ModulePragma S
x | x :: ModulePragma S
x@LanguagePragma{} <- Module_ -> [ModulePragma S]
modulePragmas Module_
x]

optToPragma :: Module_ -> [ModulePragma S] -> [Idea]
optToPragma :: Module_ -> [ModulePragma S] -> [Idea]
optToPragma x :: Module_
x lang :: [ModulePragma S]
lang =
  [PragmaIdea -> Idea
pragmaIdea ([ModulePragma S]
-> [ModulePragma S] -> [Refactoring SrcSpan] -> PragmaIdea
OptionsToComment [ModulePragma S]
old [ModulePragma S]
ys [Refactoring SrcSpan]
rs) | [ModulePragma S]
old [ModulePragma S] -> [ModulePragma S] -> Bool
forall a. Eq a => a -> a -> Bool
/= []]
  where
        (old :: [ModulePragma S]
old,new :: [Maybe (ModulePragma S)]
new,ns :: [[String]]
ns, rs :: [Refactoring SrcSpan]
rs) =
          [(ModulePragma S, Maybe (ModulePragma S), [String],
  Refactoring SrcSpan)]
-> ([ModulePragma S], [Maybe (ModulePragma S)], [[String]],
    [Refactoring SrcSpan])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [(ModulePragma S
old,Maybe (ModulePragma S)
new,[String]
ns, Refactoring SrcSpan
r)
                 | ModulePragma S
old <- Module_ -> [ModulePragma S]
modulePragmas Module_
x, Just (new :: Maybe (ModulePragma S)
new,ns :: [String]
ns) <- [ModulePragma S
-> [String] -> Maybe (Maybe (ModulePragma S), [String])
optToLanguage ModulePragma S
old [String]
ls]
                 , let r :: Refactoring SrcSpan
r = ModulePragma S
-> Maybe (ModulePragma S) -> [String] -> Refactoring SrcSpan
mkRefact ModulePragma S
old Maybe (ModulePragma S)
new [String]
ns]

        ls :: [String]
ls = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(Name S -> String) -> [Name S] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name S -> String
forall a. Named a => a -> String
fromNamed [Name S]
n | LanguagePragma _ n :: [Name S]
n <- [ModulePragma S]
lang]
        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 :: [ModulePragma S]
ys = [S -> [Name S] -> ModulePragma S
forall l. l -> [Name l] -> ModulePragma l
LanguagePragma S
an ((String -> Name S) -> [String] -> [Name S]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name S
forall a. Named a => String -> a
toNamed [String]
ns2) | [String]
ns2 [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []] [ModulePragma S] -> [ModulePragma S] -> [ModulePragma S]
forall a. [a] -> [a] -> [a]
++ [Maybe (ModulePragma S)] -> [ModulePragma S]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (ModulePragma S)]
new
        mkRefact :: ModulePragma S -> Maybe (ModulePragma S) -> [String] -> Refactoring R.SrcSpan
        mkRefact :: ModulePragma S
-> Maybe (ModulePragma S) -> [String] -> Refactoring SrcSpan
mkRefact old :: ModulePragma S
old (String
-> (ModulePragma S -> String) -> Maybe (ModulePragma S) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ModulePragma S -> String
forall a. Pretty a => a -> String
prettyPrint -> String
new) ns :: [String]
ns =
          let ns' :: [String]
ns' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\n :: String
n -> ModulePragma S -> String
forall a. Pretty a => a -> String
prettyPrint (ModulePragma S -> String) -> ModulePragma S -> String
forall a b. (a -> b) -> a -> b
$ S -> [Name S] -> ModulePragma S
forall l. l -> [Name l] -> ModulePragma l
LanguagePragma S
an [String -> Name S
forall a. Named a => String -> a
toNamed String
n]) [String]
ns
          in
          SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
ModifyComment (ModulePragma S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS ModulePragma S
old) (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\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
newString -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ns')))

data PragmaIdea = SingleComment (ModulePragma S) (ModulePragma S)
                | MultiComment (ModulePragma S) (ModulePragma S) (ModulePragma S)
                | OptionsToComment [ModulePragma S] [ModulePragma S] [Refactoring R.SrcSpan]


pragmaIdea :: PragmaIdea -> Idea
pragmaIdea :: PragmaIdea -> Idea
pragmaIdea pidea :: PragmaIdea
pidea =
  case PragmaIdea
pidea of
    SingleComment old :: ModulePragma S
old new :: ModulePragma S
new ->
      SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkFewer (S -> SrcSpan
srcInfoSpan (S -> SrcSpan)
-> (ModulePragma S -> S) -> ModulePragma S -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModulePragma S -> S
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann (ModulePragma S -> SrcSpan) -> ModulePragma S -> SrcSpan
forall a b. (a -> b) -> a -> b
$ ModulePragma S
old)
        (ModulePragma S -> String
forall a. Pretty a => a -> String
prettyPrint ModulePragma S
old) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ModulePragma S -> String
forall a. Pretty a => a -> String
prettyPrint ModulePragma S
new) []
        [SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
ModifyComment (ModulePragma S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS ModulePragma S
old) (ModulePragma S -> String
forall a. Pretty a => a -> String
prettyPrint ModulePragma S
new)]
    MultiComment repl :: ModulePragma S
repl delete :: ModulePragma S
delete new :: ModulePragma S
new ->
      SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkFewer (S -> SrcSpan
srcInfoSpan (S -> SrcSpan)
-> (ModulePragma S -> S) -> ModulePragma S -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModulePragma S -> S
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann (ModulePragma S -> SrcSpan) -> ModulePragma S -> SrcSpan
forall a b. (a -> b) -> a -> b
$ ModulePragma S
repl)
        ([ModulePragma S] -> String
f [ModulePragma S
repl, ModulePragma S
delete]) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ModulePragma S -> String
forall a. Pretty a => a -> String
prettyPrint ModulePragma S
new) []
        [ SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
ModifyComment (ModulePragma S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS ModulePragma S
repl) (ModulePragma S -> String
forall a. Pretty a => a -> String
prettyPrint ModulePragma S
new)
        , SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
ModifyComment (ModulePragma S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS ModulePragma S
delete) ""]
    OptionsToComment old :: [ModulePragma S]
old new :: [ModulePragma S]
new r :: [Refactoring SrcSpan]
r ->
      SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkLanguage (S -> SrcSpan
srcInfoSpan (S -> SrcSpan)
-> ([ModulePragma S] -> S) -> [ModulePragma S] -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModulePragma S -> S
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann (ModulePragma S -> S)
-> ([ModulePragma S] -> ModulePragma S) -> [ModulePragma S] -> S
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModulePragma S] -> ModulePragma S
forall a. [a] -> a
head ([ModulePragma S] -> SrcSpan) -> [ModulePragma S] -> SrcSpan
forall a b. (a -> b) -> a -> b
$ [ModulePragma S]
old)
        ([ModulePragma S] -> String
f [ModulePragma S]
old) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [ModulePragma S] -> String
f [ModulePragma S]
new) []
        [Refactoring SrcSpan]
r
    where
          f :: [ModulePragma S] -> String
f = [String] -> String
unlines ([String] -> String)
-> ([ModulePragma S] -> [String]) -> [ModulePragma S] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModulePragma S -> String) -> [ModulePragma S] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModulePragma S -> String
forall a. Pretty a => a -> String
prettyPrint
          mkFewer :: SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
mkFewer = Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Warning "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
Warning "Use LANGUAGE pragmas"


languageDupes :: [ModulePragma S] -> [Idea]
languageDupes :: [ModulePragma S] -> [Idea]
languageDupes (a :: ModulePragma S
a@(LanguagePragma _ x :: [Name S]
x):xs :: [ModulePragma S]
xs) =
    (if [Name S] -> [Name S]
forall (f :: * -> *). (Annotated f, Eq (f ())) => [f S] -> [f S]
nub_ [Name S]
x [Name S] -> [Name S] -> Bool
forall (f :: * -> *).
(Annotated f, Eq (f ())) =>
[f S] -> [f S] -> Bool
`neqList` [Name S]
x
        then [PragmaIdea -> Idea
pragmaIdea (ModulePragma S -> ModulePragma S -> PragmaIdea
SingleComment ModulePragma S
a (S -> [Name S] -> ModulePragma S
forall l. l -> [Name l] -> ModulePragma l
LanguagePragma (ModulePragma S -> S
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann ModulePragma S
a) ([Name S] -> ModulePragma S) -> [Name S] -> ModulePragma S
forall a b. (a -> b) -> a -> b
$ [Name S] -> [Name S]
forall (f :: * -> *). (Annotated f, Eq (f ())) => [f S] -> [f S]
nub_ [Name S]
x))]
        else [PragmaIdea -> Idea
pragmaIdea (ModulePragma S -> ModulePragma S -> ModulePragma S -> PragmaIdea
MultiComment ModulePragma S
a ModulePragma S
b (S -> [Name S] -> ModulePragma S
forall l. l -> [Name l] -> ModulePragma l
LanguagePragma (ModulePragma S -> S
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann ModulePragma S
a) ([Name S] -> [Name S]
forall (f :: * -> *). (Annotated f, Eq (f ())) => [f S] -> [f S]
nub_ ([Name S] -> [Name S]) -> [Name S] -> [Name S]
forall a b. (a -> b) -> a -> b
$ [Name S]
x [Name S] -> [Name S] -> [Name S]
forall a. [a] -> [a] -> [a]
++ [Name S]
y))) | b :: ModulePragma S
b@(LanguagePragma _ y :: [Name S]
y) <- [ModulePragma S]
xs, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Name S] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name S] -> Bool) -> [Name S] -> Bool
forall a b. (a -> b) -> a -> b
$ [Name S] -> [Name S] -> [Name S]
forall (f :: * -> *).
(Annotated f, Eq (f ())) =>
[f S] -> [f S] -> [f S]
intersect_ [Name S]
x [Name S]
y]) [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
    [ModulePragma S] -> [Idea]
languageDupes [ModulePragma S]
xs
languageDupes _ = []


-- Given a pragma, can you extract some language features out
strToLanguage :: String -> Maybe [String]
strToLanguage :: String -> Maybe [String]
strToLanguage "-cpp" = [String] -> Maybe [String]
forall a. a -> Maybe a
Just ["CPP"]
strToLanguage x :: String
x | "-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 2 String
x]
strToLanguage "-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
prettyExtension [Extension]
glasgowExts
strToLanguage _ = Maybe [String]
forall a. Maybe a
Nothing


optToLanguage :: ModulePragma S -> [String] -> Maybe (Maybe (ModulePragma S), [String])
optToLanguage :: ModulePragma S
-> [String] -> Maybe (Maybe (ModulePragma S), [String])
optToLanguage (OptionsPragma sl :: S
sl tool :: Maybe Tool
tool val :: String
val) ls :: [String]
ls
    | Bool -> (Tool -> Bool) -> Maybe Tool -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Tool -> Tool -> Bool
forall a. Eq a => a -> a -> Bool
== Tool
GHC) Maybe Tool
tool Bool -> Bool -> Bool
&& (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 =
      (Maybe (ModulePragma S), [String])
-> Maybe (Maybe (ModulePragma S), [String])
forall a. a -> Maybe a
Just (Maybe (ModulePragma S)
res, (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]
ls)) ([[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))
    where
        strs :: [String]
strs = String -> [String]
words String
val
        vs :: [Maybe [String]]
vs = (String -> Maybe [String]) -> [String] -> [Maybe [String]]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe [String]
strToLanguage [String]
strs
        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 (\v :: Maybe [String]
v s :: String
s -> [String
s | Maybe [String] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [String]
v]) [Maybe [String]]
vs [String]
strs
        res :: Maybe (ModulePragma S)
res = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
keep then Maybe (ModulePragma S)
forall a. Maybe a
Nothing else ModulePragma S -> Maybe (ModulePragma S)
forall a. a -> Maybe a
Just (ModulePragma S -> Maybe (ModulePragma S))
-> ModulePragma S -> Maybe (ModulePragma S)
forall a b. (a -> b) -> a -> b
$ S -> Maybe Tool -> String -> ModulePragma S
forall l. l -> Maybe Tool -> String -> ModulePragma l
OptionsPragma S
sl Maybe Tool
tool ([String] -> String
unwords [String]
keep)
optToLanguage _ _ = Maybe (Maybe (ModulePragma S), [String])
forall a. Maybe a
Nothing