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