-- 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 :: 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 (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX)) readPatch' readPatch :: ReadPatch p => B.ByteString -> Either String (Sealed (p wX)) readPatch :: ByteString -> Either String (Sealed (p wX)) readPatch ByteString ps = case 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 (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX)) readPatch' ByteString ps of Left String e -> String -> Either String (Sealed (p wX)) 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) -> Sealed (p wX) -> Either String (Sealed (p wX)) forall a b. b -> Either a b Right Sealed (p wX) p | Bool otherwise -> String -> Either String (Sealed (p wX)) forall a b. a -> Either a b Left (String -> Either String (Sealed (p wX))) -> String -> Either String (Sealed (p wX)) forall a b. (a -> b) -> a -> b $ [String] -> String unlines [String "leftover:",ByteString -> String forall a. Show a => a -> String show ByteString leftover] instance ReadPatch p => ReadPatch (Bracketed p) where readPatch' :: 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 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 (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 forall wX. Parser (Sealed (Bracketed p wX)) forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX)) readPatch' Char '{' Char '}' Parser (Sealed (Bracketed p wX)) -> Parser (Sealed (Bracketed p wX)) -> Parser (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)) -> Parser ByteString (Sealed (FL (Bracketed p) wX)) -> Parser (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 forall wX. Parser (Sealed (Bracketed p wX)) forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX)) readPatch' Char '(' Char ')' Parser (Sealed (Bracketed p wX)) -> Parser (Sealed (Bracketed p wX)) -> Parser (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)) -> Parser ByteString (Sealed (p wX)) -> Parser (Sealed (Bracketed p wX)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser ByteString (Sealed (p wX)) forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX)) readPatch' instance (ReadPatch p, PatchListFormat p) => ReadPatch (FL p) where readPatch' :: 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 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 (Sealed (FL p wX)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser ByteString (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 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 (Sealed (FL p wX)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser ByteString (Sealed (FL (Bracketed p) wX)) forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX)) readPatch' | Bool otherwise = Parser (Sealed (FL p wX)) forall wX. Parser (Sealed (FL p wX)) read_patches where read_patches :: Parser (Sealed (FL p wX)) read_patches :: 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 (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 (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Maybe (Sealed (p wX)) -> Parser ByteString (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 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 (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 (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' :: 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 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 (Sealed (RL p wX)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser ByteString (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 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 (m :: * -> *) a. MonadPlus m => m a mzero where bfl :: forall wZ . Parser (Sealed (FL p wZ)) bfl :: 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 (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 (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 :: 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 (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 :: 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 :: 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 -> String -> Parser AnchoredPath 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' -> AnchoredPath -> Parser AnchoredPath forall (m :: * -> *) a. Monad m => a -> m a return (AnchoredPath -> Parser AnchoredPath) -> AnchoredPath -> Parser AnchoredPath 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 (String -> AnchoredPath) -> (ByteString -> String) -> ByteString -> AnchoredPath forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String decodeWhite (String -> String) -> (ByteString -> String) -> ByteString -> 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 -> AnchoredPath floatPath (String -> AnchoredPath) -> (ByteString -> String) -> ByteString -> AnchoredPath forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String decodeWhite (String -> String) -> (ByteString -> String) -> ByteString -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> String decodeLocale convert FileNameFormat FileNameFormatDisplay = String -> ByteString -> AnchoredPath forall a. HasCallStack => String -> a error String "readFileName called with FileNameFormatDisplay"