    -- Copyright (C) 2002-2004 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.

    {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
    {-# LANGUAGE CPP #-}
    -- , TypeOperators, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}

    #include "gadts.h"

    -- | PatchChoices divides a sequence of patches into three sets: "first",
    -- "middle" and "last", such that all patches can be applied, if you first
    -- apply the first ones then the middle ones and then the last ones.
    -- Obviously if there are dependencies between the patches that will put a
    -- constraint on how you can choose to divide them up.  The PatchChoices data
    -- type and associated functions are here to deal with many of the common
    -- cases that come up when choosing a subset of a group of patches.
    --
    -- 'forceLast' tells PatchChoices that a particular patch is required to be in
    -- the "last" group, which also means that any patches that depend on it
    -- must be in the "last" group.
    --
    -- Internally, a PatchChoices doesn't actually reorder the patches until it is
    -- asked for the final output (e.g. by 'get_first_choice').  Instead, each
    -- patch is placed in a state of definitely first, definitely last and
    -- undecided; undecided leans towards "middle".  In case you're wondering
    -- about the first-middle-last language, it's because in some cases the
    -- "yes" answers will be last (as is the case for the revert command), and
    -- in others first (as in record, pull and push).
    module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps,
                                 patchChoicesTpsSub,
                          patchSlot,
                          getChoices,
                          separateFirstMiddleFromLast,
                          separateFirstFromMiddleLast,
                          forceFirst, forceFirsts, forceLast, forceLasts,
                          forceMatchingFirst, forceMatchingLast,
                          selectAllMiddles,
                          makeUncertain, makeEverythingLater,
                          TaggedPatch, Tag, tag, tpPatch,
                                 Slot(..),
                          substitute,
                        ) where

    import System.IO.Unsafe ( unsafePerformIO )
    import Data.IORef ( newIORef, writeIORef, readIORef )
    import Darcs.Patch
    import Darcs.Patch.Permutations ( commuteWhatWeCanRL )
    import Darcs.Patch.Patchy ( Invert, Commute )
    import Darcs.Witnesses.Ordered ( FL(..), RL(..), MyEq, unsafeCompare, EqCheck(..),
                                 (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),
                                 zipWithFL, mapFL_FL, mapFL, concatFL,
                                 (+>+), reverseRL, unsafeCoerceP )
    import Darcs.Witnesses.Sealed ( Sealed2(..) )

    -- | 'TG' @mp i@ acts as a temporary identifier to help us keep track of patches
    --   during the selection process.  These are useful for finding patches that
    --   may have moved around during patch selection (being pushed forwards or
    --   backwards as dependencies arise).
    --
    --   The identifier is implemented as a tuple @TG mp i@. The @i@ is just some
    --   arbitrary label, expected to be unique within the patches being
    --   scrutinised.  The @mp@ is motivated by patch splitting; it
    --   provides a convenient way to generate a new identifier from the patch
    --   being split.  For example, if we split a patch identified as @TG Nothing
    --   5@, the resulting sub-patches could be identified as @TG (TG Nothing 5)
    --   1@, @TG (TG Nothing 5) 2@, etc.
    data Tag = TG (Maybe Tag) Integer deriving ( Eq, Ord )
    data TaggedPatch p C(x y) = TP Tag (p C(x y))

    data PatchChoice p C(x y) = PC (TaggedPatch p C(x y)) Slot
    newtype PatchChoices p C(x y) = PCs (FL (PatchChoice p) C(x y))

    -- | See module documentation for 'Darcs.Patch.Choices'
    data Slot = InFirst | InMiddle | InLast

    negTag :: Tag -> Tag
    negTag (TG k n) = TG k (-n)

    invertTag :: Slot -> Slot
    invertTag InFirst = InLast
    invertTag InLast  = InFirst
    invertTag t = t

    tag :: TaggedPatch p C(x y) -> Tag
    tag (TP tg _) = tg

    tpPatch :: TaggedPatch p C(x y) -> p C(x y)
    tpPatch (TP _ p) = p

    liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b))
    liftTP f (TP t p) = TP t (f p)

    -- This is dangerous if two patches from different tagged series are compared
    -- ideally Tag (and hence TaggedPatch/PatchChoices) would have a witness type
    -- to represent the originally tagged sequence.
    compareTags :: TaggedPatch p C(a b) -> TaggedPatch p C(c d) -> EqCheck C((a, b) (c, d))
    compareTags (TP t1 _) (TP t2 _) = if t1 == t2 then unsafeCoerceP IsEq else NotEq

    instance MyEq p => MyEq (TaggedPatch p) where
        unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2

    instance Invert p => Invert (TaggedPatch p) where
        invert = liftTP invert
        identity = TP (TG Nothing (-1)) identity

    instance Commute p => Commute (TaggedPatch p) where
        commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2)
                                            return (TP t2 p2' :> TP t1 p1')
        listTouchedFiles (TP _ p) = listTouchedFiles p
        hunkMatches f (TP _ p) = hunkMatches f p
        merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of
                                         p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1'

    patchChoices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y)
    patchChoices = fst . patchChoicesTps

    -- |Tag a sequence of patches as subpatches of an existing tag. This is intended for
    -- use when substituting a patch for an equivalent patch or patches.
    patchChoicesTpsSub :: Patchy p
                          => Maybe Tag -> FL p C(x y)
                          -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))
    patchChoicesTpsSub tg ps = let tps = zipWithFL TP (map (TG tg) [1..]) ps
                                  in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps)

    -- |Tag a sequence of patches.
    patchChoicesTps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))
    patchChoicesTps = patchChoicesTpsSub Nothing

    instance MyEq p => MyEq (PatchChoice p) where
        unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2

    instance Invert p => Invert (PatchChoice p) where
        invert (PC tp mf) = PC (invert tp) (invertTag mf)
        identity = PC identity InMiddle

    instance Commute p => Commute (PatchChoice p) where
        commute (PC t1 x1 :> PC t2 x2)
            = do t2' :> t1' <- commute (t1 :> t2)
                 return (PC t2' x2 :> PC t1' x1)
        merge (PC t1 x1 :\/: PC t2 x2)
            = case merge (t1 :\/: t2) of
              t2' :/\: t1' -> PC t2' x2 :/\: PC t1' x1
        listTouchedFiles (PC t _) = listTouchedFiles t
        hunkMatches f (PC t _) = hunkMatches f t

    invertSeq :: (Invert p, Invert q) => (p :> q) C(x y) -> (q :> p) C(y x)
    invertSeq (x :> y) = (invert y :> invert x)

    separateFirstFromMiddleLast :: Patchy p => PatchChoices p C(x z)
                                    -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
    separateFirstFromMiddleLast (PCs e) = pull_only_firsts e

    separateFirstMiddleFromLast :: Patchy p => PatchChoices p C(x z)
                                    -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
    separateFirstMiddleFromLast (PCs e) = pull_firsts_middles e

    getChoices :: Patchy p => PatchChoices p C(x y)
                -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)
    getChoices (PCs e) = case pull_firsts e of
                          f :> ml -> case pull_firsts (invert ml) of
                                     l :> m -> f :> mapFL_FL pc2tp (invert m) :> invert l
      where pc2tp (PC tp _) = tp

    {-
    This unsafePerformIO hack was reported by Igloo as being necessary for
    constant space performance when working with a very large set of changes
    (e.g. from an initial import) where the second element of the returned tuple
    is expected to be small, and will only be accessed after the entire first
    element has been forced.
    On a quick scan on 20080729 it seemed like only revert/unrevert actually
    make use of both elements of the tuple.
    We should (a) add a test case that checks on constant space usage and
    (b) clean up this interface and code, perhaps by replacing the FL :> FL
    with a custom structure that forces traversal of the first element to
    get at the second (but then how would we commute/pattern-match? messy...)
    -}

    pull_firsts_middles :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
    pull_firsts_middles easyPC =
        let r = unsafePerformIO
              $ newIORef (error "pull_firsts_middles called badly")
            f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d)
            f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL)
            f acc (PC tp InLast:>:e) = f (tp:<:acc) e
            f acc (PC tp _:>:e) = case commuteWhatWeCanRL (acc :> tp) of
                                  more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e
            xs = f NilRL easyPC
        in (xs :> unsafePerformIO (readIORef r))

    pull_only_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
    pull_only_firsts easyPC =
        let r = unsafePerformIO
              $ newIORef (error "pull_only_firsts called badly")
            f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d)
            f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL)
            f acc (PC tp InFirst:>:e) = case commuteWhatWeCanRL (acc :> tp) of
                                            more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e
            f acc (PC tp _:>:e) = f (tp:<:acc) e
            xs = f NilRL easyPC
        in (xs :> unsafePerformIO (readIORef r))

    {-
    pull_middles_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p])
    pull_middles_lasts easyPC =
        let r = unsafePerformIO
              $ newIORef (error "pull_middles_lasts called badly")
            f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` []
            f acc (PC tp (Just True):e) = f (tp:acc) e
            f acc (PC (TP t p) _:e) = case commute_up_list p acc of
                                      (acc', p') -> TP t p':f acc' e
            xs = f [] easyPC
        in (xs, unsafePerformIO (readIORef r))
    -}

    --pull_only_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p])
    --pull_only_lasts easyPC =
    --    let r = unsafePerformIO
    --          $ newIORef (error "pull_only_lasts called badly")
    --        f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` []
    --        f acc (PC (TP t p) (Just False):e) = case commute_up_list p acc of
    --                                             (acc', p') -> TP t p':f acc' e
    --        f acc (PC tp _:e) = f (tp:acc) e
    --        xs = f [] easyPC
    --    in (xs, unsafePerformIO (readIORef r))

    pull_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :>  FL (PatchChoice p)) C(x z)
    pull_firsts e = case pull_first e of
                    Nothing -> (NilFL :> e)
                    Just (p:>e') -> case pull_firsts e' of
                                    (ps:>e'') -> (p:>:ps :> e'')

    pull_lasts :: Patchy p => FL (PatchChoice p) C(x y) -> (FL (PatchChoice p) :> FL (TaggedPatch p)) C(x y)
    pull_lasts e = invertSeq $ pull_firsts $ invert e

    pull_first :: Patchy p => FL (PatchChoice p) C(x z) -> Maybe ((TaggedPatch p :> FL (PatchChoice p)) C(x z))
    pull_first NilFL = Nothing
    pull_first (PC tp InFirst:>:e) = Just (tp :> e)
    pull_first (PC (TP t p) InLast:>:e) =
        case pull_first e of
        Just (TP t2 p2 :> e') ->
            case commute (p:>p2) of
            Just (p2':>p') -> Just (TP t2 p2' :> PC (TP t p') InLast:>:e')
            Nothing -> error "Aaack fixme!"
        Nothing -> Nothing
    pull_first (PC tp@(TP t p) InMiddle:>:e) =
        case pull_first e of
        Just (TP t2 p2 :> e') ->
            case commute (p:>p2) of
            Just (p2':>p') -> Just (TP t2 p2' :> (PC (TP t p') InMiddle:>:e'))
            Nothing -> Just (tp :> PC (TP (negTag t2) p2) InFirst:>:e')
        Nothing -> Nothing

    patchSlot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot
    patchSlot tp (PCs e) = ipf e
      where ipf :: FL (PatchChoice p) C(u v) -> Slot
            ipf (PC a mb:>:e') | tag a == tag tp = mb
                               | otherwise = ipf e'
            -- actually, the following should be impossible, but this is a reasonable answer
            ipf NilFL = InLast

    -- | 'setSimplys' @ts s ps@ assigns all patches in @ps@ with a tag in @ts@ to slot @s@
    --   (and any other patch to slot 'InMiddle')
    setSimplys :: [Tag] -> Slot -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y)
    setSimplys ts s e = mapFL_FL ch e
        where ch (PC tp@(TP t _) _)
               | t `elem` ts = PC tp s
               | otherwise   = PC tp InMiddle

    m2ids :: (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> FL (PatchChoice p) C(a b) -> [Tag]
    m2ids m (PC tp@(TP t _) _:>:e)
     | m tp = t:m2ids m e
     | otherwise = m2ids m e
    m2ids _ NilFL = []

    forceMatchingFirst :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)
                         -> PatchChoices p C(a b) -> PatchChoices p C(a b)
    forceMatchingFirst m (PCs e) =
        let thd (PC (TP t _) _) = t
            xs = m2ids m e
            not_needed = case pull_firsts $ setSimplys xs InFirst e of
                         _ :> rest -> mapFL thd rest
            ch pc@(PC tp@(TP t _) _)
             | t `elem` not_needed = pc
             | otherwise = PC tp InFirst
        in PCs $ mapFL_FL ch e

    forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
    forceFirsts ps pc = forceMatchingFirst ((`elem` ps) . tag) pc

    forceFirst :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
    forceFirst p pc = forceMatchingFirst ((== p) . tag) pc

    selectAllMiddles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y)
    selectAllMiddles b (PCs e) = PCs (mapFL_FL f e)
        where f (PC tp InMiddle) = PC tp (if b then InLast else InFirst)
              f pc = pc

    reverse_pc :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(y x)
    reverse_pc (PCs e) = PCs $ invert e

    forceMatchingLast :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)
                        -> PatchChoices p C(a b) -> PatchChoices p C(a b)
    forceMatchingLast m (PCs e) =
        let thd (PC (TP t _) _) = t
            xs = m2ids m e
            not_needed = case pull_lasts $ setSimplys xs InLast e of
                         rest :> _ -> mapFL thd rest
            ch pc@(PC tp@(TP t _) _)
             | t `elem` not_needed = pc
             | otherwise = PC tp InLast
        in PCs $ mapFL_FL ch e

    forceLast :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
    forceLast p pc = reverse_pc $ forceFirst p $ reverse_pc pc

    forceLasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
    forceLasts ps pc = reverse_pc $ forceFirsts ps $ reverse_pc pc

    makeUncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
    makeUncertain t (PCs e) = PCs $ mapFL_FL ch e
        where ch pc@(PC x _) = if t == tag x then PC x InMiddle else pc

    makeEverythingLater :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)
    makeEverythingLater (PCs e) = PCs $ mapFL_FL ch e
        where ch (PC tp InMiddle) = PC tp InLast
              ch (PC tp InFirst)  = PC tp InMiddle
              ch x = x

    -- | 'substitute' @(a :||: bs)@ @pcs@ replaces @a@ with @bs@ in @pcs@ preserving the choice
    --   associated with @a@
    substitute :: forall p C(x y)
                . Patchy p
               => Sealed2 (TaggedPatch p :||: FL (TaggedPatch p))
               -> PatchChoices p C(x y)
               -> PatchChoices p C(x y)
    substitute (Sealed2 (tp :||: new_tps)) (PCs pcs) = PCs (concatFL (mapFL_FL translate pcs))
       where translate :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b)
             translate (PC tp' c)
                 | IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps
                 | otherwise = PC tp' c :>: NilFL