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

module Darcs.Patch.Read ( ReadPatch(..),
                          readPatch, readPatchPartial,
                          bracketedFL, peekfor,
                          readFileName )
             where

import Prelude ()
import Darcs.Prelude

import Darcs.Util.ByteString ( dropSpace, unpackPSFromUTF8, decodeLocale )
import qualified Data.ByteString       as B  (ByteString, null)

import Darcs.Patch.Bracketed ( Bracketed(..), unBracketedFL )
import Darcs.Util.Path ( FileName, fp2fn, decodeWhite )
import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) )
import Darcs.Patch.ReadMonads (ParserM,
                               parseStrictly,
                               choice, lexChar, lexString,
                               checkConsumes )

import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, reverseFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )

import Control.Applicative ( (<|>) )
import Control.Monad ( mzero )
import qualified Data.ByteString.Char8 as BC ( ByteString, pack )

-- | This class is used to decode patches from their binary representation.
class ReadPatch p where
    readPatch'
        :: ParserM m => m (Sealed (p wX))

readPatchPartial :: ReadPatch p => B.ByteString -> Maybe (Sealed (p wX), B.ByteString)
readPatchPartial :: ByteString -> Maybe (Sealed (p wX), ByteString)
readPatchPartial ps :: ByteString
ps
    = case SM (Sealed (p wX))
