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

-- | The purpose of this module is to deal with many of the common
-- cases that come up when choosing a subset of a group of patches.
--
-- The idea is to divide a sequence of candidate patches into an initial
-- section named 'InFirst', a final section named 'InLast', and between them a
-- third section of not yet decided patches named 'InMiddle'. The reason for the
-- neutral terminology 'InFirst', 'InMiddle', and 'InLast', is that which of 'InFirst'
-- and 'InLast' counts as @selected@ or @deselected@ depends on
-- what we want to achive, that is, on the command and its options.
-- See "Darcs.UI.SelectChanges" for examples of how to use the functions from
-- this module.
--
-- Obviously if there are dependencies between the patches that will put a
-- constraint on how you can choose to divide them up. Unless stated otherwise,
-- functions that move patches from one section to another pull all dependent
-- patches with them.
--
-- Internally, we don't necessarily reorder patches immediately, but merely
-- tag them with the desired status, and thus postpone the actual commutation.
-- This saves a lot of unnecessary work, especially when choices are made
-- interactively, where the user can revise earlier decisions.
module Darcs.Patch.Choices
    ( -- * Choosing patches
      PatchChoices
    , Slot(..)
      -- ** Constructing
    , patchChoices
    , mkPatchChoices
      -- ** Querying
    , patchSlot
    , getChoices
    , separateFirstMiddleFromLast
    , separateFirstFromMiddleLast
      -- ** Forcing patches into a given 'Slot'
    , forceMatchingFirst
    , forceFirsts
    , forceFirst
    , forceMatchingLast
    , forceLasts
    , forceLast
    , forceMiddle
    , makeEverythingSooner
    , makeEverythingLater
      -- ** Operations on 'InMiddle' patches
    , selectAllMiddles
    , refineChoices
      -- ** Substitution
    , substitute
      -- * Labelling patches
    , LabelledPatch
    , Label
    , label
    , unLabel
    , labelPatches
    , getLabelInt
    ) where

import Darcs.Prelude

import Darcs.Patch.Invert ( Invert, invert )
import Darcs.Patch.Commute ( Commute, commute, commuteRL )
import Darcs.Patch.Inspect ( PatchInspect, listTouchedFiles, hunkMatches )
import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), RL(..)
    , (:>)(..), (:||:)(..)
    , zipWithFL, mapFL_FL, concatFL
    , (+>+), reverseRL, anyFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )

-- | 'Label' @mp i@ acts as a temporary identifier to help us keep track of patches
--   during the selection process.  These are useful for finding patches that
--   may have moved around during patch selection (being pushed forwards or
--   backwards as dependencies arise).
--
--   The identifier is implemented as a tuple @Label mp i@. The @i@ is an
--   integer, expected to be unique within the patches being
--   scrutinised.  The @mp@ is motivated by patch splitting; it
--   provides a convenient way to generate a new identifier from the patch
--   being split.  For example, if we split a patch identified as @Label Nothing
--   5@, the resulting sub-patches could be identified as
--   @Label (Just (Label Nothing 5))1@, @Label (Just (Label Nothing 5)) 2@, etc.
--
--   IOW, 'Label' is a non-empty, reversed list of 'Int's.
data Label = Label (Maybe Label) Int deriving Eq

-- | A patch with a 'Label' attached to it.
data LabelledPatch p wX wY = LP Label (p wX wY)

-- | This internal type tags a 'LabelledPatch' with a 'Bool', to distinguish
-- 'InMiddle' from 'InLast' patches.
data PatchChoice p wX wY = PC
  { pcPatch :: (LabelledPatch p wX wY) -- ^ the 'LabelledPatch' in question
  , _pcIsLast :: Bool                  -- ^ 'False' = 'InMiddle', 'True' = 'InLast'
  }

-- | Internal function to tag a 'LabelledPatch' as 'InMiddle' or 'InLast'.
pcSetLast :: Bool -> LabelledPatch p wX wY -> PatchChoice p wX wY
pcSetLast = flip PC

-- TODO pcsFirsts should be an 'RL', not an 'FL'.
-- | A sequence of 'LabelledPatch'es where each patch is either
-- 'InFirst', 'InMiddle', or 'InLast'. The representation is
-- optimized for the case where we start chosing patches from the left
-- of the sequence: patches that are 'InFirst' are commuted to the head
-- immediately, but patches that are 'InMiddle' or 'InLast' are mixed
-- together; when a patch is marked 'InLast', its dependencies are
-- not updated until we retrieve the final result.
data PatchChoices p wX wY where
  PCs :: { pcsFirsts :: FL (LabelledPatch p) wX wM
         , pcsMiddleLasts :: FL (PatchChoice p) wM wY}
      -> PatchChoices p wX wY

