-- 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, decodeWhite )
import Darcs.Patch.Core ( Patch(..), Named(..) )
import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..),
                          DirPatchType(..), FilePatchType(..),
                          hunk, binary )
import Darcs.Patch.Commute ( merger )
import Darcs.Patch.Patchy ( invert )
import Darcs.Patch.Info ( PatchInfo, readPatchInfo )
import Darcs.Patch.ReadMonads (ParserM, work, maybeWork, alterInput,
                               parseStrictly, peekInput, lexString, lexEof, myLex)
#include "impossible.h"
import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL )
import Darcs.Witnesses.Ordered ( FL(..), unsafeCoerceP )
import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal )

readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString)
readPatch ps = case parseStrictly (readPatch' False) ps of
                   Just (Just p, ps') -> Just (p, ps')
                   _ -> Nothing

instance ReadPatch p => ReadPatch (Named p) where
 readPatch' want_eof
   = do s <- peekInput
        case liftM (BC.unpack . fst) $ myLex 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 <- peekInput
        case liftM (BC.unpack . fst) $ myLex s of
          Just "{}" ->         do work myLex
                                  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 (readPatch' False) (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}')
        case mps of
          Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps
          Nothing -> do s <- peekInput
                        case liftM (BC.unpack . fst) $ myLex s of
                          Just "merger" ->     liftM (Just . seal) $ readMerger True
                          Just "regrem" ->     liftM (Just . seal) $ readMerger False
                          _ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof

readPatches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x )))
readPatches x str want_eof
 = do mp <- readPrim x
      case mp of
          Nothing -> do unit <- lexString str
                        case unit of
                            () -> if want_eof then do unit' <- lexEof
                                                      case unit' of
                                                          () -> return $ seal NilFL
                                              else return $ seal NilFL
          Just (Sealed p) -> do Sealed ps <- readPatches x str want_eof
                                return $ seal (p:>:ps)

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

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

readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y))
readHunk x = do
  work myLex
  fi <- work myLex
  l <- work readIntPS
  have_nl <- skipNewline
  if have_nl
     then do work $ linesStartingWith ' ' -- skipping context
             old <- work $ linesStartingWith '-'
             new <- work $ linesStartingWith '+'
             work $ linesStartingWith ' ' -- skipping context
             return $ hunk (fn2fp $ readFileName x fi) l old new
     else return $ hunk (fn2fp $ readFileName x fi) l [] []

skipNewline :: ParserM m => m Bool
skipNewline =  do s <- peekInput
                  if B.null s
                    then return False
                    else if BC.head s /= '\n'
                         then return False
                         else alterInput B.tail >> return True

readTok :: ParserM m => FileNameFormat -> m (Prim C(x y))
readTok x = do
  work myLex
  f <- work myLex
  regstr <- work myLex
  o <- work myLex
  n <- work myLex
  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 myLex
  fi <- work myLex
  work myLex
  alterInput dropSpace
  old <- work $ linesStartingWith '*'
  work myLex
  alterInput dropSpace
  new <- work $ linesStartingWith '*'
  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 myLex
                   f <- work myLex
                   return $ FP (readFileName x f) AddFile

readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y))
readRmFile x = do work myLex
                  f <- work myLex
                  return $ FP (readFileName x f) RmFile

readMove :: ParserM m => FileNameFormat -> m (Prim C(x y))
readMove x = do work myLex
                d <- work myLex
                d' <- work myLex
                return $ Move (readFileName x d) (readFileName x d')

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

readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y))
readRmDir x = do work myLex
                 f <- work myLex
                 return $ DP (readFileName x f) RmDir

readMerger :: ParserM m => Bool -> m (Patch C(x y))
readMerger b = do work myLex
                  g <- work myLex
                  lexString "("
                  Just (Sealed p1) <- readPatch' False
                  Just (Sealed p2) <- readPatch' False
                  lexString ")"
                  Sealed m <- return $ merger (BC.unpack g) p1 p2
                  return $ if b then unsafeCoerceP m else unsafeCoerceP (invert m)

readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x )))
readNamed want_eof
          = do mn <- maybeWork readPatchInfo
               case mn of
                   Nothing -> bug "readNamed 1"
                   Just n ->
                       do d <- readDepends
                          Just p <- readPatch' want_eof
                          return $ (NamedP n d) `mapSeal` p
readDepends :: ParserM m => m [PatchInfo]
readDepends =  do s <- peekInput
                  case myLex s of
                      Just (xs, _) | BC.unpack xs == "<" ->
                          do work myLex
                             readPis
                      _ -> return []
readPis :: ParserM m => m [PatchInfo]
readPis =  do mpi <- maybeWork readPatchInfo
              case mpi of
                  Just pi -> do pis <- readPis
                                return (pi:pis)
                  Nothing -> do alterInput (B.tail . BC.dropWhile (/= '>'))
                                return []

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