-- Copyright (C) 2002-2003 David Roundy -- -- 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. {-# OPTIONS_GHC -cpp -fno-warn-orphans #-} {-# LANGUAGE CPP #-} 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 ' ' -- skipping context old <- work $ linesStartingWith '-' new <- work $ linesStartingWith '+' work $ linesStartingWith ' ' -- skipping context 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 -- * Binary file modification -- -- | Modify a binary file -- -- > binary FILENAME -- > oldhex -- > *HEXHEXHEX -- > ... -- > newhex -- > *HEXHEXHEX -- > ... 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)