%  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.


\begin{code}
module PatchRead ( readPatch, readPatchLazily, gzReadPatchFileLazily )
             where

import Prelude hiding ( pi )
import Control.Monad ( liftM )

import PatchInfo ( PatchInfo, readPatchInfo )
import FastPackedString ( PackedString, LazyFile(..), gzReadFileLazily )
import FileName ( fn2fp )
import PatchCore ( Patch(..), DirPatchType(..), FilePatchType(..),
                   invert, hunk, binary )
import PatchCommute ( merger )
import PatchReadMonads (Stringalike(..), ParserM, work, maybe_work, alter_input,
                        parse_lazily, parse_strictly,
                        peek_input, lex_char, lex_string, lex_eof, my_lex)
#include "impossible.h"
\end{code}

\begin{code}
readPatch :: Stringalike s => s -> Maybe (Patch, s)
readPatch ps = case parse_strictly (readPatch' False) ps of
                   Just (Just p, ps') -> Just (p, ps')
                   _ -> Nothing

gzReadPatchFileLazily :: FilePath -> IO Patch
gzReadPatchFileLazily fp
 = do lf <- gzReadFileLazily fp
      return $ case lf of
               LazyString s ->           fst $ readPatchLazily' True s
               MMappedPackedString ps -> fst $ readPatchLazily' False ps
               LazyPackedStrings pss ->  fst $ readPatchLazily' True pss

readPatchLazily :: Stringalike s => s -> (Patch, s)
readPatchLazily = readPatchLazily' False

readPatchLazily' :: Stringalike s => Bool -> s -> (Patch, s)
readPatchLazily' want_eof ps = case parse_lazily (readPatch' want_eof) ps of
                               (Just p, ps') -> (p, ps')
                               _ -> impossible

readPatch' :: (Stringalike s, ParserM m, Monad (m s))
           => Bool -> m s (Maybe Patch)
readPatch' want_eof
 = do s <- peek_input
      case liftM (sal_to_string . fst) $ my_lex s of
          Just "{" ->          liftM Just $ readComP want_eof -- }
          Just "(" ->          liftM Just $ readSplit -- )
          Just "hunk" ->       liftM Just $ readHunk
          Just "replace" ->    liftM Just $ readTok
          Just "binary" ->     liftM Just $ readBinary
          Just "addfile" ->    liftM Just $ readAddFile
          Just "adddir" ->     liftM Just $ readAddDir
          Just "rmfile" ->     liftM Just $ readRmFile
          Just "rmdir" ->      liftM Just $ readRmDir
          Just "move" ->       liftM Just $ readMove
          Just "changepref" -> liftM Just $ readChangePref
          Just "merger" ->     liftM Just $ readMerger True
          Just "regrem" ->     liftM Just $ readMerger False
          Just "conflict" ->   liftM Just $ readConflictor
          Just "tcilfnoc" ->   liftM Just $ readInvConflictor
          Just ('[':_) ->      liftM Just $ readNamed want_eof -- ]
          _ -> return Nothing
\end{code}

\begin{code}
readComP :: (Stringalike s, ParserM m, Monad (m s)) => Bool -> m s Patch
readComP want_eof = do work my_lex
                       ps <- read_patches "}" want_eof
                       return $ ComP ps

read_patches :: (Stringalike s, ParserM m, Monad (m s))
             => String -> Bool -> m s [Patch]
read_patches str want_eof
 = do mp <- readPatch' False
      case mp of
          Nothing -> do unit <- lex_string str
                        case unit of
                            () -> if want_eof then do unit' <- lex_eof
                                                      case unit' of
                                                          () -> return []
                                              else return []
          Just p -> do ps <- read_patches str want_eof
                       return (p:ps)
\end{code}

\begin{code}
readSplit :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readSplit = do
  work my_lex
  ps <- read_patches ")" False
  return $ Split ps
\end{code}

\begin{code}
readHunk :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readHunk = do
  work my_lex
  fi <- work my_lex
  l <- work sal_readInt
  alter_input sal_tail -- skipping the newline...
  work $ lines_starting_with ' ' -- skipping context
  old <- work $ lines_starting_with '-'
  new <- work $ lines_starting_with '+'
  work $ lines_starting_with ' ' -- skipping context
  return $ hunk (fn2fp $ sal_to_fn fi) l old new
\end{code}

