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

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

import Darcs.Patch.Bracketed ( Bracketed(..), unBracketedFL )
import Darcs.Patch.Format
    ( FileNameFormat(..)
    , ListFormat(..)
    , PatchListFormat(..)
    )
import Darcs.Util.Parser
    ( Parser
    , checkConsumes
    , choice
    , lexChar
    , lexString
    , lexWord
    , parse
    )
import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, reverseFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )

import Darcs.Util.ByteString ( decodeLocale, dropSpace, unpackPSFromUTF8 )
import Darcs.Util.Path ( AnchoredPath, decodeWhite, floatPath )

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

readPatchPartial :: ReadPatch p => B.ByteString -> Either String (Sealed (p wX), B.ByteString)
readPatchPartial :: forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Either String (Sealed (p wX), ByteString)
readPatchPartial = forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'

readPatch :: ReadPatch p => B.ByteString -> Either String (Sealed (p wX))
readPatch :: forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Either String (Sealed (p wX))
readPatch ByteString
ps =
  case forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch' ByteString
ps of
    Left String
e -> forall a b. a -> Either a b
Left String
e
    Right (Sealed (p wX)
p, ByteString
leftover)
      | ByteString -> Bool
B.null (ByteString -> ByteString
dropSpace ByteString
leftover) -> forall a b. b -> Either a b
Right Sealed (p wX)
p
      | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"leftover:",forall a. Show a => a -> String
show ByteString
leftover]

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

instance (ReadPatch p, PatchListFormat p) => ReadPatch (FL p) where
    readPatch' :: forall wX. Parser (Sealed (FL p wX))
readPatch'
        | ListFormat p
ListFormatV1 <- forall (p :: * -> * -> *). PatchListFormat p => ListFormat p
patchListFormat :: ListFormat p
            = forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall (p :: * -> * -> *) wX wY. BracketedFL p wX wY -> FL p wX wY
unBracketedFL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) wX. ReadPatch p => Parser (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 <- forall (p :: * -> * -> *). PatchListFormat p => ListFormat p
patchListFormat :: ListFormat p
            = forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall (p :: * -> * -> *) wX wY. BracketedFL p wX wY -> FL p wX wY
unBracketedFL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'
        | Bool
otherwise
            = forall wX. Parser (Sealed (FL p wX))
read_patches
     where read_patches :: Parser (Sealed (FL p wX))
           read_patches :: forall wX. Parser (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 <- (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
checkConsumes forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                             case Maybe (Sealed (p wX))
mp of
                               Just (Sealed p wX wX
p) -> do --tracePeek "found one patch"
                                                     Sealed FL p wX wX
ps <- forall wX. Parser (Sealed (FL p wX))
read_patches
                                                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) wY. a wY -> Sealed a
Sealed (p wX wX
pforall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL p wX wX
ps)
                               Maybe (Sealed (p wX))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) wY. a wY -> Sealed a
Sealed 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' :: forall wX. Parser (Sealed (RL p wX))
readPatch' = forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'

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

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

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

-- See also Darcs.Patch.Show.formatFileName.
readFileName :: FileNameFormat -> Parser AnchoredPath
readFileName :: FileNameFormat -> Parser AnchoredPath
readFileName FileNameFormat
fmt = do
  ByteString
raw <- Parser ByteString
lexWord
  case ByteString -> ByteString -> Maybe ByteString
BC.stripPrefix (String -> ByteString
BC.pack String
"./") ByteString
raw of
    Maybe ByteString
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"invalid file path"
    Just ByteString
raw' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FileNameFormat -> ByteString -> AnchoredPath
convert FileNameFormat
fmt ByteString
raw'
  where
    convert :: FileNameFormat -> ByteString -> AnchoredPath
convert FileNameFormat
FileNameFormatV1 =
      String -> AnchoredPath
floatPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
decodeWhite forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
decodeLocale forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpackPSFromUTF8
    convert FileNameFormat
FileNameFormatV2 =
      String -> AnchoredPath
floatPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
decodeWhite forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
decodeLocale
    convert FileNameFormat
FileNameFormatDisplay = forall a. HasCallStack => String -> a
error String
"readFileName called with FileNameFormatDisplay"