{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
module Warning(
Warning(..),
showWarningsPretty,
showWarningsYaml,
showWarningsJson,
readWarningsFile,
ignoreWarnings
) where
import Cabal
import Util
import Control.Monad.Extra
import Data.Maybe
import Data.List.Extra
import Control.Exception
import Data.Aeson as JSON
import Data.Yaml as Yaml
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.HashMap.Strict as Map
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
data Warning = Warning
{warningPackage :: String
,warningSections :: [CabalSectionType]
,warningMessage :: String
,warningDepends :: Maybe PackageName
,warningModule :: Maybe ModuleName
,warningIdentifier :: Maybe IdentName
} deriving (Show,Eq,Ord)
warningLabels = ["package","section","message","depends","module","identifier"]
warningPath :: Warning -> [Maybe String]
warningPath Warning{..} =
[Just warningPackage
,Just $ unwords $ map show warningSections
,Just warningMessage
,warningDepends
,warningModule
,warningIdentifier]
warningUnpath :: [String] -> Warning
warningUnpath [pkg,sect,msg,deps,mod,ident] = Warning
pkg (map read $ words sect) msg
(f deps) (f mod) (f ident)
where f s = if null s then Nothing else Just s
showWarningsPretty :: PackageName -> [Warning] -> [String]
showWarningsPretty pkg [] = ["= Package " ++ pkg ++ " =","No warnings"]
showWarningsPretty _ warn = warningTree
([\x -> "= Package " ++ x ++ " =",\x -> "\n== Section " ++ x ++ " ==",id,("* "++),(" - "++)] ++ repeat id) $
map (catMaybes . warningPath) warn
warningTree :: Ord a => [a -> a] -> [[a]] -> [a]
warningTree (f:fs) xs = concat
[ f title : warningTree fs inner
| (title,inner) <- groupSort $ mapMaybe uncons xs]
data Val = Val String String [Val]
| End String [String]
deriving Show
valToValue :: [Val] -> Value
valToValue = Array . V.fromList . map f
where
pair k v = Object $ Map.singleton (T.pack k) v
f (Val sect name xs) = pair sect $ Array $ V.fromList $
pair "name" (String $ T.pack name) : map f xs
f (End sect [x]) = pair sect $ String $ T.pack x
f (End sect xs) = pair sect $ Array $ V.fromList $ map (String . T.pack) xs
valueToVal :: Value -> [Val]
valueToVal = f
where
badYaml want x = error $ "Failed to understand Yaml fragment, expected " ++ want ++ ", got:\n" ++ BS.unpack (Yaml.encode x)
f Null = []
f (Object mp) | Map.null mp = []
f (Array xs) = concatMap f $ V.toList xs
f (Object mp) | [(k,v)] <- Map.toList mp = return $ case v of
v | Just (n, rest) <- findName v -> Val (T.unpack k) (T.unpack n) $ f rest
v | Just xs <- fromStrings v -> End (T.unpack k) xs
String x -> End (T.unpack k) [T.unpack x]
_ -> badYaml "either a dict with 'name' or a list/single string" $ Object mp
f x = badYaml "either a singleton dict or an array" x
fromStrings (Array xs) = concatMapM fromStrings $ V.toList xs
fromStrings (String x) = Just [T.unpack x]
fromStrings x = Nothing
findName (Array xs)
| ([name], rest) <- partition (isJust . fromName) $ V.toList xs
= Just (fromJust $ fromName name, Array $ V.fromList rest)
findName _ = Nothing
fromName (Object mp) | [(k,String v)] <- Map.toList mp, T.unpack k == "name" = Just v
fromName _ = Nothing
showWarningsValue :: [Warning] -> Value
showWarningsValue = valToValue . f warningLabels . map (dropWhileEnd isNothing . warningPath)
where
f (name:names) xs
| all (\x -> length x <= 1) xs = [End name $ sort [x | [Just x] <- xs] | xs /= []]
| otherwise = concat
[ case a of
Nothing -> f names b
Just a -> [Val name a $ f names b]
| (a,b) <- groupSort $ mapMaybe uncons xs]
showWarningsJson :: [Warning] -> String
showWarningsJson = LBS.unpack . JSON.encode . showWarningsValue
showWarningsYaml :: [Warning] -> String
showWarningsYaml [] = ""
showWarningsYaml xs = BS.unpack $ Yaml.encode $ showWarningsValue xs
readWarningsFile :: FilePath -> IO [Warning]
readWarningsFile file = do
x <- either throwIO return =<< Yaml.decodeFileEither file
let res = map warningUnpath $ concatMap (f warningLabels) $ valueToVal x
mapM_ evaluate res
return res
where
f :: [String] -> Val -> [[String]]
f names (End sect ns) = concatMap (\n -> f names $ Val sect n []) ns
f (name:names) val@(Val sect n xs)
| sect == name = if null xs
then [n : replicate (length names) ""]
else map (n:) $ concatMap (f names) xs
| sect `notElem` names = error $
"Warnings file " ++ file ++ ", invalid section name:\n" ++
"Wanted one of: " ++ show (name:names) ++ "\n" ++
"Got: " ++ show sect
| otherwise = map ("":) $ f names val
ignoreWarnings :: [Warning] -> [Warning] -> [Warning]
ignoreWarnings template = filter (\x -> not $ any (`match` x) template)
where
unpack = map (fromMaybe "") . warningPath
match template found = and $ zipWith (\t f -> t == "" || t == f) (unpack template) (unpack found)