1 -- Copyright (C) 2002-2004 David Roundy
    2 --
    3 -- This program is free software; you can redistribute it and/or modify
    4 -- it under the terms of the GNU General Public License as published by
    5 -- the Free Software Foundation; either version 2, or (at your option)
    6 -- any later version.
    7 --
    8 -- This program is distributed in the hope that it will be useful,
    9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
   10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   11 -- GNU General Public License for more details.
   12 --
   13 -- You should have received a copy of the GNU General Public License
   14 -- along with this program; see the file COPYING.  If not, write to
   15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   16 -- Boston, MA 02110-1301, USA.
   17 
   18 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
   19 {-# LANGUAGE CPP #-}
   20 -- , TypeOperators, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
   21 
   22 #include "gadts.h"
   23 
   24 -- | PatchChoices divides a sequence of patches into three sets: "first",
   25 -- "middle" and "last", such that all patches can be applied, if you first
   26 -- apply the first ones then the middle ones and then the last ones.
   27 -- Obviously if there are dependencies between the patches that will put a
   28 -- constraint on how you can choose to divide them up.  The PatchChoices data
   29 -- type and associated functions are here to deal with many of the common
   30 -- cases that come up when choosing a subset of a group of patches.
   31 --
   32 -- 'force_last' tells PatchChoices that a particular patch is required to be in
   33 -- the "last" group, which also means that any patches that depend on it
   34 -- must be in the "last" group.
   35 --
   36 -- Internally, a PatchChoices doesn't actually reorder the patches until it is
   37 -- asked for the final output (e.g. by 'get_first_choice').  Instead, each
   38 -- patch is placed in a state of definitely first, definitely last and
   39 -- undecided; undecided leans towards "middle".  In case you're wondering
   40 -- about the first-middle-last language, it's because in some cases the
   41 -- "yes" answers will be last (as is the case for the revert command), and
   42 -- in others first (as in record, pull and push).
   43 module Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps,
   44                       patch_slot,
   45                       get_choices,
   46                       separate_first_middle_from_last,
   47                       separate_first_from_middle_last,
   48                       force_first, force_firsts, force_last, force_lasts,
   49                       force_matching_first, force_matching_last,
   50                       select_all_middles,
   51                       make_uncertain, make_everything_later,
   52                       TaggedPatch, Tag, tag, tp_patch,
   53                              Slot(..),
   54                     ) where
   55 
   56 import System.IO.Unsafe ( unsafePerformIO )
   57 import Data.IORef ( newIORef, writeIORef, readIORef )
   58 import Darcs.Patch
   59 import Darcs.Patch.Permutations ( commuteWhatWeCanRL )
   60 import Darcs.Patch.Patchy ( Invert, Commute )
   61 import Darcs.Ordered ( FL(..), RL(..), MyEq, unsafeCompare,
   62                              (:>)(..), (:\/:)(..), (:/\:)(..),
   63                              zipWithFL, mapFL_FL, mapFL,
   64                              (+>+), reverseRL, unsafeCoerceP )
   65 
   66 
   67 newtype Tag = TG Integer deriving ( Num, Show, Eq, Ord, Enum )
   68 data TaggedPatch p C(x y) = TP Tag (p C(x y))
   69 data PatchChoice p C(x y) = PC (TaggedPatch p C(x y)) Slot
   70 newtype PatchChoices p C(x y) = PCs (FL (PatchChoice p) C(x y))
   71 
   72 data Slot = InFirst | InMiddle | InLast
   73 
   74 invertTag :: Slot -> Slot
   75 invertTag InFirst = InLast
   76 invertTag InLast  = InFirst
   77 invertTag t = t
   78 
   79 tag :: TaggedPatch p C(x y) -> Tag
   80 tag (TP (TG t) _) = TG t
   81 
   82 tp_patch :: TaggedPatch p C(x y) -> p C(x y)
   83 tp_patch (TP _ p) = p
   84 
   85 liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b))
   86 liftTP f (TP t p) = TP t (f p)
   87 
   88 instance MyEq p => MyEq (TaggedPatch p) where
   89     unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2
   90 
   91 instance Invert p => Invert (TaggedPatch p) where
   92     invert = liftTP invert
   93     identity = TP (-1) identity
   94 
   95 instance Commute p => Commute (TaggedPatch p) where
   96     commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2)
   97                                         return (TP t2 p2' :> TP t1 p1')
   98     list_touched_files (TP _ p) = list_touched_files p
   99     merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of
  100                                      p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1'
  101 
  102 patch_choices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y)
  103 patch_choices = fst . patch_choices_tps
  104 
  105 patch_choices_tps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))
  106 patch_choices_tps ps = let tps = zipWithFL TP [1..] ps
  107                        in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps)
  108 
  109 make_everything_later :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)
  110 
  111 instance MyEq p => MyEq (PatchChoice p) where
  112     unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2
  113 
  114 instance Invert p => Invert (PatchChoice p) where
  115     invert (PC tp mf) = PC (invert tp) (invertTag mf)
  116     identity = PC identity InMiddle
  117 
  118 instance Commute p => Commute (PatchChoice p) where
  119     commute (PC t1 x1 :> PC t2 x2)
  120         = do t2' :> t1' <- commute (t1 :> t2)
  121              return (PC t2' x2 :> PC t1' x1)
  122     merge (PC t1 x1 :\/: PC t2 x2)
  123         = case merge (t1 :\/: t2) of
  124           t2' :/\: t1' -> PC t2' x2 :/\: PC t1' x1
  125     list_touched_files (PC t _) = list_touched_files t
  126 
  127 invertSeq :: (Invert p, Invert q) => (p :> q) C(x y) -> (q :> p) C(y x)
  128 invertSeq (x :> y) = (invert y :> invert x)
  129 
  130 separate_first_from_middle_last :: Patchy p => PatchChoices p C(x z)
  131                                 -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
  132 separate_first_from_middle_last (PCs e) = pull_only_firsts e
  133 
  134 separate_first_middle_from_last :: Patchy p => PatchChoices p C(x z)
  135                                 -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
  136 separate_first_middle_from_last (PCs e) = pull_firsts_middles e
  137 
  138 get_choices :: Patchy p => PatchChoices p C(x y)
  139             -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)
  140 get_choices (PCs e) = case pull_firsts e of
  141                       f :> ml -> case pull_firsts (invert ml) of
  142                                  l :> m -> f :> mapFL_FL pc2tp (invert m) :> invert l
  143   where pc2tp (PC tp _) = tp
  144 
  145 pull_firsts_middles :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
  146 pull_firsts_middles easyPC =
  147     let r = unsafePerformIO
  148           $ newIORef (error "pull_firsts_middles called badly")
  149         f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d)
  150         f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL)
  151         f acc (PC tp InLast:>:e) = f (tp:<:acc) e
  152         f acc (PC tp _:>:e) = case commuteWhatWeCanRL (acc :> tp) of
  153                               more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e
  154         xs = f NilRL easyPC
  155     in (xs :> unsafePerformIO (readIORef r))
  156 
  157 pull_only_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
  158 pull_only_firsts easyPC =
  159     let r = unsafePerformIO
  160           $ newIORef (error "pull_only_firsts called badly")
  161         f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d)
  162         f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL)
  163         f acc (PC tp InFirst:>:e) = case commuteWhatWeCanRL (acc :> tp) of
  164                                         more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e
  165         f acc (PC tp _:>:e) = f (tp:<:acc) e
  166         xs = f NilRL easyPC
  167     in (xs :> unsafePerformIO (readIORef r))
  168 
  169 {-
  170 pull_middles_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p])
  171 pull_middles_lasts easyPC =
  172     let r = unsafePerformIO
  173           $ newIORef (error "pull_middles_lasts called badly")
  174         f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` []
  175         f acc (PC tp (Just True):e) = f (tp:acc) e
  176         f acc (PC (TP t p) _:e) = case commute_up_list p acc of
  177                                   (acc', p') -> TP t p':f acc' e
  178         xs = f [] easyPC
  179     in (xs, unsafePerformIO (readIORef r))
  180 -}
  181 
  182 --pull_only_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p])
  183 --pull_only_lasts easyPC =
  184 --    let r = unsafePerformIO
  185 --          $ newIORef (error "pull_only_lasts called badly")
  186 --        f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` []
  187 --        f acc (PC (TP t p) (Just False):e) = case commute_up_list p acc of
  188 --                                             (acc', p') -> TP t p':f acc' e
  189 --        f acc (PC tp _:e) = f (tp:acc) e
  190 --        xs = f [] easyPC
  191 --    in (xs, unsafePerformIO (readIORef r))
  192 
  193 pull_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :>  FL (PatchChoice p)) C(x z)
  194 pull_firsts e = case pull_first e of
  195                 Nothing -> (NilFL :> e)
  196                 Just (p:>e') -> case pull_firsts e' of
  197                                 (ps:>e'') -> (p:>:ps :> e'')
  198 
  199 pull_lasts :: Patchy p => FL (PatchChoice p) C(x y) -> (FL (PatchChoice p) :> FL (TaggedPatch p)) C(x y)
  200 pull_lasts e = invertSeq $ pull_firsts $ invert e
  201 
  202 pull_first :: Patchy p => FL (PatchChoice p) C(x z) -> Maybe ((TaggedPatch p :> FL (PatchChoice p)) C(x z))
  203 pull_first NilFL = Nothing
  204 pull_first (PC tp InFirst:>:e) = Just (tp :> e)
  205 pull_first (PC (TP t p) InLast:>:e) =
  206     case pull_first e of
  207     Just (TP t2 p2 :> e') ->
  208         case commute (p:>p2) of
  209         Just (p2':>p') -> Just (TP t2 p2' :> PC (TP t p') InLast:>:e')
  210         Nothing -> error "Aaack fixme!"
  211     Nothing -> Nothing
  212 pull_first (PC tp@(TP t p) InMiddle:>:e) =
  213     case pull_first e of
  214     Just (TP t2 p2 :> e') ->
  215         case commute (p:>p2) of
  216         Just (p2':>p') -> Just (TP t2 p2' :> (PC (TP t p') InMiddle:>:e'))
  217         Nothing -> Just (tp :> PC (TP (-t2) p2) InFirst:>:e')
  218     Nothing -> Nothing
  219 
  220 patch_slot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot
  221 patch_slot tp (PCs e) = ipf e
  222   where ipf :: FL (PatchChoice p) C(u v) -> Slot
  223         ipf (PC a mb:>:e') | tag a == tag tp = mb
  224                            | otherwise = ipf e'
  225         -- actually, the following should be impossible, but this is a reasonable answer
  226         ipf NilFL = InLast
  227 
  228 set_simplys :: [Tag] -> Bool -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y)
  229 set_simplys ts b e = mapFL_FL ch e
  230     where ch (PC tp@(TP t _) _)
  231            | t `elem` ts = PC tp (if b then InFirst else InLast)
  232            | otherwise   = PC tp InMiddle
  233 
  234 
  235 m2ids :: (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> FL (PatchChoice p) C(a b) -> [Tag]
  236 m2ids m (PC tp@(TP t _) _:>:e)
  237  | m tp = t:m2ids m e
  238  | otherwise = m2ids m e
  239 m2ids _ NilFL = []
  240 
  241 force_matching_first :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)
  242                      -> PatchChoices p C(a b) -> PatchChoices p C(a b)
  243 force_matching_first m (PCs e) =
  244     let thd (PC (TP t _) _) = t
  245         xs = m2ids m e
  246         not_needed = case pull_firsts $ set_simplys xs True e of
  247                      _ :> rest -> mapFL thd rest
  248         ch pc@(PC tp@(TP t _) _)
  249          | t `elem` not_needed = pc
  250          | otherwise = PC tp InFirst
  251     in PCs $ mapFL_FL ch e
  252 
  253 force_firsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  254 force_firsts ps pc = force_matching_first ((`elem` ps) . tag) pc
  255 
  256 force_first :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  257 force_first p pc = force_matching_first ((== p) . tag) pc
  258 
  259 select_all_middles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  260 select_all_middles b (PCs e) = PCs (mapFL_FL f e)
  261     where f (PC tp InMiddle) = PC tp (if b then InLast else InFirst)
  262           f pc = pc
  263 
  264 reverse_pc :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(y x)
  265 reverse_pc (PCs e) = PCs $ invert e
  266 
  267 force_matching_last :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)
  268                     -> PatchChoices p C(a b) -> PatchChoices p C(a b)
  269 force_matching_last m (PCs e) =
  270     let thd (PC (TP t _) _) = t
  271         xs = m2ids m e
  272         not_needed = case pull_lasts $ set_simplys xs False e of
  273                      rest :> _ -> mapFL thd rest
  274         ch pc@(PC tp@(TP t _) _)
  275          | t `elem` not_needed = pc
  276          | otherwise = PC tp InLast
  277     in PCs $ mapFL_FL ch e
  278 
  279 force_last :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  280 force_last p pc = reverse_pc $ force_first p $ reverse_pc pc
  281 
  282 force_lasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  283 force_lasts ps pc = reverse_pc $ force_firsts ps $ reverse_pc pc
  284 
  285 make_uncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  286 make_uncertain t (PCs e) = PCs $ mapFL_FL ch e
  287     where ch pc@(PC x _) = if t == tag x then PC x InMiddle else pc
  288 
  289 make_everything_later (PCs e) = PCs $ mapFL_FL ch e
  290     where ch (PC tp InMiddle) = PC tp InLast
  291           ch (PC tp InFirst)  = PC tp InMiddle
  292           ch x = x