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, decodeWhite )
import Darcs.Patch.Core ( Patch(..), Named(..) )
import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..),
DirPatchType(..), FilePatchType(..),
hunk, binary )
import Darcs.Patch.Commute ( merger )
import Darcs.Patch.Patchy ( invert )
import Darcs.Patch.Info ( PatchInfo, readPatchInfo )
import Darcs.Patch.ReadMonads (ParserM, work, maybeWork, alterInput,
parseStrictly, peekInput, lexString, lexEof, myLex)
#include "impossible.h"
import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL )
import Darcs.Witnesses.Ordered ( FL(..), unsafeCoerceP )
import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal )
readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString)
readPatch ps = case parseStrictly (readPatch' False) ps of
Just (Just p, ps') -> Just (p, ps')
_ -> Nothing
instance ReadPatch p => ReadPatch (Named p) where
readPatch' want_eof
= do s <- peekInput
case liftM (BC.unpack . fst) $ myLex 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 <- peekInput
case liftM (BC.unpack . fst) $ myLex s of
Just "{}" -> do work myLex
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 (readPatch' False) (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}')
case mps of
Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps
Nothing -> do s <- peekInput
case liftM (BC.unpack . fst) $ myLex s of
Just "merger" -> liftM (Just . seal) $ readMerger True
Just "regrem" -> liftM (Just . seal) $ readMerger False
_ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof
readPatches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x )))
readPatches x str want_eof
= do mp <- readPrim x
case mp of
Nothing -> do unit <- lexString str
case unit of
() -> if want_eof then do unit' <- lexEof
case unit' of
() -> return $ seal NilFL
else return $ seal NilFL
Just (Sealed p) -> do Sealed ps <- readPatches x str want_eof
return $ seal (p:>:ps)
readSplit :: ParserM m => FileNameFormat -> m (Sealed (Prim C(x )))
readSplit x = do
work myLex
ps <- readPatches x ")" False
return $ Split `mapSeal` ps
readFileName :: FileNameFormat -> B.ByteString -> FileName
readFileName OldFormat = ps2fn
readFileName NewFormat = fp2fn . decodeWhite . BC.unpack
readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y))
readHunk x = do
work myLex
fi <- work myLex
l <- work readIntPS
have_nl <- skipNewline
if have_nl
then do work $ linesStartingWith ' '
old <- work $ linesStartingWith '-'
new <- work $ linesStartingWith '+'
work $ linesStartingWith ' '
return $ hunk (fn2fp $ readFileName x fi) l old new
else return $ hunk (fn2fp $ readFileName x fi) l [] []
skipNewline :: ParserM m => m Bool
skipNewline = do s <- peekInput
if B.null s
then return False
else if BC.head s /= '\n'
then return False
else alterInput B.tail >> return True
readTok :: ParserM m => FileNameFormat -> m (Prim C(x y))
readTok x = do
work myLex
f <- work myLex
regstr <- work myLex
o <- work myLex
n <- work myLex
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 myLex
fi <- work myLex
work myLex
alterInput dropSpace
old <- work $ linesStartingWith '*'
work myLex
alterInput dropSpace
new <- work $ linesStartingWith '*'
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 myLex
f <- work myLex
return $ FP (readFileName x f) AddFile
readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y))
readRmFile x = do work myLex
f <- work myLex
return $ FP (readFileName x f) RmFile
readMove :: ParserM m => FileNameFormat -> m (Prim C(x y))
readMove x = do work myLex
d <- work myLex
d' <- work myLex
return $ Move (readFileName x d) (readFileName x d')
readChangePref :: ParserM m => m (Prim C(x y))
readChangePref
= do work myLex
p <- work myLex
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 myLex
f <- work myLex
return $ DP (readFileName x f) AddDir
readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y))
readRmDir x = do work myLex
f <- work myLex
return $ DP (readFileName x f) RmDir
readMerger :: ParserM m => Bool -> m (Patch C(x y))
readMerger b = do work myLex
g <- work myLex
lexString "("
Just (Sealed p1) <- readPatch' False
Just (Sealed p2) <- readPatch' False
lexString ")"
Sealed m <- return $ merger (BC.unpack g) p1 p2
return $ if b then unsafeCoerceP m else unsafeCoerceP (invert m)
readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x )))
readNamed want_eof
= do mn <- maybeWork readPatchInfo
case mn of
Nothing -> bug "readNamed 1"
Just n ->
do d <- readDepends
Just p <- readPatch' want_eof
return $ (NamedP n d) `mapSeal` p
readDepends :: ParserM m => m [PatchInfo]
readDepends = do s <- peekInput
case myLex s of
Just (xs, _) | BC.unpack xs == "<" ->
do work myLex
readPis
_ -> return []
readPis :: ParserM m => m [PatchInfo]
readPis = do mpi <- maybeWork readPatchInfo
case mpi of
Just pi -> do pis <- readPis
return (pi:pis)
Nothing -> do alterInput (B.tail . BC.dropWhile (/= '>'))
return []
linesStartingWith :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString)
linesStartingWith 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)