src/Darcs/Patch/Choices.lhs

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