{-# 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 = ["
"] ++ xs ++ ["
"]
-- | Render using if it is single-line, otherwise using .
haskell :: String -> [String]
haskell s
| '\n' `elem` s = ["", s, "
"]
| otherwise = ["", s, "
", "
"]
builtinTable :: [BuiltinHint] -> [String]
builtinTable builtins =
["
"]
++ row ["Hint Name | ", "Hint | ", "Severity | "]
++ concatMap showBuiltin builtins
++ ["
"]
showBuiltin :: BuiltinHint -> [String]
showBuiltin BuiltinHint{..} = row1
where
row1 = row $
[ "" ++ hName ++ " | ", ""]
++ showExample (NE.head (NE.fromList hExamples))
++ ["Does not support refactoring." | not hRefactoring]
++ [" | "] ++
[ "" ++ show hSeverity ++ " | "
]
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 =
[""]
++ 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 ++ " | "
]