src/Darcs/Patch/TouchesFiles.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 \begin{code}
  19 {-# OPTIONS_GHC -cpp #-}
  20 {-# LANGUAGE CPP #-}
  21
  22 #include "gadts.h"
  23
  24 module Darcs.Patch.TouchesFiles ( look_touch, choose_touching,
  25                       select_touching,
  26                       deselect_not_touching, select_not_touching,
  27                     ) where
  28 import Data.List ( sort )
  29
  30 import Darcs.Patch.Choices ( PatchChoices, Tag, TaggedPatch,
  31                              patch_choices, tag, get_choices,
  32                       force_firsts, force_lasts, tp_patch,
  33                     )
  34 import Darcs.Patch ( Patchy, apply_to_filepaths, list_touched_files )
  35 import Darcs.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) )
  36 import Darcs.Sealed ( Sealed, seal )
  37 \end{code}
  38
  39 \begin{code}
  40 select_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  41 select_touching [] pc = pc
  42 select_touching files pc = force_firsts xs pc
  43     where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]
  44           ct _ NilFL = []
  45           ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of
  46                              (True, fs') -> tag tp:ct fs' tps
  47                              (False, fs') -> ct fs' tps
  48           xs = case get_choices pc of
  49                _ :> mc :> lc -> ct (map fix files) (mc +>+ lc)
  50
  51 deselect_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  52 deselect_not_touching [] pc = pc
  53 deselect_not_touching files pc = force_lasts xs pc
  54     where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]
  55           ct _ NilFL = []
  56           ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of
  57                              (True, fs') -> ct fs' tps
  58                              (False, fs') -> tag tp:ct fs' tps
  59           xs = case get_choices pc of
  60                fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)
  61
  62 select_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
  63 select_not_touching [] pc = pc
  64 select_not_touching files pc = force_firsts xs pc
  65     where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]
  66           ct _ NilFL = []
  67           ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of
  68                              (True, fs') -> ct fs' tps
  69                              (False, fs') -> tag tp:ct fs' tps
  70           xs = case get_choices pc of
  71                fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)
  72
  73 fix :: FilePath -> FilePath
  74 fix f | take 1 (reverse f) == "/" = fix $ reverse $ drop 1 $ reverse f
  75 fix "" = "."
  76 fix "." = "."
  77 fix f = "./" ++ f
  78
  79 choose_touching :: Patchy p => [FilePath] -> FL p C(x y) -> Sealed (FL p C(x))
  80 choose_touching [] p = seal p
  81 choose_touching files p = case get_choices $ select_touching files $ patch_choices p of
  82                           fc :> _ :> _ -> seal $ mapFL_FL tp_patch fc
  83
  84 look_touch :: Patchy p => [FilePath] -> p C(x y) -> (Bool, [FilePath])
  85 look_touch fs p = (any (\tf -> any (affects tf) fs) (list_touched_files p)
  86                    || fs' /= fs, fs')
  87     where affects touched f | touched == f = True
  88           affects t f = case splitAt (length f) t of
  89                         (t', '/':_) -> t' == f
  90                         _ -> case splitAt (length t) f of
  91                              (f', '/':_) -> f' == t
  92                              _ -> False
  93           fs' = sort $ apply_to_filepaths p fs
  94 \end{code}