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