-- 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 )
import qualified Data.ByteString.Char8 as BC ( ByteString, pack, stripPrefix )
import GHC.Stack ( HasCallStack )

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

import Darcs.Util.ByteString ( decodeLocale, 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 = Parser (Sealed (p wX))
-> ByteString -> Either String (Sealed (p wX), ByteString)
forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser (Sealed (p wX))
forall wX. Parser (Sealed (p wX))
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 = Parser (Sealed (p wX))
-> ByteString -> Either String (Sealed (p wX))
forall a. Parser a -> ByteString -> Either String a
parseAll Parser (Sealed (p wX))
forall wX. Parser (Sealed (p wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'

instance ReadPatch p => ReadPatch (Bracketed p) where
    readPatch' :: forall wX. Parser (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 BracketedFL p wX wX -> Bracketed p wX wX
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))
-> Parser ByteString (Sealed (FL (Bracketed p) wX))
-> Parser ByteString (Sealed (Bracketed p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wX. Parser (Sealed (Bracketed p wX)))
-> Char -> Char -> Parser ByteString (Sealed (FL (Bracketed p) wX))
forall (p :: * -> * -> *) wX.
(forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser (Sealed (FL p wX))
bracketedFL Parser (Sealed (Bracketed p wY))
forall wX. Parser (Sealed (Bracketed p wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch' Char
'{' Char
'}'
                   Parser ByteString (Sealed (Bracketed p wX))
-> Parser ByteString (Sealed (Bracketed p wX))
-> Parser ByteString (Sealed (Bracketed p wX))
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
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 FL (Bracketed p) wX wX -> Bracketed p wX wX
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))
-> Parser ByteString (Sealed (FL (Bracketed p) wX))
-> Parser ByteString (Sealed (Bracketed p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wX. Parser (Sealed (Bracketed p wX)))
-> Char -> Char -> Parser ByteString (Sealed (FL (Bracketed p) wX))
forall (p :: * -> * -> *) wX.
(forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser (Sealed (FL p wX))
bracketedFL Parser (Sealed (Bracketed p wY))
forall wX. Parser (Sealed (Bracketed p wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch' Char
'(' Char
')'
                   Parser ByteString (Sealed (Bracketed p wX))
-> Parser ByteString (Sealed (Bracketed p wX))
-> Parser ByteString (Sealed (Bracketed p wX))
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
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 p wX wX -> Bracketed p wX wX
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))
-> Parser ByteString (Sealed (p wX))
-> Parser ByteString (Sealed (Bracketed p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Sealed (p wX))
forall wX. Parser (Sealed (p wX))
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 <- 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 BracketedFL p wX wX -> FL p wX wX
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))
-> Parser ByteString (Sealed (FL (Bracketed p) wX))
-> Parser ByteString (Sealed (FL p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Sealed (FL (Bracketed p) wX))
forall wX. Parser (Sealed (FL (Bracketed p) wX))
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 <- 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 BracketedFL p wX wX -> FL p wX wX
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))
-> Parser ByteString (Sealed (FL (Bracketed p) wX))
-> Parser ByteString (Sealed (FL p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Sealed (FL (Bracketed p) wX))
forall wX. Parser (Sealed (FL (Bracketed p) wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'
        | Bool
otherwise
            = Parser ByteString (Sealed (FL p wX))
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 <- (Sealed (p wX) -> Maybe (Sealed (p wX))
forall a. a -> Maybe a
Just (Sealed (p wX) -> Maybe (Sealed (p wX)))
-> Parser ByteString (Sealed (p wX))
-> Parser ByteString (Maybe (Sealed (p wX)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Sealed (p wX))
-> Parser ByteString (Sealed (p wX))
forall a. Parser a -> Parser a
checkConsumes Parser ByteString (Sealed (p wX))
forall wX. Parser (Sealed (p wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch') Parser ByteString (Maybe (Sealed (p wX)))
-> Parser ByteString (Maybe (Sealed (p wX)))
-> Parser ByteString (Maybe (Sealed (p wX)))
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Sealed (p wX)) -> Parser ByteString (Maybe (Sealed (p wX)))
forall a. a -> Parser ByteString a
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 wX wX
p) -> do --tracePeek "found one patch"
                                                     Sealed FL p wX wX
ps <- Parser (Sealed (FL p wX))
forall wX. Parser (Sealed (FL p wX))
read_patches
                                                     Sealed (FL p wX) -> Parser (Sealed (FL p wX))
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL p wX) -> Parser (Sealed (FL p wX)))
-> Sealed (FL p wX) -> Parser (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)
                               Maybe (Sealed (p wX))
Nothing -> Sealed (FL p wX) -> Parser (Sealed (FL p wX))
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL p wX) -> Parser (Sealed (FL p wX)))
-> Sealed (FL p wX) -> Parser (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' :: forall wX. Parser (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 FL p wX wX -> RL p wX wX
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))
-> Parser ByteString (Sealed (FL p wX))
-> Parser ByteString (Sealed (RL p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Sealed (FL p wX))
forall wX. Parser (Sealed (FL p wX))
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 =
    Char
-> Parser (Sealed (FL p wX))
-> Parser (Sealed (FL p wX))
-> Parser (Sealed (FL p wX))
forall a. Char -> Parser a -> Parser a -> Parser a
peekforc Char
pre Parser (Sealed (FL p wX))
forall wZ. Parser (Sealed (FL p wZ))
bfl Parser (Sealed (FL p wX))
forall a. Parser ByteString a
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 = Char
-> Parser (Sealed (FL p wZ))
-> Parser (Sealed (FL p wZ))
-> Parser (Sealed (FL p wZ))
forall a. Char -> Parser a -> Parser a -> Parser a
peekforc Char
post (Sealed (FL p wZ) -> Parser (Sealed (FL p wZ))
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL p wZ) -> Parser (Sealed (FL p wZ)))
-> Sealed (FL p wZ) -> Parser (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 wZ wX
p <- Parser (Sealed (p wZ))
forall wY. Parser (Sealed (p wY))
parser
                                      Sealed FL p wX wX
ps <- Parser (Sealed (FL p wX))
forall wZ. Parser (Sealed (FL p wZ))
bfl
                                      Sealed (FL p wZ) -> Parser (Sealed (FL p wZ))
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL p wZ) -> Parser (Sealed (FL p wZ)))
-> Sealed (FL p wZ) -> Parser (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 :: 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 = [Parser a] -> Parser a
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [ Char -> Parser ()
lexChar Char
c Parser () -> Parser a -> Parser a
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
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 = [Parser a] -> Parser a
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 :: HasCallStack => FileNameFormat -> Parser AnchoredPath
readFileName :: HasCallStack => 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 -> String -> Parser AnchoredPath
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser AnchoredPath) -> String -> Parser AnchoredPath
forall a b. (a -> b) -> a -> b
$ String
"invalid file path"
    Just ByteString
raw' ->
      case FileNameFormat -> ByteString -> Either String AnchoredPath
convert FileNameFormat
fmt ByteString
raw' of
        Left String
e -> String -> Parser AnchoredPath
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
        Right AnchoredPath
r -> AnchoredPath -> Parser AnchoredPath
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return AnchoredPath
r
  where
    convert :: FileNameFormat -> ByteString -> Either String AnchoredPath
convert FileNameFormat
FileNameFormatV1 =
      String -> Either String AnchoredPath
floatPath (String -> Either String AnchoredPath)
-> (ByteString -> Either String String)
-> ByteString
-> Either String AnchoredPath
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Either String String
decodeWhite (String -> Either String String)
-> (ByteString -> String) -> ByteString -> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
decodeLocale (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BC.pack (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpackPSFromUTF8
    convert FileNameFormat
FileNameFormatV2 =
      String -> Either String AnchoredPath
floatPath (String -> Either String AnchoredPath)
-> (ByteString -> Either String String)
-> ByteString
-> Either String AnchoredPath
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Either String String
decodeWhite (String -> Either String String)
-> (ByteString -> String) -> ByteString -> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
decodeLocale
    convert FileNameFormat
FileNameFormatDisplay = String -> ByteString -> Either String AnchoredPath
forall a. HasCallStack => String -> a
error String
"readFileName called with FileNameFormatDisplay"