%  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}
{-# OPTIONS_GHC -cpp -fno-warn-orphans #-}
module Darcs.Patch.Read ( readPrim, readPatch )
             where

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

#include "gadts.h"
import FastPackedString ( PackedString, nilPS, headPS, tailPS, breakFirstPS,
                          nullPS, unpackPS, breakOnPS, dropWhilePS, concatPS,
                          fromHex2PS, readIntPS, dropWhitePS )
import FileName ( FileName, fn2fp, fp2fn, ps2fn, decode_white )
import Darcs.Patch.Core ( Patch(..), Named(..) )
import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..),
                          DirPatchType(..), FilePatchType(..),
                          hunk, binary )
#ifndef GADT_WITNESSES
import Darcs.Patch.Commute ( merger )
import Darcs.Patch.Patchy ( invert )
#endif
import Darcs.Patch.Info ( PatchInfo, readPatchInfo )
import Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input,
                               parse_strictly, peek_input, lex_string, lex_eof, my_lex)
#include "impossible.h"
import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL )
import Darcs.Patch.Ordered ( FL(..) )
import Darcs.Sealed ( Sealed(..), seal, mapSeal )
\end{code}

\begin{code}
readPatch :: ReadPatch p => PackedString -> Maybe (Sealed (p C(x )), PackedString)
readPatch ps = case parse_strictly (readPatch' False) ps of
                   Just (Just p, ps') -> Just (p, ps')
                   _ -> Nothing

instance ReadPatch p => ReadPatch (Named p) where
 readPatch' want_eof
   = do s <- peek_input
        case liftM (unpackPS . fst) $ my_lex s of
          Just ('[':_) ->      liftM Just $ readNamed want_eof -- ]
          _ -> return Nothing

instance ReadPatch Prim where
 readPatch' w = readPrim OldFormat w

readPrim :: ParserM m => FileNameFormat -> Bool -> m (Maybe (Sealed (Prim C(x ))))
readPrim x _
   = do s <- peek_input
        case liftM (unpackPS . fst) $ my_lex s of
          Just "{}" ->         do work my_lex
                                  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 (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}')
        case mps of
          Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps
          Nothing -> do s <- peek_input
                        case liftM (unpackPS . fst) $ my_lex s of
#ifndef GADT_WITNESSES
                          Just "merger" ->     liftM (Just . seal) $ readMerger True
                          Just "regrem" ->     liftM (Just . seal) $ readMerger False
#endif
                          _ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof
\end{code}

\begin{code}
read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x )))
read_patches x str want_eof
 = do mp <- readPrim x 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 $ seal NilFL
                                              else return $ seal NilFL
          Just (Sealed p) -> do Sealed ps <- read_patches x str want_eof
                                return $ seal (p:>:ps)
\end{code}

\begin{code}
readSplit :: ParserM m => FileNameFormat -> m (Sealed (Prim C(x )))
readSplit x = do
  work my_lex
  ps <- read_patches x ")" False
  return $ Split `mapSeal` ps
\end{code}

\begin{code}
readFileName :: FileNameFormat -> PackedString -> FileName
readFileName OldFormat = ps2fn
readFileName NewFormat = fp2fn . decode_white . unpackPS

readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y))
readHunk x = do
  work my_lex
  fi <- work my_lex
  l <- work readIntPS
  have_nl <- skip_newline
  if have_nl
     then do 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 $ readFileName x fi) l old new
     else return $ hunk (fn2fp $ readFileName x fi) l [] []

skip_newline :: ParserM m => m Bool
skip_newline = do s <- peek_input
                  if nullPS s
                    then return False
                    else if headPS s /= '\n'
                         then return False
                         else alter_input tailPS >> return True
\end{code}

\begin{code}
readTok :: ParserM m => FileNameFormat -> m (Prim C(x y))
readTok x = do
  work my_lex
  f <- work my_lex
  regstr <- work my_lex
  o <- work my_lex
  n <- work my_lex
  return $ FP (readFileName x f) $ TokReplace (drop_brackets $ unpackPS regstr)
                          (unpackPS o) (unpackPS 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 :: ParserM m => FileNameFormat -> m (Prim C(x y))
readBinary x = do
  work my_lex
  fi <- work my_lex
  work my_lex
  alter_input dropWhitePS
  old <- work $ lines_starting_with '*'
  work my_lex
  alter_input dropWhitePS
  new <- work $ lines_starting_with '*'
  return $ binary (fn2fp $ readFileName x fi)
                  (fromHex2PS $ concatPS old)
                  (fromHex2PS $ concatPS new)
\end{code}

\begin{code}
readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y))
readAddFile x = do work my_lex
                   f <- work my_lex
                   return $ FP (readFileName x f) AddFile
\end{code}

\begin{code}
readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y))
readRmFile x = do work my_lex
                  f <- work my_lex
                  return $ FP (readFileName x f) RmFile
\end{code}

\begin{code}
readMove :: ParserM m => FileNameFormat -> m (Prim C(x y))
readMove x = do work my_lex
                d <- work my_lex
                d' <- work my_lex
                return $ Move (readFileName x d) (readFileName x d')
\end{code}

\begin{code}
readChangePref :: ParserM m => m (Prim C(x y))
readChangePref
 = do work my_lex
      p <- work my_lex
      f <- work (Just . breakOnPS '\n' . tailPS . dropWhilePS (== ' '))
      t <- work (Just . breakOnPS '\n' . tailPS)
      return $ ChangePref (unpackPS p) (unpackPS f) (unpackPS t)
\end{code}

\begin{code}
readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y))
readAddDir x = do work my_lex
                  f <- work my_lex
                  return $ DP (readFileName x f) AddDir
\end{code}

\begin{code}
readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y))
readRmDir x = do work my_lex
                 f <- work my_lex
                 return $ DP (readFileName x f) RmDir
\end{code}

\begin{code}
#ifndef GADT_WITNESSES
readMerger :: ParserM m => Bool -> m (Patch C(x y))
readMerger b = do work my_lex
                  g <- work my_lex
                  lex_string "("
                  Just (Sealed p1) <- readPatch' False
                  Just (Sealed p2) <- readPatch' False
                  lex_string ")"
                  let m = merger (unpackPS g) p1 p2
                  return $ if b then m else invert m
#endif
\end{code}

\begin{code}
readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x )))
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) `mapSeal` p
read_depends :: ParserM m => m [PatchInfo]
read_depends = do s <- peek_input
                  case my_lex s of
                      Just (xs, _) | unpackPS xs == "<" ->
                          do work my_lex
                             read_pis
                      _ -> return []
read_pis :: ParserM m => m [PatchInfo]
read_pis = do mpi <- maybe_work readPatchInfo
              case mpi of
                  Just pi -> do pis <- read_pis
                                return (pi:pis)
                  Nothing -> do alter_input (tailPS . dropWhilePS (/= '>'))
                                return []
\end{code}

\begin{code}
lines_starting_with :: Char -> PackedString -> Maybe ([PackedString], PackedString)
lines_starting_with c thes =
    Just (lsw [] thes)
    where lsw acc s | nullPS s || headPS s /= c = (reverse acc, s)
          lsw acc s = let s' = tailPS s
                  in case breakFirstPS '\n' s' of
                     Just (l, r) -> lsw (l:acc) r
                     Nothing -> (reverse (s':acc), nilPS)
\end{code}