-> ByteString -> Maybe (Sealed (p wX), ByteString)
forall a. SM a -> ByteString -> Maybe (a, ByteString)
parseStrictly SM (Sealed (p wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch' ByteString
ps of
         Just (p :: Sealed (p wX)
p, ps' :: ByteString
ps') -> (Sealed (p wX), ByteString) -> Maybe (Sealed (p wX), ByteString)
forall a. a -> Maybe a
Just (Sealed (p wX)
p, ByteString
ps')
         _ -> Maybe (Sealed (p wX), ByteString)
forall a. Maybe a
Nothing

readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p wX))
readPatch :: ByteString -> Maybe (Sealed (p wX))
readPatch ps :: ByteString
ps
    = case ByteString -> Maybe (Sealed (p wX), ByteString)
forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Maybe (Sealed (p wX), ByteString)
readPatchPartial ByteString
ps of
         Just (p :: Sealed (p wX)
p, ps' :: ByteString
ps') | ByteString -> Bool
B.null (ByteString -> ByteString
dropSpace ByteString
ps') -> Sealed (p wX) -> Maybe (Sealed (p wX))
forall a. a -> Maybe a
Just Sealed (p wX)
p
         _ -> Maybe (Sealed (p wX))
forall a. Maybe a
Nothing

instance ReadPatch p => ReadPatch (Bracketed p) where
    readPatch' :: m (Sealed (Bracketed p wX))
readPatch' = (forall wX. FL (Bracketed p) wX wX -> Bracketed p wX wX)
-> Sealed (FL (Bracketed p) wX) -> Sealed (Bracketed p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. FL (Bracketed p) wX wX -> Bracketed p wX wX
forall (p :: * -> * -> *) wX wY.
BracketedFL p wX wY -> Bracketed p wX wY
Braced (Sealed (FL (Bracketed p) wX) -> Sealed (Bracketed p wX))
-> m (Sealed (FL (Bracketed p) wX)) -> m (Sealed (Bracketed p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wY. m (Sealed (Bracketed p wY)))
-> Char -> Char -> m (Sealed (FL (Bracketed p) wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
ParserM m =>
(forall wY. m (Sealed (p wY)))
-> Char -> Char -> m (Sealed (FL p wX))
bracketedFL forall wY. m (Sealed (Bracketed p wY))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch' '{' '}'
                   m (Sealed (Bracketed p wX))
-> m (Sealed (Bracketed p wX)) -> m (Sealed (Bracketed p wX))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                 (forall wX. FL (Bracketed p) wX wX -> Bracketed p wX wX)
-> Sealed (FL (Bracketed p) wX) -> Sealed (Bracketed p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. FL (Bracketed p) wX wX -> Bracketed p wX wX
forall (p :: * -> * -> *) wX wY.
BracketedFL p wX wY -> Bracketed p wX wY
Parens (Sealed (FL (Bracketed p) wX) -> Sealed (Bracketed p wX))
-> m (Sealed (FL (Bracketed p) wX)) -> m (Sealed (Bracketed p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wY. m (Sealed (Bracketed p wY)))
-> Char -> Char -> m (Sealed (FL (Bracketed p) wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
ParserM m =>
(forall wY. m (Sealed (p wY)))
-> Char -> Char -> m (Sealed (FL p wX))
bracketedFL forall wY. m (Sealed (Bracketed p wY))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch' '(' ')'
                   m (Sealed (Bracketed p wX))
-> m (Sealed (Bracketed p wX)) -> m (Sealed (Bracketed p wX))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                 (forall wX. p wX wX -> Bracketed p wX wX)
-> Sealed (p wX) -> Sealed (Bracketed p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. p wX wX -> Bracketed p wX wX
forall (p :: * -> * -> *) wX wY. p wX wY -> Bracketed p wX wY
Singleton (Sealed (p wX) -> Sealed (Bracketed p wX))
-> m (Sealed (p wX)) -> m (Sealed (Bracketed p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Sealed (p wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch'

instance (ReadPatch p, PatchListFormat p) => ReadPatch (FL p) where
    readPatch' :: m (Sealed (FL p wX))
readPatch'
        | ListFormat p
ListFormatV1 <- ListFormat p
forall (p :: * -> * -> *). PatchListFormat p => ListFormat p
patchListFormat :: ListFormat p
            = (forall wX. FL (Bracketed p) wX wX -> FL p wX wX)
-> Sealed (FL (Bracketed p) wX) -> Sealed (FL p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. FL (Bracketed p) wX wX -> FL p wX wX
forall (p :: * -> * -> *) wX wY. BracketedFL p wX wY -> FL p wX wY
unBracketedFL (Sealed (FL (Bracketed p) wX) -> Sealed (FL p wX))
-> m (Sealed (FL (Bracketed p) wX)) -> m (Sealed (FL p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Sealed (FL (Bracketed p) wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch'
        -- in the V2 format case, we only need to support () on reading, not {}
        -- for simplicity we just go through the same code path.
        | ListFormat p
ListFormatV2 <- ListFormat p
forall (p :: * -> * -> *). PatchListFormat p => ListFormat p
patchListFormat :: ListFormat p
            = (forall wX. FL (Bracketed p) wX wX -> FL p wX wX)
-> Sealed (FL (Bracketed p) wX) -> Sealed (FL p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. FL (Bracketed p) wX wX -> FL p wX wX
forall (p :: * -> * -> *) wX wY. BracketedFL p wX wY -> FL p wX wY
unBracketedFL (Sealed (FL (Bracketed p) wX) -> Sealed (FL p wX))
-> m (Sealed (FL (Bracketed p) wX)) -> m (Sealed (FL p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Sealed (FL (Bracketed p) wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch'
        | Bool
otherwise
            = m (Sealed (FL p wX))
forall (m :: * -> *) wX. ParserM m => m (Sealed (FL p wX))
read_patches
     where read_patches :: ParserM m => m (Sealed (FL p wX))
           read_patches :: m (Sealed (FL p wX))
read_patches = do --tracePeek "starting FL read"
                             -- checkConsumes is needed to make sure that something is read,
                             -- to avoid stack overflow when parsing FL (FL p)
                             Maybe (Sealed (p wX))
mp <- (Sealed (p wX) -> Maybe (Sealed (p wX))
forall a. a -> Maybe a
Just (Sealed (p wX) -> Maybe (Sealed (p wX)))
-> m (Sealed (p wX)) -> m (Maybe (Sealed (p wX)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Sealed (p wX)) -> m (Sealed (p wX))
forall (m :: * -> *) a. ParserM m => m a -> m a
checkConsumes m (Sealed (p wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch') m (Maybe (Sealed (p wX)))
-> m (Maybe (Sealed (p wX))) -> m (Maybe (Sealed (p wX)))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Sealed (p wX)) -> m (Maybe (Sealed (p wX)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Sealed (p wX))
forall a. Maybe a
Nothing
                             case Maybe (Sealed (p wX))
mp of
                               Just (Sealed p :: p wX wX
p) -> do --tracePeek "found one patch"
                                                     Sealed ps :: FL p wX wX
ps <- m (Sealed (FL p wX))
forall (m :: * -> *) wX. ParserM m => m (Sealed (FL p wX))
read_patches
                                                     Sealed (FL p wX) -> m (Sealed (FL p wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL p wX) -> m (Sealed (FL p wX)))
-> Sealed (FL p wX) -> m (Sealed (FL p wX))
forall a b. (a -> b) -> a -> b
$ FL p wX wX -> Sealed (FL p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (p wX wX
pp wX wX -> FL p wX wX -> FL p wX wX
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL p wX wX
ps)
                               Nothing -> Sealed (FL p wX) -> m (Sealed (FL p wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL p wX) -> m (Sealed (FL p wX)))
-> Sealed (FL p wX) -> m (Sealed (FL p wX))
forall a b. (a -> b) -> a -> b
$ FL p wX wX -> Sealed (FL p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL p wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
--           tracePeek x = do y <- peekInput
--                            traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return ()

instance (ReadPatch p, PatchListFormat p) => ReadPatch (RL p) where
    readPatch' :: m (Sealed (RL p wX))
readPatch' = (forall wX. FL p wX wX -> RL p wX wX)
-> Sealed (FL p wX) -> Sealed (RL p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. FL p wX wX -> RL p wX wX
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL (Sealed (FL p wX) -> Sealed (RL p wX))
-> m (Sealed (FL p wX)) -> m (Sealed (RL p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Sealed (FL p wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch'

{-# INLINE bracketedFL #-}
bracketedFL :: forall p m wX . (ParserM m) =>
               (forall wY . m (Sealed (p wY))) -> Char -> Char -> m (Sealed (FL p wX))
bracketedFL :: (forall wY. m (Sealed (p wY)))
-> Char -> Char -> m (Sealed (FL p wX))
bracketedFL parser :: forall wY. m (Sealed (p wY))
parser pre :: Char
pre post :: Char
post =
    Char
-> m (Sealed (FL p wX))
-> m (Sealed (FL p wX))
-> m (Sealed (FL p wX))
forall (m :: * -> *) a. ParserM m => Char -> m a -> m a -> m a
peekforc Char
pre m (Sealed (FL p wX))
forall wZ. m (Sealed (FL p wZ))
bfl m (Sealed (FL p wX))
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        where bfl :: forall wZ . m (Sealed (FL p wZ))
              bfl :: m (Sealed (FL p wZ))
bfl = Char
-> m (Sealed (FL p wZ))
-> m (Sealed (FL p wZ))
-> m (Sealed (FL p wZ))
forall (m :: * -> *) a. ParserM m => Char -> m a -> m a -> m a
peekforc Char
post (Sealed (FL p wZ) -> m (Sealed (FL p wZ))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL p wZ) -> m (Sealed (FL p wZ)))
-> Sealed (FL p wZ) -> m (Sealed (FL p wZ))
forall a b. (a -> b) -> a -> b
$ FL p wZ wZ -> Sealed (FL p wZ)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL p wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
                                  (do Sealed p :: p wZ wX
p <- m (Sealed (p wZ))
forall wY. m (Sealed (p wY))
parser
                                      Sealed ps :: FL p wX wX
ps <- m (Sealed (FL p wX))
forall wZ. m (Sealed (FL p wZ))
bfl
                                      Sealed (FL p wZ) -> m (Sealed (FL p wZ))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL p wZ) -> m (Sealed (FL p wZ)))
-> Sealed (FL p wZ) -> m (Sealed (FL p wZ))
forall a b. (a -> b) -> a -> b
$ FL p wZ wX -> Sealed (FL p wZ)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (p wZ wX
pp wZ wX -> FL p wX wX -> FL p wZ wX
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL p wX wX
ps))

{-# INLINE peekforc #-}
peekforc :: ParserM m => Char -> m a -> m a -> m a
peekforc :: Char -> m a -> m a -> m a
peekforc c :: Char
c ifstr :: m a
ifstr ifnot :: m a
ifnot = [m a] -> m a
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [ Char -> m ()
forall (m :: * -> *). ParserM m => Char -> m ()
lexChar Char
c m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
ifstr
                                , m a
ifnot ]

peekfor :: ParserM m => BC.ByteString -> m a -> m a -> m a
peekfor :: ByteString -> m a -> m a -> m a
peekfor ps :: ByteString
ps ifstr :: m a
ifstr ifnot :: m a
ifnot = [m a] -> m a
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [ do ByteString -> m ()
forall (m :: * -> *). ParserM m => ByteString -> m ()
lexString ByteString
ps
                                     m a
ifstr
                                , m a
ifnot ]
{-# INLINE peekfor #-}

-- See also Darcs.Patch.Show.formatFileName.
readFileName :: FileNameFormat -> B.ByteString -> FileName
readFileName :: FileNameFormat -> ByteString -> FileName
readFileName OldFormat = FilePath -> FileName
fp2fn (FilePath -> FileName)
-> (ByteString -> FilePath) -> ByteString -> FileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
decodeWhite (FilePath -> FilePath)
-> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
decodeLocale (ByteString -> FilePath)
-> (ByteString -> ByteString) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
BC.pack (FilePath -> ByteString)
-> (ByteString -> FilePath) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
unpackPSFromUTF8
readFileName NewFormat = FilePath -> FileName
fp2fn (FilePath -> FileName)
-> (ByteString -> FilePath) -> ByteString -> FileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
decodeWhite (FilePath -> FilePath)
-> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
decodeLocale
readFileName UserFormat = FilePath -> ByteString -> FileName
forall a. HasCallStack => FilePath -> a
error "readFileName called with UserFormat"