-- 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, 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.Witnesses.Ordered ( FL(..) )
import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal )

readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString)
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 (BC.unpack . fst) $ my_lex 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 <- peek_input
        case liftM (BC.unpack . 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 (BC.unpack . 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

read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x )))
read_patches x str want_eof
 = do mp <- readPrim x
      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)

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

readFileName :: FileNameFormat -> B.ByteString -> FileName
readFileName OldFormat = ps2fn
readFileName NewFormat = fp2fn . decode_white . BC.unpack

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 B.null s
                    then return False
                    else if BC.head s /= '\n'
                         then return False
                         else alter_input B.tail >> return True

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 (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 my_lex
  fi <- work my_lex
  work my_lex
  alter_input dropSpace
  old <- work $ lines_starting_with '*'
  work my_lex
  alter_input dropSpace
  new <- work $ lines_starting_with '*'
  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 my_lex
                   f <- work my_lex
                   return $ FP (readFileName x f) AddFile

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

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')

readChangePref :: ParserM m => m (Prim C(x y))
readChangePref
 = do work my_lex
      p <- work my_lex
      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 my_lex
                  f <- work my_lex
                  return $ DP (readFileName x f) AddDir

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

#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 (BC.unpack g) p1 p2
                  return $ if b then m else invert m
#endif

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, _) | BC.unpack 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 (B.tail . BC.dropWhile (/= '>'))
                                return []

lines_starting_with :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString)
lines_starting_with 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)