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

module Darcs.Patch.TouchesFiles
    ( lookTouch
    , chooseTouching
    , deselectNotTouching
    , selectNotTouching
    ) where

import Darcs.Prelude

import Data.List ( nub )

import Darcs.Patch.Apply
       (Apply, ApplyState, applyToPaths)
import Darcs.Patch.Choices
       (PatchChoices, Label, LabelledPatch, patchChoices, label,
        getChoices, forceFirsts, forceLasts, unLabel)
import Darcs.Patch.Commute (Commute)
import Darcs.Patch.Inspect (PatchInspect)
import Darcs.Patch.Witnesses.Ordered
       (FL(..), (:>)(..), mapFL_FL, (+>+))
import Darcs.Patch.Witnesses.Sealed (Sealed, seal)

import Darcs.Util.Path (AnchoredPath, isPrefix)
import Darcs.Util.Tree (Tree)

labelTouching
  :: (Apply p, PatchInspect p, ApplyState p ~ Tree)
  => Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching :: Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching Bool
_ [AnchoredPath]
_ FL (LabelledPatch p) wX wY
NilFL = []
labelTouching Bool
wantTouching [AnchoredPath]
fs (LabelledPatch p wX wY
lp :>: FL (LabelledPatch p) wY wY
lps) =
  case [AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
[AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])
lookTouchOnlyEffect [AnchoredPath]
fs (LabelledPatch p wX wY -> p wX wY
forall (p :: * -> * -> *) wX wY. LabelledPatch p wX wY -> p wX wY
unLabel LabelledPatch p wX wY
lp) of
    (Bool
doesTouch, [AnchoredPath]
fs') ->
      let rest :: [Label]
rest = Bool -> [AnchoredPath] -> FL (LabelledPatch p) wY wY -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching Bool
wantTouching [AnchoredPath]
fs' FL (LabelledPatch p) wY wY
lps
      in (if Bool
doesTouch Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
wantTouching
            then (LabelledPatch p wX wY -> Label
forall (p :: * -> * -> *) wX wY. LabelledPatch p wX wY -> Label
label LabelledPatch p wX wY
lp Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
:)
            else [Label] -> [Label]
forall a. a -> a
id)
           [Label]
rest

labelNotTouchingFM
  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
  => [AnchoredPath] -> PatchChoices p wX wY -> [Label]
labelNotTouchingFM :: [AnchoredPath] -> PatchChoices p wX wY -> [Label]
labelNotTouchingFM [AnchoredPath]
paths PatchChoices p wX wY
pc =
  case PatchChoices p wX wY
-> (:>)
     (FL (LabelledPatch p))
     (FL (LabelledPatch p) :> FL (LabelledPatch p))
     wX
     wY
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchChoices p wX wY
-> (:>)
     (FL (LabelledPatch p))
     (FL (LabelledPatch p) :> FL (LabelledPatch p))
     wX
     wY
getChoices PatchChoices p wX wY
pc of
    FL (LabelledPatch p) wX wZ
fc :> FL (LabelledPatch p) wZ wZ
mc :> FL (LabelledPatch p) wZ wY
_ -> Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wZ -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching Bool
False [AnchoredPath]
paths (FL (LabelledPatch p) wX wZ
fc FL (LabelledPatch p) wX wZ
-> FL (LabelledPatch p) wZ wZ -> FL (LabelledPatch p) wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (LabelledPatch p) wZ wZ
mc)

selectTouching
  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY
selectTouching :: Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
selectTouching Maybe [AnchoredPath]
Nothing PatchChoices p wX wY
pc = PatchChoices p wX wY
pc
selectTouching (Just [AnchoredPath]
paths) PatchChoices p wX wY
pc = [Label] -> PatchChoices p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wA wB.
Commute p =>
[Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
forceFirsts [Label]
xs PatchChoices p wX wY
pc
  where
    xs :: [Label]
xs =
      case PatchChoices p wX wY
-> (:>)
     (FL (LabelledPatch p))
     (FL (LabelledPatch p) :> FL (LabelledPatch p))
     wX
     wY
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchChoices p wX wY
-> (:>)
     (FL (LabelledPatch p))
     (FL (LabelledPatch p) :> FL (LabelledPatch p))
     wX
     wY
getChoices PatchChoices p wX wY
pc of
        FL (LabelledPatch p) wX wZ
_ :> FL (LabelledPatch p) wZ wZ
mc :> FL (LabelledPatch p) wZ wY
lc -> Bool -> [AnchoredPath] -> FL (LabelledPatch p) wZ wY -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]
labelTouching Bool
True [AnchoredPath]
paths (FL (LabelledPatch p) wZ wZ
mc FL (LabelledPatch p) wZ wZ
-> FL (LabelledPatch p) wZ wY -> FL (LabelledPatch p) wZ wY
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (LabelledPatch p) wZ wY
lc)

deselectNotTouching
  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY
deselectNotTouching :: Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
deselectNotTouching Maybe [AnchoredPath]
Nothing PatchChoices p wX wY
pc = PatchChoices p wX wY
pc
deselectNotTouching (Just [AnchoredPath]
paths) PatchChoices p wX wY
pc =
  [Label] -> PatchChoices p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wA wB.
Commute p =>
[Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
forceLasts ([AnchoredPath] -> PatchChoices p wX wY -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
[AnchoredPath] -> PatchChoices p wX wY -> [Label]
labelNotTouchingFM [AnchoredPath]
paths PatchChoices p wX wY
pc) PatchChoices p wX wY
pc

selectNotTouching
  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY
selectNotTouching :: Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
selectNotTouching Maybe [AnchoredPath]
Nothing PatchChoices p wX wY
pc = PatchChoices p wX wY
pc
selectNotTouching (Just [AnchoredPath]
paths) PatchChoices p wX wY
pc = [Label] -> PatchChoices p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wA wB.
Commute p =>
[Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
forceFirsts ([AnchoredPath] -> PatchChoices p wX wY -> [Label]
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
[AnchoredPath] -> PatchChoices p wX wY -> [Label]
labelNotTouchingFM [AnchoredPath]
paths PatchChoices p wX wY
pc) PatchChoices p wX wY
pc

chooseTouching
  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)
  => Maybe [AnchoredPath] -> FL p wX wY -> Sealed (FL p wX)
chooseTouching :: Maybe [AnchoredPath] -> FL p wX wY -> Sealed (FL p wX)
chooseTouching Maybe [AnchoredPath]
Nothing FL p wX wY
p = FL p wX wY -> Sealed (FL p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL p wX wY
p
chooseTouching Maybe [AnchoredPath]
paths FL p wX wY
p =
  case PatchChoices p wX wY
-> (:>)
     (FL (LabelledPatch p))
     (FL (LabelledPatch p) :> FL (LabelledPatch p))
     wX
     wY
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchChoices p wX wY
-> (:>)
     (FL (LabelledPatch p))
     (FL (LabelledPatch p) :> FL (LabelledPatch p))
     wX
     wY
getChoices (PatchChoices p wX wY
 -> (:>)
      (FL (LabelledPatch p))
      (FL (LabelledPatch p) :> FL (LabelledPatch p))
      wX
      wY)
-> PatchChoices p wX wY
-> (:>)
     (FL (LabelledPatch p))
     (FL (LabelledPatch p) :> FL (LabelledPatch p))
     wX
     wY
forall a b. (a -> b) -> a -> b
$ Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [AnchoredPath]
-> PatchChoices p wX wY -> PatchChoices p wX wY
selectTouching Maybe [AnchoredPath]
paths (PatchChoices p wX wY -> PatchChoices p wX wY)
-> PatchChoices p wX wY -> PatchChoices p wX wY
forall a b. (a -> b) -> a -> b
$ FL p wX wY -> PatchChoices p wX wY
forall (p :: * -> * -> *) wX wY. FL p wX wY -> PatchChoices p wX wY
patchChoices FL p wX wY
p of
    FL (LabelledPatch p) wX wZ
fc :> FL (LabelledPatch p) wZ wZ
_ :> FL (LabelledPatch p) wZ wY
_ -> FL p wX wZ -> Sealed (FL p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (FL p wX wZ -> Sealed (FL p wX)) -> FL p wX wZ -> Sealed (FL p wX)
forall a b. (a -> b) -> a -> b
$ (forall wW wY. LabelledPatch p wW wY -> p wW wY)
-> FL (LabelledPatch p) wX wZ -> FL p wX wZ
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY. LabelledPatch p wW wY -> p wW wY
forall (p :: * -> * -> *) wX wY. LabelledPatch p wX wY -> p wX wY
unLabel FL (LabelledPatch p) wX wZ
fc

lookTouchOnlyEffect
  :: (Apply p, ApplyState p ~ Tree)
  => [AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])
lookTouchOnlyEffect :: [AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])
lookTouchOnlyEffect [AnchoredPath]
fs p wX wY
p = (Bool
wasTouched, [AnchoredPath]
fs')
  where
    (Bool
wasTouched, [AnchoredPath]
_, [AnchoredPath]
fs', [(AnchoredPath, AnchoredPath)]
_) = Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> p wX wY
-> (Bool, [AnchoredPath], [AnchoredPath],
    [(AnchoredPath, AnchoredPath)])
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> p wX wY
-> (Bool, [AnchoredPath], [AnchoredPath],
    [(AnchoredPath, AnchoredPath)])
lookTouch Maybe [(AnchoredPath, AnchoredPath)]
forall a. Maybe a
Nothing [AnchoredPath]
fs p wX wY
p

lookTouch
  :: (Apply p, ApplyState p ~ Tree)
  => Maybe [(AnchoredPath, AnchoredPath)]
  -> [AnchoredPath]
  -> p wX wY
  -> (Bool, [AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
lookTouch :: Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> p wX wY
-> (Bool, [AnchoredPath], [AnchoredPath],
    [(AnchoredPath, AnchoredPath)])
lookTouch Maybe [(AnchoredPath, AnchoredPath)]
renames [AnchoredPath]
fs p wX wY
p = (Bool
anyTouched, [AnchoredPath]
touchedFs, [AnchoredPath]
fs', [(AnchoredPath, AnchoredPath)]
renames')
  where
    touchedFs :: [AnchoredPath]
touchedFs = [AnchoredPath] -> [AnchoredPath]
forall a. Eq a => [a] -> [a]
nub ([AnchoredPath] -> [AnchoredPath])
-> ([AnchoredPath] -> [AnchoredPath])
-> [AnchoredPath]
-> [AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredPath -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AnchoredPath -> [AnchoredPath]
fsAffectedBy ([AnchoredPath] -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall a b. (a -> b) -> a -> b
$ [AnchoredPath]
affected
    fsAffectedBy :: AnchoredPath -> [AnchoredPath]
fsAffectedBy AnchoredPath
af = (AnchoredPath -> Bool) -> [AnchoredPath] -> [AnchoredPath]
forall a. (a -> Bool) -> [a] -> [a]
filter (AnchoredPath -> AnchoredPath -> Bool
affectedBy AnchoredPath
af) [AnchoredPath]
fs
    anyTouched :: Bool
anyTouched = [AnchoredPath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnchoredPath]
touchedFs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    affectedBy :: AnchoredPath -> AnchoredPath -> Bool
    AnchoredPath
touched affectedBy :: AnchoredPath -> AnchoredPath -> Bool
`affectedBy` AnchoredPath
f =
      AnchoredPath
touched AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
f Bool -> Bool -> Bool
|| AnchoredPath
f AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
touched
    ([AnchoredPath]
affected, [AnchoredPath]
fs', [(AnchoredPath, AnchoredPath)]
renames') = p wX wY
-> Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY
-> Maybe [(AnchoredPath, AnchoredPath)]
-> [AnchoredPath]
-> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])
applyToPaths p wX wY
p Maybe [(AnchoredPath, AnchoredPath)]
renames [AnchoredPath]
fs