{-# 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 = ["<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 :: [(BuiltinKey, BuiltinValue)] -> [String]
builtinTable builtins =
  ["<table>"]
  ++ row ["<th>Hint Name</th>", "<th>Hint</th>", "<th>Severity</th>"]
  ++ concatMap (uncurry showBuiltin) builtins
  ++ ["</table>"]

showBuiltin :: BuiltinKey -> BuiltinValue -> [String]
showBuiltin BuiltinKey{..} BuiltinValue{..} = row1
  where
    row1 = row $
      [ "<td>" ++ builtinName ++ "</td>"
      , "<td>"
      , "Example:"
      ]
      ++ haskell builtinInp
      ++ ["Found:"]
      ++ haskell builtinFrom
      ++ ["Suggestion:"]
      ++ haskell to
      ++ ["Does not support refactoring." | not builtinRefactoring]
      ++ ["</td>"] ++
      [ "<td>" ++ show builtinSeverity ++ "</td>"
      ]
    to = case builtinTo 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>"
  ]