-- Copyright (C) 2005 Tomasz Zielonka
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program;  see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

module Main (main) where

import Repository ( read_repo, identifyRepository )
import RepoPrefs ( boring_file_filter )
import PatchMatch ( match_parser, match_pattern, apply_matcher, Matcher,
                    make_matcher )
import PatchMatchData ( PatchMatch(..) )
import PatchInfo ( PatchInfo, just_name, just_author, pi_date )
import Data.Maybe ( catMaybes )
import Data.List ( intersperse )

import Text.ParserCombinators.Parsec
import Text.PrettyPrint ( Doc, text, (<+>), nest, parens, fsep,
                          renderStyle, Style(..), Mode(PageMode) )
import System (getArgs)
import Control.Monad.Writer
import System.Time ( formatCalendarTime )
import System.Locale ( defaultTimeLocale, rfc822DateFormat )
import System.IO (hPutStr, stderr)

type ChangeLogEntry = ([Matcher], Doc)

main :: IO ()
main = do
    boring_filter <- boring_file_filter
    entries <- liftM concat $ do
        fnames <- boring_filter `liftM` getArgs
        mapM loadEntryFile fnames

    history <- do
        repository <- identifyRepository "."
        full_backward_history <- liftM concat (read_repo repository)
        return $
            reverse $
            takeWhile (not . (apply_matcher matchTag_1_0_2)) $
            full_backward_history

    let (unmatched, docs) = runWriter (foldM processPatch entries history)

    putStr (renderDocs (reverse docs))

    when (not (null unmatched)) $ do
        hPutStr stderr $ concat
            [ "\nunmatched ChangeLog entries (upcoming?):\n\n"
            , renderDocs (map snd unmatched)
            ]
  where
    processPatch entries patch@(pinfo, _) = do
        entries' <- liftM catMaybes $ (`mapM` entries) $ \(patterns, descr) -> do
            let patterns' = filter (not . (`apply_matcher` patch)) patterns
            if null patterns'
              then do
                tell [descr]
                return Nothing
              else do
                return (Just (patterns', descr))
        when (matchTag `apply_matcher` patch) $ do
            let 'T':'A':'G':' ':tagName = just_name pinfo
            when (isStableTag tagName) $ do
                tell [text (" -- " ++ just_author pinfo ++ "  " ++ show_pi_date pinfo)]
                tell [text "darcs" <+> parens (text tagName)]
        return entries'

show_pi_date :: PatchInfo -> String
show_pi_date pinfo =
    formatCalendarTime defaultTimeLocale rfc822DateFormat (pi_date pinfo)

matchTag :: Matcher
matchTag = match_pattern (PatternMatch "name \"^TAG \"")

matchTag_1_0_2 :: Matcher
matchTag_1_0_2 = match_pattern (PatternMatch "exact \"TAG 1.0.2\"")

isStableTag :: String -> Bool
isStableTag tagName = 
    case parse p "" tagName of
        Left _ -> False
        Right _ -> True
  where
    p = do
        many1 digit
        char '.'
        many1 digit
        char '.'
        many1 digit
        many letter
        many digit
        eof

render :: Doc -> String
render doc = renderStyle style doc
  where
    style = Style { mode = PageMode,
                    lineLength = 78,
                    ribbonsPerLine = 1 }

renderDocs :: [Doc] -> String
renderDocs = unlines . intersperse "" . map render

--------------------------------------------------------------------------------
-- Parsing ChangeLog entries

restOfLine :: CharParser st String
restOfLine = do
    rest <- many (noneOf "\r\n")
    optional (char '\r')
    return rest

formatEntry :: [String] -> Doc
formatEntry descr =
    nest 2 (text "*") <+> fsep (map text (concatMap words descr))

entry :: CharParser st ChangeLogEntry
entry = do
    emptyLine
    patterns <- many1 $ do
        try (string "match:")
        startPos <- getPosition
        -- take the characters to the end of line
        s <- restOfLine
        endState <- getParserState
        -- and parse them again as a match pattern
        setPosition startPos
        setInput s
        m <- match_parser
        -- restore parser state
        setParserState endState
        newline
        return (make_matcher s m)
    emptyLine
    descr <- many1 $ do
        char '>'
        skipMany (char ' ' <|> char '\t')
        cs <- restOfLine
        newline
        return cs
    emptyLine
    return (patterns, formatEntry descr)

emptyLine :: CharParser st ()
emptyLine = skipMany $ do optional (char '#' >> restOfLine)
                          newline

entryFile :: CharParser st [ChangeLogEntry]
entryFile = do es <- many entry
               eof
               return es

loadEntryFile :: FilePath -> IO [ChangeLogEntry]
loadEntryFile fname = do
    cs <- readFile fname -- ratify readFile: not part of darcs executable
    case parse entryFile fname cs of
        Left err -> fail (show err)
        Right x -> return x