-- | See module documentation for "Darcs.Patch.Choices".
data Slot = InFirst | InMiddle | InLast

label :: LabelledPatch p wX wY -> Label
label (LP tg _) = tg

getLabelInt :: Label -> Int
getLabelInt (Label _ i) = i

unLabel :: LabelledPatch p wX wY -> p wX wY
unLabel (LP _ p) = p

-- This is dangerous if two patches from different labelled series are compared
-- ideally Label (and hence LabelledPatch/PatchChoices) would have a witness type
-- to represent the originally labelled sequence.
compareLabels :: LabelledPatch p wA wB -> LabelledPatch p wC wD -> EqCheck (wA, wB) (wC, wD)
compareLabels (LP l1 _) (LP l2 _) = if l1 == l2 then unsafeCoerceP IsEq else NotEq

instance Invert p => Invert (LabelledPatch p) where
  invert (LP t p) = LP t (invert p)

instance Commute p => Commute (LabelledPatch p) where
  commute (LP l1 p1 :> LP l2 p2) = do
    p2' :> p1' <- commute (p1 :> p2)
    return (LP l2 p2' :> LP l1 p1')

instance PatchInspect p => PatchInspect (LabelledPatch p) where
  listTouchedFiles = listTouchedFiles . unLabel
  hunkMatches f = hunkMatches f . unLabel

instance Commute p => Commute (PatchChoice p) where
  commute (PC p1 c1 :> PC p2 c2) = do
    p2' :> p1' <- commute (p1 :> p2)
    return (PC p2' c2 :> PC p1' c1)

instance PatchInspect p => PatchInspect (PatchChoice p) where
  listTouchedFiles = listTouchedFiles . pcPatch
  hunkMatches f = hunkMatches f . pcPatch

-- | Create a 'PatchChoices' from a sequence of patches, so that
-- all patches are initially 'InMiddle'.
patchChoices :: FL p wX wY -> PatchChoices p wX wY
patchChoices = mkPatchChoices . labelPatches Nothing

-- | Label a sequence of patches, maybe using the given parent label.
labelPatches :: Maybe Label -> FL p wX wY -> FL (LabelledPatch p) wX wY
labelPatches tg ps = zipWithFL LP (map (Label tg) [1..]) ps

-- | Create a 'PatchChoices' from an already labelled sequence of patches,
-- so that all patches are initially 'InMiddle'.
mkPatchChoices :: FL (LabelledPatch p) wX wY -> PatchChoices p wX wY
mkPatchChoices = PCs NilFL . mapFL_FL (pcSetLast False)


-- | Like 'getChoices' but lumps together 'InMiddle' and 'InLast' patches.
-- This is more efficient than using 'getChoices' and then catenating 'InMiddle'
-- and 'InLast' sections because we have to commute less.
-- (This is what 'PatchChoices' are optimized for.)
--
-- prop> separateFirstFromMiddleLast c == case getChoices c of f:>m:>l -> f:>m+>+l
separateFirstFromMiddleLast :: PatchChoices p wX wZ
                            -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ
separateFirstFromMiddleLast (PCs f ml) = f :> mapFL_FL pcPatch ml

-- | Like 'getChoices' but lumps together 'InFirst' and 'InMiddle' patches.
--
-- prop> separateFirstMiddleFromLast c == case getChoices c of f:>m:>l -> f+>+m:>l
separateFirstMiddleFromLast :: Commute p
                            => PatchChoices p wX wZ
                            -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ
