1 -- Copyright (C) 2002-2003 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 {-# OPTIONS_GHC -cpp -fno-warn-orphans #-} 19 {-# LANGUAGE CPP #-} 20 21 module Darcs.Patch.Read ( readPrim, readPatch ) 22 where 23 24 import Prelude hiding ( pi ) 25 import Control.Monad ( liftM ) 26 27 #include "gadts.h" 28 29 import ByteStringUtils ( breakFirstPS, fromHex2PS, readIntPS, dropSpace ) 30 import qualified Data.ByteString.Char8 as BC (head, unpack, dropWhile, break) 31 import qualified Data.ByteString as B (ByteString, null, init, tail, empty, concat) 32 33 import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, ps2fn, decode_white ) 34 import Darcs.Patch.Core ( Patch(..), Named(..) ) 35 import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..), 36 DirPatchType(..), FilePatchType(..), 37 hunk, binary ) 38 #ifndef GADT_WITNESSES 39 import Darcs.Patch.Commute ( merger ) 40 import Darcs.Patch.Patchy ( invert ) 41 #endif 42 import Darcs.Patch.Info ( PatchInfo, readPatchInfo ) 43 import Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input, 44 parse_strictly, peek_input, lex_string, lex_eof, my_lex) 45 #include "impossible.h" 46 import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL ) 47 import Darcs.Ordered ( FL(..) ) 48 import Darcs.Sealed ( Sealed(..), seal, mapSeal ) 49 50 readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString) 51 readPatch ps = case parse_strictly (readPatch' False) ps of 52 Just (Just p, ps') -> Just (p, ps') 53 _ -> Nothing 54 55 instance ReadPatch p => ReadPatch (Named p) where 56 readPatch' want_eof 57 = do s <- peek_input 58 case liftM (BC.unpack . fst) $ my_lex s of 59 Just ('[':_) -> liftM Just $ readNamed want_eof -- ] 60 _ -> return Nothing 61 62 instance ReadPatch Prim where 63 readPatch' w = readPrim OldFormat w 64 65 readPrim :: ParserM m => FileNameFormat -> Bool -> m (Maybe (Sealed (Prim C(x )))) 66 readPrim x _ 67 = do s <- peek_input 68 case liftM (BC.unpack . fst) $ my_lex s of 69 Just "{}" -> do work my_lex 70 return $ Just $ seal Identity 71 Just "(" -> liftM Just $ readSplit x -- ) 72 Just "hunk" -> liftM (Just . seal) $ readHunk x 73 Just "replace" -> liftM (Just . seal) $ readTok x 74 Just "binary" -> liftM (Just . seal) $ readBinary x 75 Just "addfile" -> liftM (Just . seal) $ readAddFile x 76 Just "adddir" -> liftM (Just . seal) $ readAddDir x 77 Just "rmfile" -> liftM (Just . seal) $ readRmFile x 78 Just "rmdir" -> liftM (Just . seal) $ readRmDir x 79 Just "move" -> liftM (Just . seal) $ readMove x 80 Just "changepref" -> liftM (Just . seal) $ readChangePref 81 _ -> return Nothing 82 83 instance ReadPatch Patch where 84 readPatch' want_eof 85 = do mps <- bracketedFL (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}') 86 case mps of 87 Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps 88 Nothing -> do s <- peek_input 89 case liftM (BC.unpack . fst) $ my_lex s of 90 #ifndef GADT_WITNESSES 91 Just "merger" -> liftM (Just . seal) $ readMerger True 92 Just "regrem" -> liftM (Just . seal) $ readMerger False 93 #endif 94 _ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof 95 96 read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x ))) 97 read_patches x str want_eof 98 = do mp <- readPrim x False 99 case mp of 100 Nothing -> do unit <- lex_string str 101 case unit of 102 () -> if want_eof then do unit' <- lex_eof 103 case unit' of 104 () -> return $ seal NilFL 105 else return $ seal NilFL 106 Just (Sealed p) -> do Sealed ps <- read_patches x str want_eof 107 return $ seal (p:>:ps) 108 109 readSplit :: ParserM m => FileNameFormat -> m (Sealed (Prim C(x ))) 110 readSplit x = do 111 work my_lex 112 ps <- read_patches x ")" False 113 return $ Split `mapSeal` ps 114 115 readFileName :: FileNameFormat -> B.ByteString -> FileName 116 readFileName OldFormat = ps2fn 117 readFileName NewFormat = fp2fn . decode_white . BC.unpack 118 119 readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y)) 120 readHunk x = do 121 work my_lex 122 fi <- work my_lex 123 l <- work readIntPS 124 have_nl <- skip_newline 125 if have_nl 126 then do work $ lines_starting_with ' ' -- skipping context 127 old <- work $ lines_starting_with '-' 128 new <- work $ lines_starting_with '+' 129 work $ lines_starting_with ' ' -- skipping context 130 return $ hunk (fn2fp $ readFileName x fi) l old new 131 else return $ hunk (fn2fp $ readFileName x fi) l [] [] 132 133 skip_newline :: ParserM m => m Bool 134 skip_newline = do s <- peek_input 135 if B.null s 136 then return False 137 else if BC.head s /= '\n' 138 then return False 139 else alter_input B.tail >> return True 140 141 readTok :: ParserM m => FileNameFormat -> m (Prim C(x y)) 142 readTok x = do 143 work my_lex 144 f <- work my_lex 145 regstr <- work my_lex 146 o <- work my_lex 147 n <- work my_lex 148 return $ FP (readFileName x f) $ TokReplace (BC.unpack (drop_brackets regstr)) 149 (BC.unpack o) (BC.unpack n) 150 where drop_brackets = B.init . B.tail 151 152 153 -- * Binary file modification 154 -- 155 -- | Modify a binary file 156 -- 157 -- > binary FILENAME 158 -- > oldhex 159 -- > *HEXHEXHEX 160 -- > ... 161 -- > newhex 162 -- > *HEXHEXHEX 163 -- > ... 164 readBinary :: ParserM m => FileNameFormat -> m (Prim C(x y)) 165 readBinary x = do 166 work my_lex 167 fi <- work my_lex 168 work my_lex 169 alter_input dropSpace 170 old <- work $ lines_starting_with '*' 171 work my_lex 172 alter_input dropSpace 173 new <- work $ lines_starting_with '*' 174 return $ binary (fn2fp $ readFileName x fi) 175 (fromHex2PS $ B.concat old) 176 (fromHex2PS $ B.concat new) 177 178 readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y)) 179 readAddFile x = do work my_lex 180 f <- work my_lex 181 return $ FP (readFileName x f) AddFile 182 183 readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y)) 184 readRmFile x = do work my_lex 185 f <- work my_lex 186 return $ FP (readFileName x f) RmFile 187 188 readMove :: ParserM m => FileNameFormat -> m (Prim C(x y)) 189 readMove x = do work my_lex 190 d <- work my_lex 191 d' <- work my_lex 192 return $ Move (readFileName x d) (readFileName x d') 193 194 readChangePref :: ParserM m => m (Prim C(x y)) 195 readChangePref 196 = do work my_lex 197 p <- work my_lex 198 f <- work (Just . BC.break ((==)'\n') . B.tail . BC.dropWhile (== ' ')) 199 t <- work (Just . BC.break ((==)'\n') . B.tail) 200 return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t) 201 202 readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y)) 203 readAddDir x = do work my_lex 204 f <- work my_lex 205 return $ DP (readFileName x f) AddDir 206 207 readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y)) 208 readRmDir x = do work my_lex 209 f <- work my_lex 210 return $ DP (readFileName x f) RmDir 211 212 #ifndef GADT_WITNESSES 213 readMerger :: ParserM m => Bool -> m (Patch C(x y)) 214 readMerger b = do work my_lex 215 g <- work my_lex 216 lex_string "(" 217 Just (Sealed p1) <- readPatch' False 218 Just (Sealed p2) <- readPatch' False 219 lex_string ")" 220 let m = merger (BC.unpack g) p1 p2 221 return $ if b then m else invert m 222 #endif 223 224 readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x ))) 225 readNamed want_eof 226 = do mn <- maybe_work readPatchInfo 227 case mn of 228 Nothing -> bug "readNamed 1" 229 Just n -> 230 do d <- read_depends 231 Just p <- readPatch' want_eof 232 return $ (NamedP n d) `mapSeal` p 233 read_depends :: ParserM m => m [PatchInfo] 234 read_depends = do s <- peek_input 235 case my_lex s of 236 Just (xs, _) | BC.unpack xs == "<" -> 237 do work my_lex 238 read_pis 239 _ -> return [] 240 read_pis :: ParserM m => m [PatchInfo] 241 read_pis = do mpi <- maybe_work readPatchInfo 242 case mpi of 243 Just pi -> do pis <- read_pis 244 return (pi:pis) 245 Nothing -> do alter_input (B.tail . BC.dropWhile (/= '>')) 246 return [] 247 248 lines_starting_with :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString) 249 lines_starting_with c thes = 250 Just (lsw [] thes) 251 where lsw acc s | B.null s || BC.head s /= c = (reverse acc, s) 252 lsw acc s = let s' = B.tail s 253 in case breakFirstPS '\n' s' of 254 Just (l, r) -> lsw (l:acc) r 255 Nothing -> (reverse (s':acc), B.empty)