Choices.hs

-- 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