separateFirstMiddleFromLast (PCs f l) =
  case pushLasts l of
    (m :> l') -> f +>+ m :> l'

-- | Retrieve the resulting sections from a 'PatchChoice'.  The result is a
-- triple @first:>middle:>last@, such that all patches in @first@ are
-- 'InFirst', all patches in @middle@ are 'InMiddle', and all patches in @last@
-- are 'InLast'.
getChoices :: Commute p
           => PatchChoices p wX wY
           -> (FL (LabelledPatch p) :> FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY
getChoices (PCs f ml) =
  case pushLasts ml of
    (m :> l') -> f :> m :> l'

-- | Internal function to commute patches in the common 'pcsMiddleLasts' segment
-- so that all 'InLast' patches are behind 'InMiddle' ones. Patches 'InMiddle'
-- that depend on any 'InLast' are promoted to 'InLast'.
pushLasts :: Commute p
          => FL (PatchChoice p) wX wY
          -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY
pushLasts NilFL = NilFL :> NilFL
pushLasts (PC lp False :>: pcs) =
  case pushLasts pcs of
       (m :> l) -> (lp :>: m) :> l
pushLasts (PC lp True :>: pcs) =
  case pushLasts pcs of
    (m :> l) ->
      case commuteWhatWeCanFL (lp :> m) of
        (m' :> lp' :> deps) -> m' :> (lp' :>: deps +>+ l)

-- TODO for the way we use this function it is too restrictive IMO: it does not
-- allow the user to select anything that doesn't match the pre-filters.
-- | Use the given monadic 'PatchChoices' transformer on the 'InMiddle' section
-- of a 'PatchChoices', then fold the result back into the original 'PatchChoices'.
refineChoices :: (Commute p, Monad m)
              => (forall wU wV . FL (LabelledPatch p) wU wV ->
                  PatchChoices p wU wV -> m (PatchChoices p wU wV))
              -> PatchChoices p wX wY -> m (PatchChoices p wX wY)
refineChoices act ps =
  case getChoices ps of
    (f :> m :> l) -> do
      (PCs f' l') <- act m (mkPatchChoices m)
      return . PCs (f +>+ f') $ l' +>+ mapFL_FL (pcSetLast True) l

-- | Given a 'LabelledPatch' determine to which section of the given
-- 'PatchChoices' it belongs. This is not trivial to compute, since a patch
-- tagged as 'InMiddle' may be forced to actually be 'InLast' by dependencies. We
-- return a possibly re-ordered 'PatchChoices' so as not to waste the
-- commutation effort.
patchSlot :: forall p wA wB wX wY. Commute p
          => LabelledPatch p wA wB
          -> PatchChoices p wX wY
          -> (Slot, PatchChoices p wX wY)
patchSlot (LP t _) pc@(PCs f ml)
  | foundIn f = (InFirst, pc)
  | otherwise = psLast f NilRL NilRL ml
  where
    foundIn = anyFL ((== t) . label)
    psLast :: forall wM wC wL .
             FL (LabelledPatch p) wX wM ->
             RL (LabelledPatch p) wM wC ->
             RL (LabelledPatch p) wC wL ->
             FL (PatchChoice p) wL wY ->
             (Slot, PatchChoices p wX wY)
    psLast firsts middles bubble (PC lp True :>: ls)
      | label lp == t = (InLast
                      , PCs { pcsFirsts = firsts
                            , pcsMiddleLasts = settleM middles
                                         +>+ settleB bubble
                                         +>+ PC lp True :>: ls})
    psLast firsts middles bubble (PC lp False :>: ls)
      | label lp == t =
        case commuteRL (bubble :> lp) of
        Just (lp' :> bubble') -> (InMiddle,
                                 PCs { pcsFirsts = firsts
                                     , pcsMiddleLasts = settleM middles
                                                  +>+ PC lp' False
                                                  :>: settleB bubble'
                                                  +>+ ls})
        Nothing -> (InLast,
                   PCs { pcsFirsts = firsts
                       , pcsMiddleLasts = settleM middles
                                    +>+ settleB bubble
                                    +>+ PC lp True
                                    :>: ls})
    psLast firsts middles bubble (PC lp True :>: ls) =
      psLast firsts middles (bubble :<: lp) ls
    psLast firsts middles bubble (PC lp False :>: ls) =
      case commuteRL (bubble :> lp) of
        Just (lp' :> bubble') -> psLast firsts (middles :<: lp') bubble' ls
        Nothing -> psLast firsts middles (bubble :<: lp) ls
    psLast _ _ _ NilFL = error "impossible case"
    settleM middles = mapFL_FL (\lp -> PC lp False) $ reverseRL middles
    settleB bubble = mapFL_FL (\lp -> PC lp True) $ reverseRL bubble

-- | Force all patches matching the given predicate to be 'InFirst',
-- pulling any dependencies with them. This even forces any patches
-- that were already tagged 'InLast'.
forceMatchingFirst :: forall p wA wB. Commute p
                   => ( forall wX wY . LabelledPatch p wX wY -> Bool)
                   -> PatchChoices p wA wB
                   -> PatchChoices p wA wB
forceMatchingFirst pred (PCs f0 ml) = fmfLasts f0 NilRL ml
    where
      fmfLasts :: FL (LabelledPatch p) wA wM
                 -> RL (PatchChoice p) wM wN
                 -> FL (PatchChoice p) wN wB
                 -> PatchChoices p wA wB
      fmfLasts f l1 (a :>: l2)
          | pred_pc a =
            case commuteWhatWeCanRL (l1 :> a) of
              (deps :> a' :> l1') ->
                let
                  f' = f +>+ mapFL_FL pcPatch (reverseRL deps) +>+ (pcPatch a' :>: NilFL)
                in fmfLasts f' l1' l2
      fmfLasts f l1 (a :>: l2) = fmfLasts f (l1 :<: a) l2
      fmfLasts f l1 NilFL = PCs { pcsFirsts = f
                                , pcsMiddleLasts = reverseRL l1 }
      pred_pc :: forall wX wY . PatchChoice p wX wY -> Bool
      pred_pc (PC lp _) = pred lp

-- | Force all patches labelled with one of the given labels to be 'InFirst',
-- pulling any dependencies with them. This even forces any patches
-- that were already tagged 'InLast'.
forceFirsts :: Commute p
            => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
forceFirsts ps = forceMatchingFirst ((`elem` ps) . label)

-- | Force a single patch labelled with the given label to be 'InFirst',
-- pulling any dependencies with them. This even forces any patches
-- that were already tagged 'InLast'.
forceFirst :: Commute p
           => Label -> PatchChoices p wA wB -> PatchChoices p wA wB
forceFirst p = forceMatchingFirst ((== p) . label)
--TODO: stop after having seen the patch we want to force first

-- | Make all 'InMiddle' patches either 'InFirst' or 'InLast'. This does *not*
-- modify any patches that are already determined to be 'InLast' by
-- dependencies.
selectAllMiddles :: forall p wX wY. Commute p
                 => Bool -> PatchChoices p wX wY -> PatchChoices p wX wY
selectAllMiddles True (PCs f l) = PCs f (mapFL_FL g l)
    where g (PC lp _) = PC lp True
selectAllMiddles False (PCs f l) = samf f NilRL NilRL l
  where
    samf :: forall wM1 wM2 wM3 .
           FL (LabelledPatch p) wX wM1 ->
           RL (LabelledPatch p) wM1 wM2 ->
           RL (PatchChoice p) wM2 wM3 ->
           FL (PatchChoice p) wM3 wY ->
           PatchChoices p wX wY
    samf f1 f2 l1 (pc@(PC lp False) :>: l2) =
      case commuteRL (l1 :> pc) of
        Nothing -> samf f1 f2 (l1 :<: PC lp True) l2
        Just ((PC lp' _) :> l1') -> samf f1 (f2 :<: lp') l1' l2
    samf f1 f2 l1 (PC lp True :>: l2) = samf f1 f2 (l1 :<: PC lp True) l2
    samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1)

-- | Similar to 'forceMatchingFirst' only that patches are forced to be
-- 'InLast' regardless of their previous status.
forceMatchingLast :: Commute p => (forall wX wY . LabelledPatch p wX wY -> Bool)
                  -> PatchChoices p wA wB
                  -> PatchChoices p wA wB
forceMatchingLast pred (PCs f ml) =
  forceMatchingMiddleOrLast pred True NilRL f ml

-- | Internal function working directly on the constituent parts of a
-- 'PatchChoices' and taking an accumulating 'RL' to build up a new 'InFirst'
-- section.  It forces patches to be 'InMiddle' or 'InLast', depending
-- on the 'Bool' parameter ('True' means 'InLast', 'False' means 'InMiddle').
-- It does this regardless of the previous status of patches and also pulls
-- any dependent patches with it.
forceMatchingMiddleOrLast
  :: forall p wA wB wM1 wM2 . Commute p
  => (forall wX wY . LabelledPatch p wX wY -> Bool)
  -> Bool
  -> RL (LabelledPatch p) wA wM1  -- ^ accumulator for 'InFirst' patches
  -> FL (LabelledPatch p) wM1 wM2 -- ^ original 'InFirst' section
  -> FL (PatchChoice p) wM2 wB    -- ^ original 'InMiddle' and 'InLast' section
  -> PatchChoices p wA wB
forceMatchingMiddleOrLast pred b f1 (a :>: f2) ml
  | pred a =
    case commuteWhatWeCanFL (a :> f2) of
      (f2' :> a' :> deps) ->
        let
          ml' = mapFL_FL (pcSetLast b) (a' :>: deps) +>+ ml
        in
        forceMatchingMiddleOrLast pred b f1 f2' ml'
forceMatchingMiddleOrLast pred b f1 (a :>: f2) ml =
  forceMatchingMiddleOrLast pred b (f1 :<: a) f2 ml
forceMatchingMiddleOrLast pred b f1 NilFL ml =
  PCs { pcsFirsts = reverseRL f1
      , pcsMiddleLasts = mapFL_FL choose ml
      }
  where
    choose (PC lp c) = (PC lp (if pred lp then b else c) )

-- | Force all patches labelled with one of the given labels to be 'InLast',
-- pulling any dependencies with them. This even forces any patches
-- that were previously tagged 'InFirst'.
forceLasts :: Commute p
           => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
forceLasts ps = forceMatchingLast ((`elem` ps) . label)

-- | Force a single patch labelled with the given label to be 'InLast',
-- pulling any dependencies with them, regardless of their previous status.
forceLast :: Commute p
          => Label -> PatchChoices p wA wB -> PatchChoices p wA wB
forceLast p = forceMatchingLast ((== p) . label)

-- | Force a patch with the given 'Label' to be 'InMiddle',
-- pulling any dependencies with it, regardless of their previous status.
forceMiddle :: Commute p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB
forceMiddle t (PCs f l) = forceMatchingMiddleOrLast ((== t) . label) False NilRL f l

-- | Turn 'InFirst' patches into 'InMiddle' ones and 'InMiddle' into 'InLast' ones.
makeEverythingLater :: PatchChoices p wX wY -> PatchChoices p wX wY
makeEverythingLater (PCs f ml) =
  let m = mapFL_FL (pcSetLast False) f
      ml' = mapFL_FL (\(PC lp _) -> PC lp True) ml
  in PCs NilFL $ m +>+ ml'

-- | Turn 'InMiddle' patches into 'InFirst' and 'InLast' patches into 'InMiddle'.
-- Does *not* pull dependencies into 'InFirst', instead patches that
-- cannot be commuted past 'InLast' patches stay 'InMiddle'.
makeEverythingSooner :: forall p wX wY. Commute p
                     => PatchChoices p wX wY -> PatchChoices p wX wY
makeEverythingSooner (PCs f ml) =
  case mes NilRL NilRL ml
       of (m :> ml') ->
            PCs (f +>+ m) ml'
    where
      mes :: forall wM1 wM2 wM3 .
            RL (LabelledPatch p) wM1 wM2 ->
            RL (LabelledPatch p) wM2 wM3 ->
            FL (PatchChoice p) wM3 wY ->
            (FL (LabelledPatch p) :> FL (PatchChoice p)) wM1 wY
      mes middle bubble (PC lp True :>: mls) = mes middle (bubble :<: lp) mls
      mes middle bubble (PC lp False :>: mls) =
        case commuteRL (bubble :> lp) of
          Nothing -> mes middle (bubble :<: lp) mls
          Just (lp' :> bubble') -> mes (middle :<: lp') bubble' mls
      mes middle bubble NilFL =
        (reverseRL middle) :> mapFL_FL (\lp -> PC lp False) (reverseRL bubble)

-- | Substitute a single 'LabelledPatch' with an equivalent list of patches,
-- preserving its status as 'InFirst', 'InMiddle' or 'InLast').
-- The patch is looked up using equality of 'Label's.
substitute :: forall p wX wY .
              Sealed2 (LabelledPatch p :||: FL (LabelledPatch p))
           -> PatchChoices p wX wY
           -> PatchChoices p wX wY
substitute (Sealed2 (lp :||: new_lps)) (PCs f l) =
  PCs (concatFL $ mapFL_FL substLp f) (concatFL $ mapFL_FL substPc l)
   where
     substLp :: LabelledPatch p wA wB -> FL (LabelledPatch p) wA wB
     substLp lp'
       | IsEq <- compareLabels lp lp' = new_lps
       | otherwise = lp' :>: NilFL
     substPc :: PatchChoice p wA wB -> FL (PatchChoice p) wA wB
     substPc (PC lp' c)
       | IsEq <- compareLabels lp lp' = mapFL_FL (pcSetLast c) new_lps
       | otherwise = PC lp' c :>: NilFL