-- Copyright (C) 2007 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.Witnesses.Ordered
(
-- * Directed Types
-- $DirectedTypes
(:>)(..)
, FL(..)
, RL(..)
-- * Merge Types
-- $MergeTypes
, (:\/:)(..)
, (:/\:)(..)
, (:||:)(..)
, Fork(..)
-- * Functions for 'FL's and 'RL's
, nullFL
, nullRL
, lengthFL
, lengthRL
, mapFL
, mapRL
, mapFL_FL
, mapRL_RL
, foldrFL
, foldlRL
, foldrwFL
, foldlwRL
, allFL
, allRL
, anyFL
, anyRL
, filterFL
, filterRL
, foldFL_M
, foldRL_M
, splitAtFL
, splitAtRL
, filterOutFLFL
, filterOutRLRL
, reverseFL
, reverseRL
, (+>+)
, (+<+)
, (+>>+)
, (+<<+)
, concatFL
, concatRL
, dropWhileFL
, dropWhileRL
-- * 'FL' only
, bunchFL
, spanFL
, spanFL_M
, zipWithFL
, toFL
, mapFL_FL_M
, sequenceFL_
, eqFL
, eqFLUnsafe
, initsFL
-- * 'RL' only
, isShorterThanRL
, snocRLSealed
, spanRL
, breakRL
, takeWhileRL
, concatRLFL
) where
import Darcs.Prelude
import Darcs.Patch.Witnesses.Show
import Darcs.Patch.Witnesses.Sealed
( FlippedSeal(..)
, flipSeal
, Sealed(..)
, FreeLeft
, unFreeLeft
, Sealed2(..)
, seal
)
import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )
-- * Directed Types
-- $DirectedTypes
-- Darcs patches have a notion of transforming between contexts. This
-- naturally leads us to container types that are \"directed\" and
-- transform from one context to another.
--
-- For example, the swap of names of files x and y could be represented
-- with the following sequence of patches:
--
-- @ Move x z ':>' Move y x ':>' Move z y @
--
-- or using forward lists, like
--
-- @ Move x z ':>:' Move y x ':>:' Move z y ':>:' NilFL @
-- | Directed Forward Pairs
data (a1 :> a2) wX wY = forall wZ . (a1 wX wZ) :> (a2 wZ wY)
infixr 1 :>
-- | Forward lists
data FL a wX wZ where
(:>:) :: a wX wY -> FL a wY wZ -> FL a wX wZ
NilFL :: FL a wX wX
-- | Reverse lists
data RL a wX wZ where
(:<:) :: RL a wX wY -> a wY wZ -> RL a wX wZ
NilRL :: RL a wX wX
instance Show2 a => Show (FL a wX wZ) where
showsPrec _ NilFL = showString "NilFL"
showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .
showString " :>: " . showsPrec (prec + 1) xs
where prec = 5
instance Show2 a => Show1 (FL a wX)
instance Show2 a => Show2 (FL a)
instance Show2 a => Show (RL a wX wZ) where
showsPrec _ NilRL = showString "NilRL"
showsPrec d (xs :<: x) = showParen (d > prec) $ showsPrec (prec + 1) xs .
showString " :<: " . showsPrec2 (prec + 1) x
where prec = 5
instance Show2 a => Show1 (RL a wX)
instance Show2 a => Show2 (RL a)
instance (Show2 a, Show2 b) => Show1 ((a :> b) wX)
-- * Merge Types
-- $MergeTypes
-- When we have two patches which commute and share the same pre-context we can
-- merge the patches. Whenever patches, or sequences of patches, share a
-- pre-context we say they are Forking Pairs (':\/:'). The same way, when
-- patches or sequences of patches, share a post-context we say they are
-- Joining Pairs (':/\:').
--
-- The following diagram shows the symmetry of merge types:
--
-- @ wZ
-- ':/\:'
-- a3 / \ a4
-- / \
-- wX wY
-- \ /
-- a1 \ / a2
-- ':\/:'
-- wZ
-- @
--
-- (non-haddock version)
-- wZ
-- :/\:
-- a3 / \ a4
-- / \
-- wX wY
-- \ /
-- a1 \ / a2
-- :\/:
-- wZ
--
infix 1 :/\:, :\/:, :||:
-- | Forking Pairs (Implicit starting context)
data (a1 :\/: a2) wX wY = forall wZ . (a1 wZ wX) :\/: (a2 wZ wY)
-- | Joining Pairs
data (a3 :/\: a4) wX wY = forall wZ . (a3 wX wZ) :/\: (a4 wY wZ)
-- | Forking Pair (Explicit starting context)
--
-- @ wX wY
-- \ /
-- \ /
-- \ /
-- wU
-- |
-- |
-- |
-- wA
-- @
--
-- (non-haddock version)
--
-- wX wY
-- \ /
-- \ /
-- \ /
-- wU
-- |
-- |
-- |
-- wA
--
data Fork common left right wA wX wY =
forall wU. Fork (common wA wU) (left wU wX) (right wU wY)
-- | Parallel Pairs
data (a1 :||: a2) wX wY = (a1 wX wY) :||: (a2 wX wY)
instance (Show2 a, Show2 b) => Show ( (a :> b) wX wY ) where
showsPrec d (x :> y) = showOp2 1 ":>" d x y
instance (Eq2 a, Eq2 b) => Eq2 (a :> b) where
(a1 :> b1) =\/= (a2 :> b2) | IsEq <- a1 =\/= a2 = b1 =\/= b2
| otherwise = NotEq
instance (Eq2 a, Eq2 b) => Eq ((a :> b) wX wY) where
(==) = unsafeCompare
instance (Show2 a, Show2 b) => Show2 (a :> b)
instance (Show2 a, Show2 b) => Show ( (a :\/: b) wX wY ) where
showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y
instance (Show2 a, Show2 b) => Show2 (a :\/: b)
instance (Show2 a, Show2 b) => Show ( (a :/\: b) wX wY ) where
showsPrec d (x :/\: y) = showOp2 1 ":/\\:" d x y
instance (Show2 a, Show2 b) => Show2 ( (a :/\: b) )
-- * Functions
infixr 5 :>:, +>+
infixl 5 :<:, +<+
nullFL :: FL a wX wZ -> Bool
nullFL NilFL = True
nullFL _ = False
nullRL :: RL a wX wZ -> Bool
nullRL NilRL = True
nullRL _ = False
-- | @filterOutFLFL p xs@ deletes any @x@ in @xs@ for which @p x == IsEq@
-- (indicating that @x@ has no effect as far as we are concerned, and can be
-- safely removed from the chain)
filterOutFLFL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> FL p wW wZ -> FL p wW wZ
filterOutFLFL _ NilFL = NilFL
filterOutFLFL f (x:>:xs) | IsEq <- f x = filterOutFLFL f xs
| otherwise = x :>: filterOutFLFL f xs
filterOutRLRL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> RL p wW wZ -> RL p wW wZ
filterOutRLRL _ NilRL = NilRL
filterOutRLRL f (xs:<:x) | IsEq <- f x = filterOutRLRL f xs
| otherwise = filterOutRLRL f xs :<: x
filterRL :: (forall wX wY . p wX wY -> Bool) -> RL p wA wB -> [Sealed2 p]
filterRL _ NilRL = []
filterRL f (xs :<: x) | f x = Sealed2 x : (filterRL f xs)
| otherwise = filterRL f xs
(+>+) :: FL a wX wY -> FL a wY wZ -> FL a wX wZ
NilFL +>+ ys = ys
(x:>:xs) +>+ ys = x :>: xs +>+ ys
(+<+) :: RL a wX wY -> RL a wY wZ -> RL a wX wZ
xs +<+ NilRL = xs
xs +<+ (ys:<:y) = xs +<+ ys :<: y
reverseFL :: FL a wX wZ -> RL a wX wZ
reverseFL xs = r NilRL xs
where r :: RL a wL wM -> FL a wM wO -> RL a wL wO
r ls NilFL = ls
r ls (a:>:as) = r (ls:<:a) as
reverseRL :: RL a wX wZ -> FL a wX wZ
reverseRL xs = r NilFL xs
where r :: FL a wM wO -> RL a wL wM -> FL a wL wO
r ls NilRL = ls
r ls (as:<:a) = r (a:>:ls) as
concatFL :: FL (FL a) wX wZ -> FL a wX wZ
concatFL NilFL = NilFL
concatFL (a:>:as) = a +>+ concatFL as
concatRL :: RL (RL a) wX wZ -> RL a wX wZ
concatRL NilRL = NilRL
concatRL (as:<:a) = concatRL as +<+ a
spanFL :: (forall wW wY . a wW wY -> Bool) -> FL a wX wZ -> (FL a :> FL a) wX wZ
spanFL f (x:>:xs) | f x = case spanFL f xs of
ys :> zs -> (x:>:ys) :> zs
spanFL _ xs = NilFL :> xs
spanFL_M :: forall a m wX wZ. Monad m =>
(forall wW wY . a wW wY -> m Bool) -> FL a wX wZ
-> m ((FL a :> FL a) wX wZ)
spanFL_M f (x:>:xs) =
do
continue <- f x
if continue
then do (ys :> zs) <- spanFL_M f xs
return $ (x :>: ys) :> zs
else return $ NilFL :> (x :>: xs)
spanFL_M _ (NilFL) = return $ NilFL :> NilFL
splitAtFL :: Int -> FL a wX wZ -> (FL a :> FL a) wX wZ
splitAtFL 0 xs = NilFL :> xs
splitAtFL _ NilFL = NilFL :> NilFL
splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of
(xs':>xs'') -> (x:>:xs' :> xs'')
splitAtRL :: Int -> RL a wX wZ -> (RL a :> RL a) wX wZ
splitAtRL 0 xs = xs :> NilRL
splitAtRL _ NilRL = NilRL :> NilRL
splitAtRL n (xs:<:x) = case splitAtRL (n-1) xs of
(xs'':>xs') -> (xs'':> xs':<:x)
-- 'bunchFL n' groups patches into batches of n, except that it always puts
-- the first patch in its own group, this being a recognition that the
-- first patch is often *very* large.
bunchFL :: Int -> FL a wX wY -> FL (FL a) wX wY
bunchFL _ NilFL = NilFL
bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs
where bFL :: FL a wX wY -> FL (FL a) wX wY
bFL NilFL = NilFL
bFL bs = case splitAtFL n bs of
a :> b -> a :>: bFL b
-- | Monadic fold over an 'FL' associating to the left, sequencing
-- effects from left to right.
-- The order of arguments follows the standard 'foldM' from base.
foldFL_M :: Monad m
=> (forall wA wB. r wA -> p wA wB -> m (r wB))
-> r wX -> FL p wX wY -> m (r wY)
foldFL_M _ r NilFL = return r
foldFL_M f r (x :>: xs) = f r x >>= \r' -> foldFL_M f r' xs
-- | Monadic fold over an 'FL' associating to the right, sequencing
-- effects from right to left.
-- Mostly useful for prepend-like operations with an effect where the
-- order of effects is not relevant.
foldRL_M :: Monad m
=> (forall wA wB. p wA wB -> r wB -> m (r wA))
-> RL p wX wY -> r wY -> m (r wX)
foldRL_M _ NilRL r = return r
foldRL_M f (xs :<: x) r = f x r >>= foldRL_M f xs
allFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool
allFL f xs = and $ mapFL f xs
anyFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool
anyFL f xs = or $ mapFL f xs
allRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> Bool
allRL f xs = and $ mapRL f xs
anyRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> Bool
anyRL f xs = or $ mapRL f xs
-- | The "natural" fold over an 'FL' i.e. associating to the right.
-- Like 'Prelude.foldr' only with the more useful order of arguments.
foldrFL :: (forall wA wB . p wA wB -> r -> r) -> FL p wX wY -> r -> r
foldrFL _ NilFL r = r
foldrFL f (p:>:ps) r = f p (foldrFL f ps r)
-- | The "natural" fold over an RL i.e. associating to the left.
foldlRL :: (forall wA wB . r -> p wA wB -> r) -> r -> RL p wX wY -> r
foldlRL _ r NilRL = r
foldlRL f r (ps:<:p) = f (foldlRL f r ps) p
-- | Right associative fold for 'FL's that transforms a witnessed state
-- in the direction opposite to the 'FL'.
-- This is the "natural" fold for 'FL's i.e. the one which replaces the
-- ':>:' with the passed operator.
foldrwFL :: (forall wA wB . p wA wB -> r wB -> r wA) -> FL p wX wY -> r wY -> r wX
foldrwFL _ NilFL r = r
foldrwFL f (p:>:ps) r = f p (foldrwFL f ps r)
-- | The analog of 'foldrwFL' for 'RL's.
-- This is the "natural" fold for 'RL's i.e. the one which replaces the
-- ':<:' with the passed operator.
foldlwRL :: (forall wA wB . r wA -> p wA wB -> r wB) -> r wX -> RL p wX wY -> r wY
foldlwRL _ r NilRL = r
foldlwRL f r (ps:<:p) = f (foldlwRL f r ps) p
mapFL_FL :: (forall wW wY . a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL _ NilFL = NilFL
mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as
mapFL_FL_M :: Monad m => (forall wW wY . a wW wY -> m (b wW wY)) -> FL a wX wZ -> m (FL b wX wZ)
mapFL_FL_M _ NilFL = return NilFL
mapFL_FL_M f (a:>:as) = do b <- f a
bs <- mapFL_FL_M f as
return (b:>:bs)
sequenceFL_ :: Monad m => (forall wW wZ . a wW wZ -> m b) -> FL a wX wY -> m ()
sequenceFL_ f = sequence_ . mapFL f
zipWithFL :: (forall wX wY . a -> p wX wY -> q wX wY)
-> [a] -> FL p wW wZ -> FL q wW wZ
zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys
zipWithFL _ _ NilFL = NilFL
zipWithFL _ [] (_:>:_) = error "zipWithFL called with too short a list"
mapRL_RL :: (forall wW wY . a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ
mapRL_RL _ NilRL = NilRL
mapRL_RL f (as:<:a) = mapRL_RL f as :<: f a
{-# INLINABLE mapFL #-}
mapFL :: (forall wW wZ . a wW wZ -> b) -> FL a wX wY -> [b]
mapFL _ NilFL = []
mapFL f (a :>: b) = f a : mapFL f b
filterFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> [Sealed2 a]
filterFL _ NilFL = []
filterFL f (a :>: b) = if f a
then (Sealed2 a):(filterFL f b)
else filterFL f b
mapRL :: (forall wW wZ . a wW wZ -> b) -> RL a wX wY -> [b]
mapRL _ NilRL = []
mapRL f (as :<: a) = f a : mapRL f as
lengthFL :: FL a wX wZ -> Int
lengthFL xs = l xs 0
where l :: FL a wX wZ -> Int -> Int
l NilFL n = n
l (_:>:as) n = l as $! n+1
lengthRL :: RL a wX wZ -> Int
lengthRL xs = l xs 0
where l :: RL a wX wZ -> Int -> Int
l NilRL n = n
l (as:<:_) n = l as $! n+1
isShorterThanRL :: RL a wX wY -> Int -> Bool
isShorterThanRL _ n | n <= 0 = False
isShorterThanRL NilRL _ = True
isShorterThanRL (xs:<:_) n = isShorterThanRL xs (n-1)
snocRLSealed :: FlippedSeal (RL a) wY -> a wY wZ -> FlippedSeal (RL a) wZ
snocRLSealed (FlippedSeal as) a = flipSeal $ as :<: a
toFL :: [FreeLeft a] -> Sealed (FL a wX)
toFL [] = Sealed NilFL
toFL (x:xs) = case unFreeLeft x of Sealed y -> case toFL xs of Sealed ys -> Sealed (y :>: ys)
dropWhileFL :: (forall wX wY . a wX wY -> Bool) -> FL a wR wV -> FlippedSeal (FL a) wV
dropWhileFL _ NilFL = flipSeal NilFL
dropWhileFL p xs@(x:>:xs')
| p x = dropWhileFL p xs'
| otherwise = flipSeal xs
dropWhileRL :: (forall wX wY . a wX wY -> Bool) -> RL a wR wV -> Sealed (RL a wR)
dropWhileRL _ NilRL = seal NilRL
dropWhileRL p xs@(xs':<:x)
| p x = dropWhileRL p xs'
| otherwise = seal xs
-- | Like 'takeWhile' only for 'RL's. This function is supposed to be lazy:
-- elements before the split point should not be touched.
takeWhileRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> FlippedSeal (RL a) wY
takeWhileRL f xs = case spanRL f xs of _ :> r -> flipSeal r
-- | Like 'span' only for 'RL's. This function is supposed to be lazy:
-- elements before the split point should not be touched.
spanRL :: (forall wA wB . p wA wB -> Bool) -> RL p wX wY -> (RL p :> RL p) wX wY
spanRL _ NilRL = NilRL :> NilRL
spanRL f left@(ps :<: p)
| f p = case spanRL f ps of left' :> right -> left' :> right :<: p
| otherwise = left :> NilRL
-- | Like 'break' only for 'RL's. This function is supposed to be lazy:
-- elements before the split point should not be touched.
breakRL :: (forall wA wB . p wA wB -> Bool) -> RL p wX wY -> (RL p :> RL p) wX wY
breakRL f = spanRL (not . f)
-- |Check that two 'FL's are equal element by element.
-- This differs from the 'Eq2' instance for 'FL' which
-- uses commutation.
eqFL :: Eq2 a => FL a wX wY -> FL a wX wZ -> EqCheck wY wZ
eqFL NilFL NilFL = IsEq
eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq
eqFL _ _ = NotEq
eqFLUnsafe :: Eq2 a => FL a wX wY -> FL a wZ wW -> Bool
eqFLUnsafe NilFL NilFL = True
eqFLUnsafe (x:>:xs) (y:>:ys) = unsafeCompare x y && eqFLUnsafe xs ys
eqFLUnsafe _ _ = False
infixr 5 +>>+
infixl 5 +<<+
-- | Prepend an 'RL' to an 'FL'. This traverses only the left hand side.
(+>>+) :: RL p wX wY -> FL p wY wZ -> FL p wX wZ
NilRL +>>+ ys = ys
(xs:<:x) +>>+ ys = xs +>>+ (x :>: ys)
-- | Append an 'FL' to an 'RL'. This traverses only the right hand side.
(+<<+) :: RL p wX wY -> FL p wY wZ -> RL p wX wZ
xs +<<+ NilFL = xs
xs +<<+ (y:>:ys) = (xs:<:y) +<<+ ys
initsFL :: FL p wX wY -> [Sealed ((p :> FL p) wX)]
initsFL NilFL = []
initsFL (x :>: xs) =
Sealed (x :> NilFL) :
map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs)
concatRLFL :: RL (FL p) wX wY -> RL p wX wY
concatRLFL NilRL = NilRL
concatRLFL (ps :<: p) = concatRLFL ps +<<+ p