-- 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