module Darcs.Annotate
(
annotate
, annotateDirectory
, format
, machineFormat
) where
import Prelude hiding ( pi )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.Map as M
import qualified Data.Vector as V
import Data.List( nub, groupBy )
import Data.Maybe( isJust, catMaybes, isNothing )
import Control.Monad.State ( modify, when, gets, State, execState )
import Control.Applicative( (<$>) )
import Darcs.Patch.ApplyMonad( ApplyMonad(..) )
import Darcs.Patch.FileName( FileName, movedirfilename, fn2ps, ps2fn )
import Darcs.Patch.Apply ( Apply, apply, ApplyState )
import Darcs.Patch.Info ( PatchInfo(..), humanFriendly, piAuthor, makeFilename )
import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd )
import Darcs.Witnesses.Ordered
import Storage.Hashed.Tree( Tree )
import Lcs( getChanges )
import Printer( renderString )
import ByteStringUtils ( linesPS, unlinesPS )
#include "gadts.h"
#include "impossible.h"
data FileOrDirectory = File
| Directory
deriving (Show, Eq)
data Annotated = Annotated
{ annotated :: V.Vector (Maybe PatchInfo, B.ByteString)
, current :: [(Int, B.ByteString)]
, path :: Maybe FileName
, what :: FileOrDirectory
, currentInfo :: PatchInfo
} deriving Show
type AnnotatedM = State Annotated
instance ApplyMonad AnnotatedM Tree where
type ApplyMonadBase AnnotatedM = AnnotatedM
nestedApply _ _ = undefinedFun "nestedApply"
liftApply _ _ = undefinedFun "liftApply"
getApplyState = undefinedFun "getApplyState"
putApplyState _ = undefinedFun "putApplyState"
mReadFilePS = undefinedFun "mReadFilePS"
mDoesFileExist _ = return True
mDoesDirectoryExist _ = return True
mCreateDirectory _ = return ()
mCreateFile _ = return ()
mRemoveFile f = do
p <- gets path
when (p == Just f) $ modify (\x -> x { path = Nothing })
updateDirectory f
mRemoveDirectory = mRemoveFile
mRename a b = do
p <- gets path
w <- gets what
when (isJust p) $
modify $ \st -> st { path = Just $ movedirfilename a b (fromJust p) }
when (w == Directory) $ do
let fix (i, x) = (i, fn2ps $ movedirfilename a b (ps2fn x))
modify $ \st -> st { current = map fix $ current st }
mModifyFilePS f job = do
p <- gets path
when (p == Just f) $ updateFile (fmap linesPS . job . unlinesPS)
mModifyFilePSs f job = do
p <- gets path
when (p == Just f) $ updateFile job
undefinedFun :: Monad m
=> String
-> m a
undefinedFun name = fail $ name ++ " undefined for Annotated"
updateFile :: ([B.ByteString]
-> AnnotatedM [B.ByteString])
-> AnnotatedM ()
updateFile job = (==File) <$> gets what >>= flip when go
where
go = do
before <- map snd `fmap` gets current
after <- job before
reannotate $ getChanges before after
reannotate [] = return ()
reannotate ((off, remove, add):rest) = do
i <- gets currentInfo
c <- gets current
a <- gets annotated
modify $ \s -> s { current = take off c ++ [ (1, x) | x <- add ] ++
drop (off + length remove) c
, annotated = merge i a $ take (length remove) $ drop off c
}
reannotate rest
merge i a l = a V.// [ (line, (Just i, B.empty))
| (line, _) <- l, line >= 0 && line < V.length a]
updateDirectory :: FileName -> AnnotatedM ()
updateDirectory p = (==Directory) <$> gets what >>= flip when go
where
go = do let line = fn2ps p
files <- gets current
case filter ((==line) . snd) files of
[match@(ident, _)] -> reannotate ident match line
_ -> return ()
reannotate ident match line =
modify $ \x -> x { annotated = annotated x V.// [ (ident, update line $ currentInfo x) ]
, current = filter (/= match) $ current x }
update line inf = (Just inf, BC.concat [ " -- created as: ", line ])
complete :: Annotated -> Bool
complete x = (V.all (isJust . fst) $ annotated x) || (isNothing $ path x)
annotate' :: (Apply p, ApplyState p ~ Tree)
=> FL (PatchInfoAnd p) C(x y)
-> Annotated
-> Annotated
annotate' NilFL ann = ann
annotate' (p :>: ps) ann
| complete ann = ann
| otherwise = annotate' ps $ execState (apply p) (ann { currentInfo = info p })
annotate :: (Apply p, ApplyState p ~ Tree)
=> FL (PatchInfoAnd p) C(x y)
-> FileName
-> B.ByteString
-> Annotated
annotate patches inipath inicontent = annotate' patches initial
where
initial = Annotated { path = Just inipath
, currentInfo = error "There is no currentInfo."
, current = zip [0..] (linesPS inicontent)
, what = File
, annotated = V.replicate (length $ breakLines inicontent)
(Nothing, B.empty)
}
annotateDirectory :: (Apply p, ApplyState p ~ Tree)
=> FL (PatchInfoAnd p) C(x y)
-> FileName
-> [FileName]
-> Annotated
annotateDirectory patches inipath inicontent = annotate' patches initial
where
initial = Annotated { path = Just inipath
, currentInfo = error "There is no currentInfo."
, current = zip [0..] (map fn2ps inicontent)
, what = Directory
, annotated = V.replicate (length inicontent) (Nothing, B.empty)
}
machineFormat :: B.ByteString -> Annotated -> String
machineFormat d a = unlines [ case i of
Just inf -> makeFilename inf
Nothing ->
"19700101000000-0000-0000000000000000000000000000000000000000.gz"
++ " | " ++ BC.unpack line ++ " " ++ BC.unpack add
| ((i, add), line) <- zip (V.toList $ annotated a) (breakLines d) ]
format :: B.ByteString
-> Annotated
-> String
format d a = pi_list ++ "\n" ++ file
where
pi_list = unlines $ [ show n ++ ": " ++ renderString (humanFriendly i)
| (n :: Int, i) <- zip [1..] pis ]
file = concat [ annotation (fst $ head chunk) ++ " | " ++ line (head chunk) ++
"\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- tail chunk ]
| chunk <- file_ann ]
pis = nub $ catMaybes . map fst $ V.toList (annotated a)
pi_map = M.fromList (zip pis [1 :: Int ..])
file_ann = groupBy (\x y -> fst x == fst y) $ zip (V.toList $ annotated a) (breakLines d)
line ((_, add), l) = BC.unpack $ BC.concat [l, " ", add]
annotation (Just i, _) | Just n <- M.lookup i pi_map =
pad 20 (piMail i) ++ " " ++ pad 4 ("#" ++ show n)
annotation _ = pad 25 "unknown"
pad n str = replicate (n length str) ' ' ++ (take n str)
indent n str = replicate n ' ' ++ str
piMail pi
| '<' `elem` piAuthor pi = takeWhile (/= '>') . drop 1 . dropWhile (/= '<') $ piAuthor pi
| otherwise = piAuthor pi
breakLines :: BC.ByteString
-> [BC.ByteString]
breakLines s = case BC.split '\n' s of
[] -> []
split | BC.null (last split) -> init split
| otherwise -> split