\begin{code}
readTok :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readTok = do
  work my_lex
  f <- work my_lex
  regstr <- work my_lex
  o <- work my_lex
  n <- work my_lex
  return $ FP (sal_to_fn f) $ TokReplace (drop_brackets $ sal_to_string regstr)
                          (sal_to_string o) (sal_to_string n)
    where drop_brackets = init . tail
\end{code}

\paragraph{Binary file modification}

Modify a binary file
\begin{verbatim}
binary FILENAME
oldhex
*HEXHEXHEX
...
newhex
*HEXHEXHEX
...
\end{verbatim}
\begin{code}
readBinary :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readBinary = do
  work my_lex
  fi <- work my_lex
  work my_lex
  alter_input sal_dropWhite
  old <- work $ lines_starting_with '*'
  work my_lex
  alter_input sal_dropWhite
  new <- work $ lines_starting_with '*'
  return $ binary (fn2fp $ sal_to_fn fi)
                  (sal_to_PS $ sal_fromHex $ sal_concat old)
                  (sal_to_PS $ sal_fromHex $ sal_concat new)
\end{code}

\begin{code}
readAddFile :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readAddFile = do work my_lex
                 f <- work my_lex
                 return $ FP (sal_to_fn f) AddFile
\end{code}

\begin{code}
readRmFile :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readRmFile = do work my_lex
                f <- work my_lex
                return $ FP (sal_to_fn f) RmFile
\end{code}

\begin{code}
readMove :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readMove = do work my_lex
              d <- work my_lex
              d' <- work my_lex
              return $ Move (sal_to_fn d) (sal_to_fn d')
\end{code}

\begin{code}
readChangePref :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readChangePref
 = do work my_lex
      p <- work my_lex
      f <- work (Just . sal_breakOn '\n' . sal_tail . sal_dropWhile (== ' '))
      t <- work (Just . sal_breakOn '\n' . sal_tail)
      alter_input sal_tail
      return $ ChangePref (sal_to_string p) (sal_to_string f) (sal_to_string t)
\end{code}

\begin{code}
readAddDir :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readAddDir = do work my_lex
                f <- work my_lex
                return $ DP (sal_to_fn f) AddDir
\end{code}

\begin{code}
readRmDir :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readRmDir = do work my_lex
               f <- work my_lex
               return $ DP (sal_to_fn f) RmDir
\end{code}

\begin{code}
readMerger :: (Stringalike s, ParserM m, Monad (m s)) => Bool -> m s Patch
readMerger b = do work my_lex
                  g <- work my_lex
                  lex_char '('
                  Just p1 <- readPatch' False
                  Just p2 <- readPatch' False
                  lex_char ')'
                  let m = merger (sal_to_string g) p1 p2
                  return $ if b then m else invert m
\end{code}

\begin{code}
readConflictor :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readConflictor =
    do work my_lex
       b <- read_patches "with" False
       a <- read_patches "done_conflict" False
       return $ Conflictor False a b

readInvConflictor :: (Stringalike s, ParserM m, Monad (m s)) => m s Patch
readInvConflictor =
    do work my_lex
       b <- read_patches "with" False
       a <- read_patches "done_tcilfnoc" False
       return $ Conflictor True a b
\end{code}

\begin{code}
readNamed :: (Stringalike s, ParserM m, Monad (m s)) => Bool -> m s Patch
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 p
read_depends :: (Stringalike s, ParserM m, Monad (m s)) => m s [PatchInfo]
read_depends = do s <- peek_input
                  case my_lex s of
                      Just (xs, _) | sal_to_string xs == "<" ->
                          do work my_lex
                             read_pis
                      _ -> return []
read_pis :: (Stringalike s, ParserM m, Monad (m s)) => m s [PatchInfo]
read_pis = do mpi <- maybe_work readPatchInfo
              case mpi of
                  Just pi -> do pis <- read_pis
                                return (pi:pis)
                  Nothing -> do alter_input (sal_tail . sal_dropWhile (/= '>'))
                                return []
\end{code}

\begin{code}
lines_starting_with :: Stringalike s => Char -> s -> Maybe ([PackedString], s)
lines_starting_with c thes =
    Just (lsw [] thes)
    where lsw acc s | sal_null s || sal_head s /= c = (reverse acc, s)
          lsw acc s = let s' = sal_tail s
                  in case sal_breakFirst '\n' s' of
                     Just (l, r) -> lsw (sal_to_PS l:acc) r
                     Nothing -> (reverse (sal_to_PS s':acc), sal_empty)
\end{code}