module Darcs.Patch.Repair
    ( Repair(..), RepairToFL(..), mapMaybeSnd, Check(..) )
    where

import Darcs.Prelude

import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.ApplyMonad ( ApplyMonad )
import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), mapFL, mapRL, (+>+) )
import Darcs.Util.Printer ( Doc )

import Data.Maybe ( catMaybes, listToMaybe )


class Check p where
    isInconsistent :: p wX wY -> Maybe Doc
    isInconsistent p wX wY
_ = Maybe Doc
forall a. Maybe a
Nothing

-- |'Repair' and 'RepairToFL' deal with repairing old patches that were were
-- written out due to bugs or that we no longer wish to support. 'Repair' is
-- implemented by collections of patches (FL, Named, PatchInfoAnd) that might
-- need repairing.
class Repair p where
    applyAndTryToFix
      :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, p wX wY))

-- |'RepairToFL' is implemented by single patches that can be repaired (Prim,
-- Patch, RepoPatchV2) There is a default so that patch types with no current
-- legacy problems don't need to have an implementation.
class Apply p => RepairToFL p where
    applyAndTryToFixFL
      :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, FL p wX wY))
    applyAndTryToFixFL p wX wY
p = do p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p; Maybe (String, FL p wX wY) -> m (Maybe (String, FL p wX wY))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, FL p wX wY)
forall a. Maybe a
Nothing

mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b)
mapMaybeSnd :: forall a b c. (a -> b) -> Maybe (c, a) -> Maybe (c, b)
mapMaybeSnd a -> b
f (Just (c
a,a
b)) = (c, b) -> Maybe (c, b)
forall a. a -> Maybe a
Just (c
a,a -> b
f a
b)
mapMaybeSnd a -> b
_ Maybe (c, a)
Nothing = Maybe (c, b)
forall a. Maybe a
Nothing

instance Check p => Check (FL p) where
    isInconsistent :: forall wX wY. FL p wX wY -> Maybe Doc
isInconsistent = [Doc] -> Maybe Doc
forall a. [a] -> Maybe a
listToMaybe ([Doc] -> Maybe Doc)
-> (FL p wX wY -> [Doc]) -> FL p wX wY -> Maybe Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Doc] -> [Doc]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Doc] -> [Doc])
-> (FL p wX wY -> [Maybe Doc]) -> FL p wX wY -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wW wZ. p wW wZ -> Maybe Doc) -> FL p wX wY -> [Maybe Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL p wW wZ -> Maybe Doc
forall wW wZ. p wW wZ -> Maybe Doc
forall (p :: * -> * -> *) wX wY. Check p => p wX wY -> Maybe Doc
isInconsistent

instance Check p => Check (RL p) where
    isInconsistent :: forall wX wY. RL p wX wY -> Maybe Doc
isInconsistent = [Doc] -> Maybe Doc
forall a. [a] -> Maybe a
listToMaybe ([Doc] -> Maybe Doc)
-> (RL p wX wY -> [Doc]) -> RL p wX wY -> Maybe Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Doc] -> [Doc]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Doc] -> [Doc])
-> (RL p wX wY -> [Maybe Doc]) -> RL p wX wY -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wW wZ. p wW wZ -> Maybe Doc) -> RL p wX wY -> [Maybe Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL p wW wZ -> Maybe Doc
forall wW wZ. p wW wZ -> Maybe Doc
forall (p :: * -> * -> *) wX wY. Check p => p wX wY -> Maybe Doc
isInconsistent

instance RepairToFL p => Repair (FL p) where
    applyAndTryToFix :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL p)) m =>
FL p wX wY -> m (Maybe (String, FL p wX wY))
applyAndTryToFix FL p wX wY
NilFL = Maybe (String, FL p wX wY) -> m (Maybe (String, FL p wX wY))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, FL p wX wY)
forall a. Maybe a
Nothing
    applyAndTryToFix (p wX wY
p :>: FL p wY wY
ps) = do
      Maybe (String, FL p wX wY)
mp <- p wX wY -> m (Maybe (String, FL p wX wY))
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m (Maybe (String, FL p wX wY))
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(RepairToFL p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m (Maybe (String, FL p wX wY))
applyAndTryToFixFL p wX wY
p
      Maybe (String, FL p wY wY)
mps <- FL p wY wY -> m (Maybe (String, FL p wY wY))
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL p)) m =>
FL p wX wY -> m (Maybe (String, FL p wX wY))
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Repair p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m (Maybe (String, p wX wY))
applyAndTryToFix FL p wY wY
ps
      Maybe (String, FL p wX wY) -> m (Maybe (String, FL p wX wY))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (String, FL p wX wY) -> m (Maybe (String, FL p wX wY)))
-> Maybe (String, FL p wX wY) -> m (Maybe (String, FL p wX wY))
forall a b. (a -> b) -> a -> b
$
        case (Maybe (String, FL p wX wY)
mp, Maybe (String, FL p wY wY)
mps) of
          (Maybe (String, FL p wX wY)
Nothing, Maybe (String, FL p wY wY)
Nothing) -> Maybe (String, FL p wX wY)
forall a. Maybe a
Nothing
          (Just (String
e, FL p wX wY
p'), Maybe (String, FL p wY wY)
Nothing) -> (String, FL p wX wY) -> Maybe (String, FL p wX wY)
forall a. a -> Maybe a
Just (String
e, FL p wX wY
p' FL p wX wY -> FL p wY wY -> FL p wX wY
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p wY wY
ps)
          (Maybe (String, FL p wX wY)
Nothing, Just (String
e, FL p wY wY
ps')) -> (String, FL p wX wY) -> Maybe (String, FL p wX wY)
forall a. a -> Maybe a
Just (String
e, p wX wY
p p wX wY -> FL p wY wY -> FL p wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wY wY
ps')
          (Just (String
e, FL p wX wY
p'), Just (String
es, FL p wY wY
ps')) -> (String, FL p wX wY) -> Maybe (String, FL p wX wY)
forall a. a -> Maybe a
Just (String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es, FL p wX wY
p' FL p wX wY -> FL p wY wY -> FL p wX wY
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p wY wY
ps')