content: -- {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
  {-# LANGUAGE
          GADTs,
          TypeOperators,
          ScopedTypeVariables,
          RankNTypes,
          NoMonoLocalBinds
   #-}
  {-# OPTIONS_GHC -O2 -w #-}
  {-
    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 T4524 where
  
  import Data.Maybe ( mapMaybe )
  import Control.Applicative ( Alternative(..) )
  import Control.Monad ( MonadPlus(..), msum, ap, liftM )
  import Unsafe.Coerce (unsafeCoerce)
  
  newtype FileName = FN FilePath deriving ( Eq, Ord )
  
  data FL a x z where
      (:>:) :: a x y -> FL a y z -> FL a x z
      NilFL :: FL a x x
  data RL a x z where
      (:<:) :: a y z -> RL a x y -> RL a x z
      NilRL :: RL a x x
  data (a1 :> a2) x y = forall z. (a1 x z) :> (a2 z y)
  infixr 1 :>
  data (a1 :< a2) x y = forall z. (a1 z y) :< (a2 x z)
  infix 1 :<
  infixr 5 :>:, :<:
  
  data EqCheck a b where
      IsEq :: EqCheck a a
      NotEq :: EqCheck a b
  
  class MyEq p => Invert p where
      invert :: p x y -> p y x
      identity :: p x x
  
  class MyEq p where
      unsafeCompare :: p a b -> p c d -> Bool
      unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b)
  
      (=\/=) :: p a b -> p a c -> EqCheck b c
      a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq
               | otherwise = NotEq
  
      (=/\=) :: p a c -> p b c -> EqCheck a b
      a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq
               | otherwise = NotEq
  
  infix 4 =\/=, =/\=
  
  class Commute p where
      commute :: (p :> p) x y -> Maybe ((p :> p) x y)
  
  instance (MyEq p, Commute p) => MyEq (FL p) where
  instance (MyEq p, Commute p) => MyEq (RL p) where
  instance Commute p => Commute (RL p) where
  instance (Commute p, Invert p) => Invert (RL p) where
  instance (Invert p, Commute p) => Invert (FL p) where
  instance Eq (EqCheck a b) where
  instance MyEq FilePatchType where
  instance Invert Patch where
  
  instance MyEq Patch where
      unsafeCompare = eqPatches
  
  eqPatches :: Patch x y -> Patch w z -> Bool
  eqPatches (PP p1) (PP p2) = undefined
  eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b)
   = eqPatches p1a p2a &&
     eqPatches p1b p2b
  eqPatches (Regrem _ _ p1a p1b) (Regrem _ _ p2a p2b)
   = eqPatches p1a p2a &&
     eqPatches p1b p2b
  eqPatches _ _ = False
  
  data Prim x y where
      FP :: !FileName -> !(FilePatchType x y) -> Prim x y
  
  data FilePatchType x y = FilePatchType
                              deriving (Eq,Ord)
  
  data Patch x y where
      PP :: Prim x y -> Patch x y
      Merger :: FL Patch x y
             -> RL Patch x b
             -> Patch c b
             -> Patch c d
             -> Patch x y
      Regrem :: FL Patch x y
             -> RL Patch x b
             -> Patch c b
             -> Patch c a
             -> Patch y x
  
  data Sealed a where
      Sealed :: a x -> Sealed a
  data FlippedSeal a y where
      FlippedSeal :: !(a x y) -> FlippedSeal a y
  
  mapFlipped :: (forall x. a x y -> b x z) -> FlippedSeal a y -> FlippedSeal b z
  mapFlipped f (FlippedSeal x) = FlippedSeal (f x)
  
  headPermutationsRL :: Commute p => RL p x y -> [RL p x y]
  headPermutationsRL NilRL = []
  headPermutationsRL (p:<:ps) =
      (p:<:ps) : mapMaybe (swapfirstRL.(p:<:)) (headPermutationsRL ps)
          where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1)
                                                Just $ p2':<:p1':<:xs
                swapfirstRL _ = Nothing
  
  is_filepatch :: Prim x y -> Maybe FileName
  is_filepatch (FP f _) = Just f
  is_filepatch _ = Nothing
  
  toFwdCommute :: (Commute p, Commute q, Monad m)
               => ((p :< q) x y -> m ((q :< p) x y))
               -> (q :> p) x y -> m ((p :> q) x y)
  toFwdCommute c (x :> y) = do x' :< y' <- c (y :< x)
                               return (y' :> x')
  
  unsafeUnseal :: Sealed a -> a x
  unsafeUnseal (Sealed a) = unsafeCoerceP1 a
  
  unsafeUnsealFlipped :: FlippedSeal a y -> a x y
  unsafeUnsealFlipped (FlippedSeal a) = unsafeCoerceP a
  
  unsafeCoerceP :: a x y -> a b c
  unsafeCoerceP = unsafeCoerce
  
  unsafeCoercePStart :: a x1 y -> a x2 y
  unsafeCoercePStart = unsafeCoerce
  
  unsafeCoercePEnd :: a x y1 -> a x y2
  unsafeCoercePEnd = unsafeCoerce
  
  unsafeCoerceP1 :: a x -> a y
  unsafeCoerceP1 = unsafeCoerce
  
  data Perhaps a = Unknown | Failed | Succeeded a
  
  instance Functor Perhaps where
    fmap = liftM
  
  instance Applicative Perhaps where
    pure  = return
    (<*>) = ap
  
  instance  Monad Perhaps where
      (Succeeded x) >>= k =  k x
      Failed   >>= _      =  Failed
      Unknown  >>= _      =  Unknown
      Failed   >> _       =  Failed
      (Succeeded _) >> k  =  k
      Unknown  >> k       =  k
      return              =  Succeeded
      fail _              =  Unknown
  
  instance Alternative Perhaps where
    (<|>) = mplus
    empty = mzero
  
  instance  MonadPlus Perhaps where
      mzero                 = Unknown
      Unknown `mplus` ys    = ys
      Failed  `mplus` _     = Failed
      (Succeeded x) `mplus` _ = Succeeded x
  
  toMaybe :: Perhaps a -> Maybe a
  toMaybe (Succeeded x) = Just x
  toMaybe _ = Nothing
  
  cleverCommute :: CommuteFunction -> CommuteFunction
  cleverCommute c (p1:<p2) =
      case c (p1 :< p2) of
      Succeeded x -> Succeeded x
      Failed -> Failed
  
  speedyCommute :: CommuteFunction
  speedyCommute (p1 :< p2) -- Deal with common case quickly!
      | p1_modifies /= Nothing && p2_modifies /= Nothing &&
        p1_modifies /= p2_modifies = undefined
      | otherwise = Unknown
      where p1_modifies = isFilepatchMerger p1
            p2_modifies = isFilepatchMerger p2
  
  everythingElseCommute :: MaybeCommute -> CommuteFunction
  everythingElseCommute _ x = undefined
  
  unsafeMerger :: String -> Patch x y -> Patch x z -> Patch a b
  unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2
  
  mergerCommute :: (Patch :< Patch) x y -> Perhaps ((Patch :< Patch) x y)
  mergerCommute (Merger _ _ p1 p2 :< pA)
      | unsafeCompare pA p1 = Succeeded (unsafeMerger "0.0" p2 p1 :< unsafeCoercePStart p2)
      | unsafeCompare pA (invert (unsafeMerger "0.0" p2 p1)) = Failed
  mergerCommute (Merger _ _
                  (Merger _ _ c b)
                  (Merger _ _ c' a) :<
                  Merger _ _ b' c'')
      | unsafeCompare b' b && unsafeCompare c c' && unsafeCompare c c'' = undefined
  mergerCommute _ = Unknown
  
  instance Commute Patch where
      commute x = toMaybe $ msum
                    [toFwdCommute speedyCommute x,
                     toFwdCommute (cleverCommute mergerCommute) x,
                     toFwdCommute (everythingElseCommute undefined) x
                    ]
  
  isFilepatchMerger :: Patch x y -> Maybe FileName
  isFilepatchMerger (PP p) = is_filepatch p
  isFilepatchMerger (Regrem und unw p1 p2)
      = isFilepatchMerger (Merger und unw p1 p2)
  
  type CommuteFunction = forall x y. (Patch :< Patch) x y -> Perhaps ((Patch :< Patch) x y)
  type MaybeCommute = forall x y. (Patch :< Patch) x y -> Maybe ((Patch :< Patch) x y)
  
  {- unwind, trueUnwind, reconcleUnwindings, and merger are most likely
   where the problem lies.  Everything above is just brought in to bring
   in enough context so that those four will compile. -}
  unwind :: Patch x y -> Sealed (RL Patch x) -- Recreates a patch history in reverse.
  unwind (Merger _ unwindings _ _) = Sealed unwindings
  unwind p = Sealed (p :<: NilRL)
  
  trueUnwind :: Patch x y -> Sealed (RL Patch x) -- Recreates a patch history in reverse.
  trueUnwind p@(Merger _ _ p1 p2) =
      case (unwind p1, unwind p2) of
      (Sealed (_:<:p1s),Sealed (_:<:p2s)) ->
           Sealed (p :<: unsafeCoerceP p1 :<: unsafeUnsealFlipped (reconcileUnwindings p1s (unsafeCoercePEnd p2s)))
  
  reconcileUnwindings :: RL Patch x z -> RL Patch y z -> FlippedSeal (RL Patch) z
  reconcileUnwindings p1s NilRL = FlippedSeal p1s
  reconcileUnwindings (p1:<:_) (p2:<:_) =
      case [undefined | p1s'@(_:<:_) <- headPermutationsRL (p1:<:undefined)] of
      ((_:<:p1s', _:<:p2s'):_) ->
          mapFlipped (undefined :<:) $ reconcileUnwindings p1s' (unsafeCoercePEnd p2s')
  
  merger :: String -> Patch x y -> Patch x z -> Sealed (Patch y)
  merger "0.0" p1 p2 = Sealed $ Merger undoit unwindings p1 p2
      where fake_p = Merger identity NilRL p1 p2
            unwindings = unsafeUnseal (trueUnwind fake_p)
            p = undefined
            undoit = undefined
  