{-# 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)
generateSummary :: [Setting] -> IO String
generateSummary :: [Setting] -> IO String
generateSummary [Setting]
settings = do
[(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
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
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>"]
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>"
]