module Darcs.Patch.Read ( readPrim, readPatch )
where
import Prelude hiding ( pi )
import Control.Monad ( liftM )
#include "gadts.h"
import ByteStringUtils ( breakFirstPS, fromHex2PS, readIntPS, dropSpace )
import qualified Data.ByteString.Char8 as BC (head, unpack, dropWhile, break)
import qualified Data.ByteString as B (ByteString, null, init, tail, empty, concat)
import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, ps2fn, decode_white )
import Darcs.Patch.Core ( Patch(..), Named(..) )
import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..),
DirPatchType(..), FilePatchType(..),
hunk, binary )
#ifndef GADT_WITNESSES
import Darcs.Patch.Commute ( merger )
import Darcs.Patch.Patchy ( invert )
#endif
import Darcs.Patch.Info ( PatchInfo, readPatchInfo )
import Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input,
parse_strictly, peek_input, lex_string, lex_eof, my_lex)
#include "impossible.h"
import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL )
import Darcs.Witnesses.Ordered ( FL(..) )
import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal )
readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString)
readPatch ps = case parse_strictly (readPatch' False) ps of
Just (Just p, ps') -> Just (p, ps')
_ -> Nothing
instance ReadPatch p => ReadPatch (Named p) where
readPatch' want_eof
= do s <- peek_input
case liftM (BC.unpack . fst) $ my_lex s of
Just ('[':_) -> liftM Just $ readNamed want_eof
_ -> return Nothing
instance ReadPatch Prim where
readPatch' _ = readPrim OldFormat
readPrim :: ParserM m => FileNameFormat -> m (Maybe (Sealed (Prim C(x ))))
readPrim x
= do s <- peek_input
case liftM (BC.unpack . fst) $ my_lex s of
Just "{}" -> do work my_lex
return $ Just $ seal Identity
Just "(" -> liftM Just $ readSplit x
Just "hunk" -> liftM (Just . seal) $ readHunk x
Just "replace" -> liftM (Just . seal) $ readTok x
Just "binary" -> liftM (Just . seal) $ readBinary x
Just "addfile" -> liftM (Just . seal) $ readAddFile x
Just "adddir" -> liftM (Just . seal) $ readAddDir x
Just "rmfile" -> liftM (Just . seal) $ readRmFile x
Just "rmdir" -> liftM (Just . seal) $ readRmDir x
Just "move" -> liftM (Just . seal) $ readMove x
Just "changepref" -> liftM (Just . seal) $ readChangePref
_ -> return Nothing
instance ReadPatch Patch where
readPatch' want_eof
= do mps <- bracketedFL (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}')
case mps of
Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps
Nothing -> do s <- peek_input
case liftM (BC.unpack . fst) $ my_lex s of
#ifndef GADT_WITNESSES
Just "merger" -> liftM (Just . seal) $ readMerger True
Just "regrem" -> liftM (Just . seal) $ readMerger False
#endif
_ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof
read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x )))
read_patches x str want_eof
= do mp <- readPrim x
case mp of
Nothing -> do unit <- lex_string str
case unit of
() -> if want_eof then do unit' <- lex_eof
case unit' of
() -> return $ seal NilFL
else return $ seal NilFL
Just (Sealed p) -> do Sealed ps <- read_patches x str want_eof
return $ seal (p:>:ps)
readSplit :: ParserM m => FileNameFormat -> m (Sealed (Prim C(x )))
readSplit x = do
work my_lex
ps <- read_patches x ")" False
return $ Split `mapSeal` ps
readFileName :: FileNameFormat -> B.ByteString -> FileName
readFileName OldFormat = ps2fn
readFileName NewFormat = fp2fn . decode_white . BC.unpack
readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y))
readHunk x = do
work my_lex
fi <- work my_lex
l <- work readIntPS
have_nl <- skip_newline
if have_nl
then do work $ lines_starting_with ' '
old <- work $ lines_starting_with '-'
new <- work $ lines_starting_with '+'
work $ lines_starting_with ' '
return $ hunk (fn2fp $ readFileName x fi) l old new
else return $ hunk (fn2fp $ readFileName x fi) l [] []
skip_newline :: ParserM m => m Bool
skip_newline = do s <- peek_input
if B.null s
then return False
else if BC.head s /= '\n'
then return False
else alter_input B.tail >> return True
readTok :: ParserM m => FileNameFormat -> m (Prim C(x y))
readTok x = do
work my_lex
f <- work my_lex
regstr <- work my_lex
o <- work my_lex
n <- work my_lex
return $ FP (readFileName x f) $ TokReplace (BC.unpack (drop_brackets regstr))
(BC.unpack o) (BC.unpack n)
where drop_brackets = B.init . B.tail
readBinary :: ParserM m => FileNameFormat -> m (Prim C(x y))
readBinary x = do
work my_lex
fi <- work my_lex
work my_lex
alter_input dropSpace
old <- work $ lines_starting_with '*'
work my_lex
alter_input dropSpace
new <- work $ lines_starting_with '*'
return $ binary (fn2fp $ readFileName x fi)
(fromHex2PS $ B.concat old)
(fromHex2PS $ B.concat new)
readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y))
readAddFile x = do work my_lex
f <- work my_lex
return $ FP (readFileName x f) AddFile
readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y))
readRmFile x = do work my_lex
f <- work my_lex
return $ FP (readFileName x f) RmFile
readMove :: ParserM m => FileNameFormat -> m (Prim C(x y))
readMove x = do work my_lex
d <- work my_lex
d' <- work my_lex
return $ Move (readFileName x d) (readFileName x d')
readChangePref :: ParserM m => m (Prim C(x y))
readChangePref
= do work my_lex
p <- work my_lex
f <- work (Just . BC.break ((==)'\n') . B.tail . BC.dropWhile (== ' '))
t <- work (Just . BC.break ((==)'\n') . B.tail)
return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t)
readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y))
readAddDir x = do work my_lex
f <- work my_lex
return $ DP (readFileName x f) AddDir
readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y))
readRmDir x = do work my_lex
f <- work my_lex
return $ DP (readFileName x f) RmDir
#ifndef GADT_WITNESSES
readMerger :: ParserM m => Bool -> m (Patch C(x y))
readMerger b = do work my_lex
g <- work my_lex
lex_string "("
Just (Sealed p1) <- readPatch' False
Just (Sealed p2) <- readPatch' False
lex_string ")"
let m = merger (BC.unpack g) p1 p2
return $ if b then m else invert m
#endif
readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x )))
readNamed want_eof
= do mn <- maybe_work readPatchInfo
case mn of
Nothing -> bug "readNamed 1"
Just n ->
do d <- read_depends
Just p <- readPatch' want_eof
return $ (NamedP n d) `mapSeal` p
read_depends :: ParserM m => m [PatchInfo]
read_depends = do s <- peek_input
case my_lex s of
Just (xs, _) | BC.unpack xs == "<" ->
do work my_lex
read_pis
_ -> return []
read_pis :: ParserM m => m [PatchInfo]
read_pis = do mpi <- maybe_work readPatchInfo
case mpi of
Just pi -> do pis <- read_pis
return (pi:pis)
Nothing -> do alter_input (B.tail . BC.dropWhile (/= '>'))
return []
lines_starting_with :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString)
lines_starting_with c thes =
Just (lsw [] thes)
where lsw acc s | B.null s || BC.head s /= c = (reverse acc, s)
lsw acc s = let s' = B.tail s
in case breakFirstPS '\n' s' of
Just (l, r) -> lsw (l:acc) r
Nothing -> (reverse (s':acc), B.empty)