{-# 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
{ builtinName :: !String
, builtinSeverity :: !Severity
, builtinRefactoring :: !Bool
} deriving (Eq, Ord)
data BuiltinValue = BuiltinValue
{ builtinInp :: !String
, builtinFrom :: !String
, builtinTo :: !(Maybe String)
}
dedupeBuiltin :: [(BuiltinKey, BuiltinValue)] -> [(BuiltinKey, BuiltinValue)]
dedupeBuiltin = Map.toAscList . Map.fromListWith (\_ old -> old)
-- | Generate a summary of hints, including built-in hints and YAML-configured hints
-- from @data/hlint.yaml@.
generateSummary :: [Setting] -> IO String
generateSummary 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.
builtinHints <- mkBuiltinSummary
let lhsRhsHints = [hint | SettingMatchExp hint <- settings]
pure $ genBuiltinSummaryMd builtinHints 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 = forM builtinHints $ \(name, hint) -> (name,) <$> do
let file = "src/Hint" > name <.> "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 dedupeBuiltin <$> concatForM tests $ \(TestCase _ _ inp _ _) -> do
m <- parseModuleEx defaultParseFlags file (Just inp)
pure $ case m of
Right m -> map (ideaToValue inp) $ applyHints [] hint [m]
Left _ -> []
where
ideaToValue :: String -> Idea -> (BuiltinKey, BuiltinValue)
ideaToValue 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)
v = BuiltinValue inp ideaFrom to
genBuiltinSummaryMd :: [(String, [(BuiltinKey, BuiltinValue)])] -> [HintRule] -> String
genBuiltinSummaryMd builtins lhsRhs = unlines $
[ "# Summary of Hints"
, ""
, "This page is auto-generated from `hlint --generate-summary`."
] ++
concat ["" : ("## Builtin " ++ group ) : "" : builtinTable hints | (group, hints) <- builtins] ++
[ ""
, "## Configured hints"
, ""
]
++ lhsRhsTable lhsRhs
row :: [String] -> [String]
row xs = ["
"] ++ xs ++ ["
"]
-- | Render using if it is single-line, otherwise using .
haskell :: String -> [String]
haskell s
| '\n' `elem` s = ["", s, "
"]
| otherwise = ["", s, "
", "
"]
builtinTable :: [(BuiltinKey, BuiltinValue)] -> [String]
builtinTable builtins =
["
"]
++ row ["Hint Name | ", "Hint | ", "Severity | "]
++ concatMap (uncurry showBuiltin) builtins
++ ["
"]
showBuiltin :: BuiltinKey -> BuiltinValue -> [String]
showBuiltin BuiltinKey{..} BuiltinValue{..} = row1
where
row1 = row $
[ "" ++ builtinName ++ " | "
, ""
, "Example:"
]
++ haskell builtinInp
++ ["Found:"]
++ haskell builtinFrom
++ ["Suggestion:"]
++ haskell to
++ ["Does not support refactoring." | not builtinRefactoring]
++ [" | "] ++
[ "" ++ show builtinSeverity ++ " | "
]
to = case builtinTo of
Nothing -> ""
Just "" -> "Perhaps you should remove it."
Just s -> s
lhsRhsTable :: [HintRule] -> [String]
lhsRhsTable hints =
[""]
++ row ["Hint Name | ", "Hint | ", "Severity | "]
++ concatMap showLhsRhs hints
++ ["
"]
showLhsRhs :: HintRule -> [String]
showLhsRhs HintRule{..} = row $
[ "" ++ hintRuleName ++ " | "
, ""
, "LHS:"
]
++ haskell (show hintRuleLHS)
++ ["RHS:"]
++ haskell (show hintRuleRHS)
++
[ " | "
, "" ++ show hintRuleSeverity ++ " | "
]