-- 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 Darcs.Arguments ( showFriendly )
import Darcs.Flags ( DarcsFlag(Summary) )
import Darcs.Repository ( read_repo, withRepository, ($-) )
import Darcs.Repository.Prefs ( boring_file_filter )
import Darcs.Patch.Match ( match_parser, match_pattern, apply_matcher, Matcher,
                    make_matcher )
import Darcs.Patch.MatchData ( PatchMatch(..) )
import Darcs.Patch.Info ( PatchInfo, just_name, just_author, pi_date, pi_tag )
import Darcs.Patch.Ordered ( unsafeUnRL, concatRL )
import Darcs.Hopefully ( info )
import Darcs.Sealed ( liftSM )

import Data.Char ( isSpace )
import Data.Maybe ( catMaybes, mapMaybe, isNothing )
import Data.List ( intersperse, unfoldr )

import Text.ParserCombinators.Parsec
import Printer ( Doc, text, (<+>), (<>), parens, renderString, vcat )
import System (getArgs)
import Control.Monad.Writer
import System.Time ( formatCalendarTime )
import System.Locale ( defaultTimeLocale, rfc822DateFormat )
import System.IO (hPutStr, stderr)

type ChangeLogEntry p = ([Matcher p], Maybe Doc)

main :: IO ()
main = withRepository [] $- \repository -> do
    boring_filter <- boring_file_filter
    entries <- liftM concat $ do
        fnames <- boring_filter `liftM` getArgs
        mapM loadEntryFile fnames

    history <- do
        full_backward_history <- concatRL `liftSM` read_repo repository
        return $
            reverse $
            takeWhile (not . (apply_matcher matchTag_1_0_2)) $
            unsafeUnRL $ 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 (mapMaybe snd unmatched)
            ]

    let unlogged = filter (\p -> not $ any (`apply_matcher` p) allpatterns)
                 . filter (isNothing . pi_tag . info) $ history
         where allpatterns = concat $ map fst entries
    when (not (null unlogged)) $ do
        hPutStr stderr $ concat
           [ "\npatches which have not yet been changelogged\n\n"
           , renderDocs $ map (showFriendly [Summary]) unlogged
           ]

  where
    processPatch entries patch = do
        let pinfo = info patch
        entries' <- liftM catMaybes $ (`mapM` entries) $ \(patterns, descr) -> do
            let patterns' = filter (not . (`apply_matcher` patch)) patterns
            if null patterns'
              then do
                case descr of
                 Nothing -> return ()
                 Just d  -> tell [d]
                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 p
matchTag = match_pattern (PatternMatch "name \"^TAG \"")

matchTag_1_0_2 :: Matcher p
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 = renderString

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 =
    vcat . indent 2 '*' . map text
         . wrap 75
         . unwords . concatMap words $ descr

wrap :: Int -> String -> [String]
wrap n = unfoldr cut
 where
   cut ""  = Nothing
   cut str =
    let (xy,z)  = splitAt n str
        (_y,_x) = break isSpace (reverse xy)
        x = reverse . drop 1 $ _x
        y = reverse _y
    in Just $ if null z then      (xy, z)
              else if null x then (y ++ z, "")
                   else           (x, y ++ z)

indent :: Int -> Char -> [Doc] -> [Doc]
indent _ _ []      = []
indent n b (x:xs)  = prefixH x : map prefixT xs
 where
   prefixH h = padding n <> text [b] <+> h
   prefixT t = padding (n+1)         <+> t
   padding p = text . take p . repeat $ ' '

entry :: CharParser st (ChangeLogEntry p)
entry =
 do emptyLine
    e <- matchEntry <|> ignoreEntry
    emptyLine
    return e

ignoreEntry :: CharParser st (ChangeLogEntry p)
ignoreEntry = do
    patterns <- many1 $ do
        try (string "ignore:")
        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)
    return (patterns, Nothing)

matchEntry :: CharParser st (ChangeLogEntry p)
matchEntry = do
    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
    return (patterns, Just $ formatEntry descr)

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

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

loadEntryFile :: FilePath -> IO [ChangeLogEntry p]
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