{-# LANGUAGE RecordWildCards, TupleSections #-}

module Summary (generateSummary) where

import qualified Data.Map as Map
import Control.Monad.Extra
import System.FilePath
import Data.List.Extra
import System.Directory

import Idea
import Apply
import Hint.Type
import Hint.All
import Config.Type
import Test.Annotations


data BuiltinKey = BuiltinKey
  { BuiltinKey -> String
builtinName :: !String
  , BuiltinKey -> Severity
builtinSeverity :: !Severity
  , BuiltinKey -> Bool
builtinRefactoring :: !Bool
  } deriving (BuiltinKey -> BuiltinKey -> Bool
(BuiltinKey -> BuiltinKey -> Bool)
-> (BuiltinKey -> BuiltinKey -> Bool) -> Eq BuiltinKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuiltinKey -> BuiltinKey -> Bool
$c/= :: BuiltinKey -> BuiltinKey -> Bool
== :: BuiltinKey -> BuiltinKey -> Bool
$c== :: BuiltinKey -> BuiltinKey -> Bool
Eq, Eq BuiltinKey
Eq BuiltinKey
-> (BuiltinKey -> BuiltinKey -> Ordering)
-> (BuiltinKey -> BuiltinKey -> Bool)
-> (BuiltinKey -> BuiltinKey -> Bool)
-> (BuiltinKey -> BuiltinKey -> Bool)
-> (BuiltinKey -> BuiltinKey -> Bool)
-> (BuiltinKey -> BuiltinKey -> BuiltinKey)
-> (BuiltinKey -> BuiltinKey -> BuiltinKey)
-> Ord BuiltinKey
BuiltinKey -> BuiltinKey -> Bool
BuiltinKey -> BuiltinKey -> Ordering
BuiltinKey -> BuiltinKey -> BuiltinKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BuiltinKey -> BuiltinKey -> BuiltinKey
$cmin :: BuiltinKey -> BuiltinKey -> BuiltinKey
max :: BuiltinKey -> BuiltinKey -> BuiltinKey
$cmax :: BuiltinKey -> BuiltinKey -> BuiltinKey
>= :: BuiltinKey -> BuiltinKey -> Bool
$c>= :: BuiltinKey -> BuiltinKey -> Bool
> :: BuiltinKey -> BuiltinKey -> Bool
$c> :: BuiltinKey -> BuiltinKey -> Bool
<= :: BuiltinKey -> BuiltinKey -> Bool
$c<= :: BuiltinKey -> BuiltinKey -> Bool
< :: BuiltinKey -> BuiltinKey -> Bool
$c< :: BuiltinKey -> BuiltinKey -> Bool
compare :: BuiltinKey -> BuiltinKey -> Ordering
$ccompare :: BuiltinKey -> BuiltinKey -> Ordering
$cp1Ord :: Eq BuiltinKey
Ord)

data BuiltinValue = BuiltinValue
    { BuiltinValue -> String
builtinInp :: !String
    , BuiltinValue -> String
builtinFrom :: !String
    , BuiltinValue -> Maybe String
builtinTo :: !(Maybe String)
    }


dedupeBuiltin :: [(BuiltinKey, BuiltinValue)] -> [(BuiltinKey, BuiltinValue)]
dedupeBuiltin :: [(BuiltinKey, BuiltinValue)] -> [(BuiltinKey, BuiltinValue)]
dedupeBuiltin = Map BuiltinKey BuiltinValue -> [(BuiltinKey, BuiltinValue)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map BuiltinKey BuiltinValue -> [(BuiltinKey, BuiltinValue)])
-> ([(BuiltinKey, BuiltinValue)] -> Map BuiltinKey BuiltinValue)
-> [(BuiltinKey, BuiltinValue)]
-> [(BuiltinKey, BuiltinValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuiltinValue -> BuiltinValue -> BuiltinValue)
-> [(BuiltinKey, BuiltinValue)] -> Map BuiltinKey BuiltinValue
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\BuiltinValue
_ BuiltinValue
old -> BuiltinValue
old)


-- | Generate a summary of hints, including built-in hints and YAML-configured hints
-- from @data/hlint.yaml@.
generateSummary :: [Setting] -> IO String
generateSummary :: [Setting] -> IO String
generateSummary [Setting]
settings = do
    -- Do not insert if the key already exists in the map. This has the effect
    -- of picking the first test case of a hint as the example in the summary.
    [(String, [(BuiltinKey, BuiltinValue)])]
builtinHints <- IO [(String, [(BuiltinKey, BuiltinValue)])]
mkBuiltinSummary
    let lhsRhsHints :: [HintRule]
lhsRhsHints = [HintRule
hint | SettingMatchExp HintRule
hint <- [Setting]
settings]
    String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [(String, [(BuiltinKey, BuiltinValue)])] -> [HintRule] -> String
genBuiltinSummaryMd [(String, [(BuiltinKey, BuiltinValue)])]
builtinHints [HintRule]
lhsRhsHints

-- | The summary of built-in hints is generated by running the test cases in
-- @src/Hint/*.hs@. One entry per (hint name, severity, does it support refactoring).
mkBuiltinSummary :: IO [(String, [(BuiltinKey, BuiltinValue)])]
mkBuiltinSummary :: IO [(String, [(BuiltinKey, BuiltinValue)])]
mkBuiltinSummary = [(String, Hint)]
-> ((String, Hint) -> IO (String, [(BuiltinKey, BuiltinValue)]))
-> IO [(String, [(BuiltinKey, BuiltinValue)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, Hint)]
builtinHints (((String, Hint) -> IO (String, [(BuiltinKey, BuiltinValue)]))
 -> IO [(String, [(BuiltinKey, BuiltinValue)])])
-> ((String, Hint) -> IO (String, [(BuiltinKey, BuiltinValue)]))
-> IO [(String, [(BuiltinKey, BuiltinValue)])]
forall a b. (a -> b) -> a -> b
$ \(String
name, Hint
hint) -> (String
name,) ([(BuiltinKey, BuiltinValue)]
 -> (String, [(BuiltinKey, BuiltinValue)]))
-> IO [(BuiltinKey, BuiltinValue)]
-> IO (String, [(BuiltinKey, BuiltinValue)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    let file :: String
file = String
"src/Hint" String -> String -> String
</> String
name String -> String -> String
<.> String
"hs"
    Bool
b <- String -> IO Bool
doesFileExist String
file
    if Bool -> Bool
not Bool
b then do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find source hint file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", some hints will be missing"
        [(BuiltinKey, BuiltinValue)] -> IO [(BuiltinKey, BuiltinValue)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
     else do
        [TestCase]
tests <- String -> IO [TestCase]
parseTestFile String
file
        ([(BuiltinKey, BuiltinValue)] -> [(BuiltinKey, BuiltinValue)])
-> IO [(BuiltinKey, BuiltinValue)]
-> IO [(BuiltinKey, BuiltinValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(BuiltinKey, BuiltinValue)] -> [(BuiltinKey, BuiltinValue)]
dedupeBuiltin (IO [(BuiltinKey, BuiltinValue)]
 -> IO [(BuiltinKey, BuiltinValue)])
-> ((TestCase -> IO [(BuiltinKey, BuiltinValue)])
    -> IO [(BuiltinKey, BuiltinValue)])
-> (TestCase -> IO [(BuiltinKey, BuiltinValue)])
-> IO [(BuiltinKey, BuiltinValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestCase]
-> (TestCase -> IO [(BuiltinKey, BuiltinValue)])
-> IO [(BuiltinKey, BuiltinValue)]
forall (m :: * -> *) a b. Monad m => [a] -> (a -> m [b]) -> m [b]
concatForM [TestCase]
tests ((TestCase -> IO [(BuiltinKey, BuiltinValue)])
 -> IO [(BuiltinKey, BuiltinValue)])
-> (TestCase -> IO [(BuiltinKey, BuiltinValue)])
-> IO [(BuiltinKey, BuiltinValue)]
forall a b. (a -> b) -> a -> b
$ \(TestCase SrcLoc
_ Refactor
_ String
inp Maybe String
_ [Setting]
_) -> do
            Either ParseError ModuleEx
m <- ParseFlags
-> String -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
defaultParseFlags String
file (String -> Maybe String
forall a. a -> Maybe a
Just String
inp)
            [(BuiltinKey, BuiltinValue)] -> IO [(BuiltinKey, BuiltinValue)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(BuiltinKey, BuiltinValue)] -> IO [(BuiltinKey, BuiltinValue)])
-> [(BuiltinKey, BuiltinValue)] -> IO [(BuiltinKey, BuiltinValue)]
forall a b. (a -> b) -> a -> b
$ case Either ParseError ModuleEx
m of
                Right ModuleEx
m -> (Idea -> (BuiltinKey, BuiltinValue))
-> [Idea] -> [(BuiltinKey, BuiltinValue)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Idea -> (BuiltinKey, BuiltinValue)
ideaToValue String
inp) ([Idea] -> [(BuiltinKey, BuiltinValue)])
-> [Idea] -> [(BuiltinKey, BuiltinValue)]
forall a b. (a -> b) -> a -> b
$ [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints [] Hint
hint [ModuleEx
m]
                Left ParseError
_ -> []
    where
        ideaToValue :: String -> Idea -> (BuiltinKey, BuiltinValue)
        ideaToValue :: String -> Idea -> (BuiltinKey, BuiltinValue)
ideaToValue String
inp Idea{String
[String]
[Refactoring SrcSpan]
[Note]
Maybe String
SrcSpan
Severity
ideaRefactoring :: Idea -> [Refactoring SrcSpan]
ideaNote :: Idea -> [Note]
ideaTo :: Idea -> Maybe String
ideaFrom :: Idea -> String
ideaSpan :: Idea -> SrcSpan
ideaHint :: Idea -> String
ideaSeverity :: Idea -> Severity
ideaDecl :: Idea -> [String]
ideaModule :: Idea -> [String]
ideaRefactoring :: [Refactoring SrcSpan]
ideaNote :: [Note]
ideaTo :: Maybe String
ideaFrom :: String
ideaSpan :: SrcSpan
ideaHint :: String
ideaSeverity :: Severity
ideaDecl :: [String]
ideaModule :: [String]
..} = (BuiltinKey
k, BuiltinValue
v)
            where
                -- make sure Windows/Linux don't differ on path separators
                to :: Maybe String
to = (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
x -> if String
"Combine with " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x then String -> String -> String -> String
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace String
"\\" String
"/" String
x else String
x) Maybe String
ideaTo
                k :: BuiltinKey
k = String -> Severity -> Bool -> BuiltinKey
BuiltinKey String
ideaHint Severity
ideaSeverity ([Refactoring SrcSpan] -> Bool
forall a. [a] -> Bool
notNull [Refactoring SrcSpan]
ideaRefactoring)
                v :: BuiltinValue
v = String -> String -> Maybe String -> BuiltinValue
BuiltinValue String
inp String
ideaFrom Maybe String
to


genBuiltinSummaryMd :: [(String, [(BuiltinKey, BuiltinValue)])] -> [HintRule] -> String
genBuiltinSummaryMd :: [(String, [(BuiltinKey, BuiltinValue)])] -> [HintRule] -> String
genBuiltinSummaryMd [(String, [(BuiltinKey, BuiltinValue)])]
builtins [HintRule]
lhsRhs = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  [ String
"# Summary of Hints"
  , String
""
  , String
"This page is auto-generated from `hlint --generate-summary`."
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String
"## Builtin " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
group ) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [(BuiltinKey, BuiltinValue)] -> [String]
builtinTable [(BuiltinKey, BuiltinValue)]
hints |  (String
group, [(BuiltinKey, BuiltinValue)]
hints) <- [(String, [(BuiltinKey, BuiltinValue)])]
builtins] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
""
  , String
"## Configured hints"
  , String
""
  ]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [HintRule] -> [String]
lhsRhsTable [HintRule]
lhsRhs

row :: [String] -> [String]
row :: [String] -> [String]
row [String]
xs = [String
"<tr>"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"</tr>"]

-- | Render using <code> if it is single-line, otherwise using <pre>.
haskell :: String -> [String]
haskell :: String -> [String]
haskell String
s
  | Char
'\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s = [String
"<pre>", String
s, String
"</pre>"]
  | Bool
otherwise = [String
"<code>", String
s, String
"</code>", String
"<br>"]

builtinTable :: [(BuiltinKey, BuiltinValue)] -> [String]
builtinTable :: [(BuiltinKey, BuiltinValue)] -> [String]
builtinTable [(BuiltinKey, BuiltinValue)]
builtins =
  [String
"<table>"]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
row [String
"<th>Hint Name</th>", String
"<th>Hint</th>", String
"<th>Severity</th>"]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((BuiltinKey, BuiltinValue) -> [String])
-> [(BuiltinKey, BuiltinValue)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((BuiltinKey -> BuiltinValue -> [String])
-> (BuiltinKey, BuiltinValue) -> [String]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry BuiltinKey -> BuiltinValue -> [String]
showBuiltin) [(BuiltinKey, BuiltinValue)]
builtins
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"</table>"]

showBuiltin :: BuiltinKey -> BuiltinValue -> [String]
showBuiltin :: BuiltinKey -> BuiltinValue -> [String]
showBuiltin BuiltinKey{Bool
String
Severity
builtinRefactoring :: Bool
builtinSeverity :: Severity
builtinName :: String
builtinRefactoring :: BuiltinKey -> Bool
builtinSeverity :: BuiltinKey -> Severity
builtinName :: BuiltinKey -> String
..} BuiltinValue{String
Maybe String
builtinTo :: Maybe String
builtinFrom :: String
builtinInp :: String
builtinTo :: BuiltinValue -> Maybe String
builtinFrom :: BuiltinValue -> String
builtinInp :: BuiltinValue -> String
..} = [String]
row1
  where
    row1 :: [String]
row1 = [String] -> [String]
row ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
      [ String
"<td>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
builtinName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"</td>"
      , String
"<td>"
      , String
"Example:"
      ]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
haskell String
builtinInp
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Found:"]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
haskell String
builtinFrom
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Suggestion:"]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
haskell String
to
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Does not support refactoring." | Bool -> Bool
not Bool
builtinRefactoring]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"</td>"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [ String
"<td>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Severity -> String
forall a. Show a => a -> String
show Severity
builtinSeverity String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"</td>"
      ]
    to :: String
to = case Maybe String
builtinTo of
      Maybe String
Nothing -> String
""
      Just String
"" -> String
"Perhaps you should remove it."
      Just String
s -> String
s

lhsRhsTable :: [HintRule] -> [String]
lhsRhsTable :: [HintRule] -> [String]
lhsRhsTable [HintRule]
hints =
  [String
"<table>"]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
row [String
"<th>Hint Name</th>", String
"<th>Hint</th>", String
"<th>Severity</th>"]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (HintRule -> [String]) -> [HintRule] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HintRule -> [String]
showLhsRhs [HintRule]
hints
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"</table>"]

showLhsRhs :: HintRule -> [String]
showLhsRhs :: HintRule -> [String]
showLhsRhs HintRule{String
[Note]
Maybe (HsExtendInstances (LHsExpr GhcPs))
HsExtendInstances (LHsExpr GhcPs)
Scope
Severity
hintRuleSide :: HintRule -> Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleRHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleScope :: HintRule -> Scope
hintRuleNotes :: HintRule -> [Note]
hintRuleName :: HintRule -> String
hintRuleSeverity :: HintRule -> Severity
hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleScope :: Scope
hintRuleNotes :: [Note]
hintRuleName :: String
hintRuleSeverity :: Severity
..} = [String] -> [String]
row ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
  [ String
"<td>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hintRuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"</td>"
  , String
"<td>"
  , String
"LHS:"
  ]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
haskell (HsExtendInstances (LHsExpr GhcPs) -> String
forall a. Show a => a -> String
show HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS)
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"RHS:"]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
haskell (HsExtendInstances (LHsExpr GhcPs) -> String
forall a. Show a => a -> String
show HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS)
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
"</td>"
  , String
"<td>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Severity -> String
forall a. Show a => a -> String
show Severity
hintRuleSeverity String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"</td>"
  ]