src/Darcs/Patch/Read.lhs

   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
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp -fno-warn-orphans #-}
  21 {-# LANGUAGE CPP #-}
  22
  23 module Darcs.Patch.Read ( readPrim, readPatch )
  24              where
  25
  26 import Prelude hiding ( pi )
  27 import Control.Monad ( liftM )
  28
  29 #include "gadts.h"
  30
  31 import ByteStringUtils ( breakFirstPS, fromHex2PS, readIntPS, dropSpace )
  32 import qualified Data.ByteString.Char8 as BC (head, unpack, dropWhile, break)
  33 import qualified Data.ByteString       as B  (ByteString, null, init, tail, empty, concat)
  34
  35 import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, ps2fn, decode_white )
  36 import Darcs.Patch.Core ( Patch(..), Named(..) )
  37 import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..),
  38                           DirPatchType(..), FilePatchType(..),
  39                           hunk, binary )
  40 #ifndef GADT_WITNESSES
  41 import Darcs.Patch.Commute ( merger )
  42 import Darcs.Patch.Patchy ( invert )
  43 #endif
  44 import Darcs.Patch.Info ( PatchInfo, readPatchInfo )
  45 import Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input,
  46                                parse_strictly, peek_input, lex_string, lex_eof, my_lex)
  47 #include "impossible.h"
  48 import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL )
  49 import Darcs.Ordered ( FL(..) )
  50 import Darcs.Sealed ( Sealed(..), seal, mapSeal )
  51 \end{code}
  52
  53 \begin{code}
  54 readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString)
  55 readPatch ps = case parse_strictly (readPatch' False) ps of
  56                    Just (Just p, ps') -> Just (p, ps')
  57                    _ -> Nothing
  58
  59 instance ReadPatch p => ReadPatch (Named p) where
  60  readPatch' want_eof
  61    = do s <- peek_input
  62         case liftM (BC.unpack . fst) $ my_lex s of
  63           Just ('[':_) ->      liftM Just $ readNamed want_eof -- ]
  64           _ -> return Nothing
  65
  66 instance ReadPatch Prim where
  67  readPatch' w = readPrim OldFormat w
  68
  69 readPrim :: ParserM m => FileNameFormat -> Bool -> m (Maybe (Sealed (Prim C(x ))))
  70 readPrim x _
  71    = do s <- peek_input
  72         case liftM (BC.unpack . fst) $ my_lex s of
  73           Just "{}" ->         do work my_lex
  74                                   return $ Just $ seal Identity
  75           Just "(" ->          liftM Just $ readSplit x -- )
  76           Just "hunk" ->       liftM (Just . seal) $ readHunk x
  77           Just "replace" ->    liftM (Just . seal) $ readTok x
  78           Just "binary" ->     liftM (Just . seal) $ readBinary x
  79           Just "addfile" ->    liftM (Just . seal) $ readAddFile x
  80           Just "adddir" ->     liftM (Just . seal) $ readAddDir x
  81           Just "rmfile" ->     liftM (Just . seal) $ readRmFile x
  82           Just "rmdir" ->      liftM (Just . seal) $ readRmDir x
  83           Just "move" ->       liftM (Just . seal) $ readMove x
  84           Just "changepref" -> liftM (Just . seal) $ readChangePref
  85           _ -> return Nothing
  86
  87 instance ReadPatch Patch where
  88  readPatch' want_eof
  89    = do mps <- bracketedFL (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}')
  90         case mps of
  91           Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps
  92           Nothing -> do s <- peek_input
  93                         case liftM (BC.unpack . fst) $ my_lex s of
  94 #ifndef GADT_WITNESSES
  95                           Just "merger" ->     liftM (Just . seal) $ readMerger True
  96                           Just "regrem" ->     liftM (Just . seal) $ readMerger False
  97 #endif
  98                           _ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof
  99 \end{code}
 100
 101 \begin{code}
 102 read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x )))
 103 read_patches x str want_eof
 104  = do mp <- readPrim x False
 105       case mp of
 106           Nothing -> do unit <- lex_string str
 107                         case unit of
 108                             () -> if want_eof then do unit' <- lex_eof
 109                                                       case unit' of
 110                                                           () -> return $ seal NilFL
 111                                               else return $ seal NilFL
 112           Just (Sealed p) -> do Sealed ps <- read_patches x str want_eof
 113                                 return $ seal (p:>:ps)
 114 \end{code}
 115
 116 \begin{code}
 117 readSplit :: ParserM m => FileNameFormat -> m (Sealed (Prim C(x )))
 118 readSplit x = do
 119   work my_lex
 120   ps <- read_patches x ")" False
 121   return $ Split `mapSeal` ps
 122 \end{code}
 123
 124 \begin{code}
 125 readFileName :: FileNameFormat -> B.ByteString -> FileName
 126 readFileName OldFormat = ps2fn
 127 readFileName NewFormat = fp2fn . decode_white . BC.unpack
 128
 129 readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y))
 130 readHunk x = do
 131   work my_lex
 132   fi <- work my_lex
 133   l <- work readIntPS
 134   have_nl <- skip_newline
 135   if have_nl
 136      then do work $ lines_starting_with ' ' -- skipping context
 137              old <- work $ lines_starting_with '-'
 138              new <- work $ lines_starting_with '+'
 139              work $ lines_starting_with ' ' -- skipping context
 140              return $ hunk (fn2fp $ readFileName x fi) l old new
 141      else return $ hunk (fn2fp $ readFileName x fi) l [] []
 142
 143 skip_newline :: ParserM m => m Bool
 144 skip_newline = do s <- peek_input
 145                   if B.null s
 146                     then return False
 147                     else if BC.head s /= '\n'
 148                          then return False
 149                          else alter_input B.tail >> return True
 150 \end{code}
 151
 152 \begin{code}
 153 readTok :: ParserM m => FileNameFormat -> m (Prim C(x y))
 154 readTok x = do
 155   work my_lex
 156   f <- work my_lex
 157   regstr <- work my_lex
 158   o <- work my_lex
 159   n <- work my_lex
 160   return $ FP (readFileName x f) $ TokReplace (BC.unpack (drop_brackets regstr))
 161                           (BC.unpack o) (BC.unpack n)
 162     where drop_brackets = B.init . B.tail
 163 \end{code}
 164
 165 \paragraph{Binary file modification}
 166
 167 Modify a binary file
 168 \begin{verbatim}
 169 binary FILENAME
 170 oldhex
 171 *HEXHEXHEX
 172 ...
 173 newhex
 174 *HEXHEXHEX
 175 ...
 176 \end{verbatim}
 177 \begin{code}
 178 readBinary :: ParserM m => FileNameFormat -> m (Prim C(x y))
 179 readBinary x = do
 180   work my_lex
 181   fi <- work my_lex
 182   work my_lex
 183   alter_input dropSpace
 184   old <- work $ lines_starting_with '*'
 185   work my_lex
 186   alter_input dropSpace
 187   new <- work $ lines_starting_with '*'
 188   return $ binary (fn2fp $ readFileName x fi)
 189                   (fromHex2PS $ B.concat old)
 190                   (fromHex2PS $ B.concat new)
 191 \end{code}
 192
 193 \begin{code}
 194 readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y))
 195 readAddFile x = do work my_lex
 196                    f <- work my_lex
 197                    return $ FP (readFileName x f) AddFile
 198 \end{code}
 199
 200 \begin{code}
 201 readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y))
 202 readRmFile x = do work my_lex
 203                   f <- work my_lex
 204                   return $ FP (readFileName x f) RmFile
 205 \end{code}
 206
 207 \begin{code}
 208 readMove :: ParserM m => FileNameFormat -> m (Prim C(x y))
 209 readMove x = do work my_lex
 210                 d <- work my_lex
 211                 d' <- work my_lex
 212                 return $ Move (readFileName x d) (readFileName x d')
 213 \end{code}
 214
 215 \begin{code}
 216 readChangePref :: ParserM m => m (Prim C(x y))
 217 readChangePref
 218  = do work my_lex
 219       p <- work my_lex
 220       f <- work (Just . BC.break ((==)'\n') . B.tail . BC.dropWhile (== ' '))
 221       t <- work (Just . BC.break ((==)'\n') . B.tail)
 222       return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t)
 223 \end{code}
 224
 225 \begin{code}
 226 readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y))
 227 readAddDir x = do work my_lex
 228                   f <- work my_lex
 229                   return $ DP (readFileName x f) AddDir
 230 \end{code}
 231
 232 \begin{code}
 233 readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y))
 234 readRmDir x = do work my_lex
 235                  f <- work my_lex
 236                  return $ DP (readFileName x f) RmDir
 237 \end{code}
 238
 239 \begin{code}
 240 #ifndef GADT_WITNESSES
 241 readMerger :: ParserM m => Bool -> m (Patch C(x y))
 242 readMerger b = do work my_lex
 243                   g <- work my_lex
 244                   lex_string "("
 245                   Just (Sealed p1) <- readPatch' False
 246                   Just (Sealed p2) <- readPatch' False
 247                   lex_string ")"
 248                   let m = merger (BC.unpack g) p1 p2
 249                   return $ if b then m else invert m
 250 #endif
 251 \end{code}
 252
 253 \begin{code}
 254 readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x )))
 255 readNamed want_eof
 256           = do mn <- maybe_work readPatchInfo
 257                case mn of
 258                    Nothing -> bug "readNamed 1"
 259                    Just n ->
 260                        do d <- read_depends
 261                           Just p <- readPatch' want_eof
 262                           return $ (NamedP n d) `mapSeal` p
 263 read_depends :: ParserM m => m [PatchInfo]
 264 read_depends = do s <- peek_input
 265                   case my_lex s of
 266                       Just (xs, _) | BC.unpack xs == "<" ->
 267                           do work my_lex
 268                              read_pis
 269                       _ -> return []
 270 read_pis :: ParserM m => m [PatchInfo]
 271 read_pis = do mpi <- maybe_work readPatchInfo
 272               case mpi of
 273                   Just pi -> do pis <- read_pis
 274                                 return (pi:pis)
 275                   Nothing -> do alter_input (B.tail . BC.dropWhile (/= '>'))
 276                                 return []
 277 \end{code}
 278
 279 \begin{code}
 280 lines_starting_with :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString)
 281 lines_starting_with c thes =
 282     Just (lsw [] thes)
 283     where lsw acc s | B.null s || BC.head s /= c = (reverse acc, s)
 284           lsw acc s = let s' = B.tail s
 285                   in case breakFirstPS '\n' s' of
 286                      Just (l, r) -> lsw (l:acc) r
 287                      Nothing -> (reverse (s':acc), B.empty)
 288 \end{code}