{-# 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]


-- (section, name, children)
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 [] = "" -- no need to write anything in the file
showWarningsYaml xs = BS.unpack $ Yaml.encode $ showWarningsValue xs


readWarningsFile :: FilePath -> IO [Warning]
readWarningsFile file = do
    x <- eitherM throwIO return $ Yaml.decodeFileEither file
    let res = map warningUnpath $ concatMap (f warningLabels) $ valueToVal x
    mapM_ evaluate res -- ensure exceptions happen immediately
    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


-- | Ignore all found warnings that are covered by a template
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)