hlint-3.10: src/Summary.hs

{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DataKinds #-}

module Summary (generateMdSummary, generateJsonSummary, generateExhaustiveConfig) where

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

import Idea
import Apply
import Hint.Type
import Hint.All
import Config.Type
import Test.Annotations
import Deriving.Aeson
import Data.Aeson (encode)
import Data.ByteString.Char8 (unpack)
import Data.ByteString.Lazy (toStrict)

data Summary = Summary
  { sBuiltinRules :: ![BuiltinHint]
  , sLhsRhsRules :: ![HintRule]
  } deriving (Show, Generic)
  deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "s", CamelToSnake)] Summary

data BuiltinHint = BuiltinHint
  { hName :: !String
  , hSeverity :: !Severity
  , hRefactoring :: !Bool
  , hCategory :: !String
  , hExamples :: ![BuiltinExample]
  } deriving (Show, Eq, Ord, Generic)
  deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "h", CamelToSnake)] BuiltinHint

data BuiltinKey = BuiltinKey
  { kName :: !String
  , kSeverity :: !Severity
  , kRefactoring :: !Bool
  , kCategory :: !String
  } deriving (Show, Eq, Ord)

data BuiltinExample = BuiltinExample
    { eContext :: !String
    , eFrom :: !String
    , eTo :: !(Maybe String)
    } deriving (Show, Eq, Ord, Generic)
    deriving (ToJSON) via CustomJSON '[FieldLabelModifier (StripPrefix "e", CamelToSnake)] BuiltinExample

dedupBuiltin :: [(BuiltinKey, BuiltinExample)] -> [BuiltinHint]
dedupBuiltin = fmap makeHint . Map.toAscList . Map.fromListWith (<>) . fmap exampleToList where
  exampleToList (k, e) = (k, [e])
  makeHint (BuiltinKey{..}, examples) = BuiltinHint
    kName
    kSeverity
    kRefactoring
    kCategory
    examples

-- | The summary of built-in hints is generated by running the test cases in
-- @src/Hint/*.hs@.
mkBuiltinSummary :: IO [BuiltinHint]
mkBuiltinSummary = concatForM builtinHints $ \(category, hint) -> do
    let file = "src/Hint" </> category <.> "hs"
    b <- doesFileExist file
    if not b then do
        putStrLn $ "Couldn't find source hint file " ++ file ++ ", some hints will be missing"
        pure []
     else do
        tests <- parseTestFile file
        fmap dedupBuiltin <$> concatForM tests $ \(TestCase _ _ inp _ _) -> do
            m <- parseModuleEx defaultParseFlags file (Just inp)
            pure $ case m of
                Right m -> map (ideaToValue category inp) $ applyHints [] hint [m]
                Left _ -> []
    where
        ideaToValue :: String -> String -> Idea -> (BuiltinKey, BuiltinExample)
        ideaToValue category inp Idea{..} = (k, v)
            where
                -- make sure Windows/Linux don't differ on path separators
                to = fmap (\x -> if "Combine with " `isPrefixOf` x then replace "\\" "/" x else x) ideaTo
                k = BuiltinKey ideaHint ideaSeverity (notNull ideaRefactoring) category
                v = BuiltinExample inp ideaFrom to

getSummary :: [Setting] -> IO Summary
getSummary settings = do
  builtinHints <- mkBuiltinSummary
  let lhsRhsHints = [hint | SettingMatchExp hint <- settings]
  pure $ Summary builtinHints lhsRhsHints

jsonToString :: ToJSON a => a -> String
jsonToString = unpack . toStrict . encode

-- | Generate a summary of hints, including built-in hints and YAML-configured hints
generateMdSummary :: [Setting] -> IO String
generateMdSummary = fmap genSummaryMd . getSummary

generateJsonSummary :: [Setting] -> IO String
generateJsonSummary = fmap jsonToString . getSummary

generateExhaustiveConfig :: Severity -> [Setting] -> IO String
generateExhaustiveConfig severity = fmap (genExhaustiveConfig severity) . getSummary

genExhaustiveConfig :: Severity -> Summary -> String
genExhaustiveConfig severity Summary{..} = unlines $
  [ "# HLint configuration file"
  , "# https://github.com/ndmitchell/hlint"
  , "##########################"
  , ""
  , "# This file contains a template configuration file, which is typically"
  , "# placed as .hlint.yaml in the root of your project"
  , ""
  , "# All built-in hints"
  ]
    ++ (mkLine <$> sortDedup (hName <$> sBuiltinRules))
    ++ ["", "# All LHS/RHS hints"]
    ++ (mkLine <$> sortDedup (hintRuleName <$> sLhsRhsRules))
  where
    sortDedup = fmap (NE.head . NE.fromList) . group . sort
    mkLine name = "- " <> show severity <> ": {name: " <> jsonToString name <> "}"

genSummaryMd :: Summary -> String
genSummaryMd Summary{..} = unlines $
  [ "# Summary of Hints"
  , ""
  , "This page is auto-generated from `hlint --generate-summary`."
  ] ++
  concat ["" : ("## Builtin " ++ group ) : "" : builtinTable hints | (group, hints) <- groupHintsByCategory sBuiltinRules] ++
  [ ""
  , "## Configured hints"
  , ""
  ]
  ++ lhsRhsTable sLhsRhsRules
  where
    groupHintsByCategory = Map.toAscList . Map.fromListWith (<>) . fmap keyCategory
    keyCategory hint = (hCategory hint, [hint])

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

-- | Render using <code> if it is single-line, otherwise using <pre>.
haskell :: String -> [String]
haskell s
  | '\n' `elem` s = ["<pre>", s, "</pre>"]
  | otherwise = ["<code>", s, "</code>", "<br>"]

builtinTable :: [BuiltinHint] -> [String]
builtinTable builtins =
  ["<table>"]
  ++ row ["<th>Hint Name</th>", "<th>Hint</th>", "<th>Severity</th>"]
  ++ concatMap showBuiltin builtins
  ++ ["</table>"]

showBuiltin :: BuiltinHint -> [String]
showBuiltin BuiltinHint{..} = row1
  where
    row1 = row $
      [ "<td>" ++ hName ++ "</td>", "<td>"]
      ++ showExample (NE.head (NE.fromList hExamples))
      ++ ["Does not support refactoring." | not hRefactoring]
      ++ ["</td>"] ++
      [ "<td>" ++ show hSeverity ++ "</td>"
      ]
    showExample BuiltinExample{..} =
      ["Example: "]
        ++ haskell eContext
        ++ ["Found:"]
        ++ haskell eFrom
        ++ ["Suggestion:"]
        ++ haskell eTo'
      where
      eTo' = case eTo of
        Nothing -> ""
        Just "" -> "Perhaps you should remove it."
        Just s -> s

lhsRhsTable :: [HintRule] -> [String]
lhsRhsTable hints =
  ["<table>"]
  ++ row ["<th>Hint Name</th>", "<th>Hint</th>", "<th>Severity</th>"]
  ++ concatMap showLhsRhs hints
  ++ ["</table>"]

showLhsRhs :: HintRule -> [String]
showLhsRhs HintRule{..} = row $
  [ "<td>" ++ hintRuleName ++ "</td>"
  , "<td>"
  , "LHS:"
  ]
  ++ haskell (show hintRuleLHS)
  ++ ["RHS:"]
  ++ haskell (show hintRuleRHS)
  ++
  [ "</td>"
  , "<td>" ++ show hintRuleSeverity ++ "</td>"
  ]