{-# LANGUAGE UndecidableInstances #-}
module Darcs.Patch.Rebase.Item
    ( RebaseItem(..)
    , simplifyPush, simplifyPushes
    , countToEdit
    ) where

import Prelude ()
import Darcs.Prelude

import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )
import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.FileHunk ( IsHunk(..) )
import Darcs.Patch.Format ( PatchListFormat(..) )
import Darcs.Patch.Named ( Named(..), commuterIdNamed )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Inspect ( PatchInspect(..) )
import Darcs.Patch.Read ( ReadPatch(..) )
import Darcs.Patch.Show ( ShowPatch(..) )
import Darcs.Patch.Prim
    ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL )
import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )
import Darcs.Patch.Rebase.Name
    ( RebaseName(..)
    , commutePrimName, commuteNamePrim
    , canonizeNamePair
    )
import Darcs.Patch.Repair ( Check(..) )
import Darcs.Patch.Show ( ShowPatchBasic(..) )
import Darcs.Patch.Summary ( plainSummaryPrim )
import Darcs.Patch.ReadMonads ( ParserM, lexString )
import Darcs.Patch.Witnesses.Eq
import Darcs.Patch.Witnesses.Ordered
import Darcs.Patch.Witnesses.Sealed
import Darcs.Patch.Witnesses.Show
    ( Show1(..), Show2(..), showsPrec2
    , ShowDict(ShowDictClass), appPrec
    )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import qualified Darcs.Util.Diff as D ( DiffAlgorithm )
import Darcs.Util.Printer ( vcat, blueText, ($$), (<+>) )

import Control.Applicative ( (<|>) )
import qualified Data.ByteString as B ( ByteString )
import qualified Data.ByteString.Char8 as BC ( pack )

-- |A single item in the rebase state consists of either
-- a patch that is being edited, or a fixup that adjusts
-- the context so that a subsequent patch that is being edited
-- \"makes sense\".
--
-- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of
-- the patch will typically be the name the patch had before
-- it was added to the rebase state; if it is moved back
-- into the repository it must be given a fresh name to account
-- for the fact that it will not necessarily have the same
-- dependencies as the original patch. This is typically
-- done by changing the @Ignore-This@ junk.
--
-- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch
-- is correct. Where possible, @Fixup@ changes are commuted
-- as far as possible into the rebase state, so any remaining
-- ones will typically cause a conflict when the @ToEdit@ patch
-- is moved back into the repository.
data RebaseItem p wX wY where
    ToEdit :: Named p wX wY -> RebaseItem p wX wY
    Fixup :: RebaseFixup p wX wY -> RebaseItem p wX wY

instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY) where
    showsPrec d (ToEdit p) =
        showParen (d > appPrec) $ showString "ToEdit " . showsPrec2 (appPrec + 1) p
    showsPrec d (Fixup p) =
        showParen (d > appPrec) $ showString "Fixup " . showsPrec2 (appPrec + 1) p

instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX) where
    showDict1 = ShowDictClass

instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p) where
    showDict2 = ShowDictClass

countToEdit :: FL (RebaseItem p) wX wY -> Int
countToEdit NilFL = 0
countToEdit (ToEdit _ :>: ps) = 1 + countToEdit ps
countToEdit (_ :>: ps) = countToEdit ps

-- |Given a list of rebase items, try to push a new fixup as far as possible into
-- the list as possible, using both commutation and coalescing. If the fixup
-- commutes past all the 'ToEdit' patches then it is dropped entirely.
simplifyPush :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
             => D.DiffAlgorithm -> RebaseFixup p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)

simplifyPush _ _f NilFL = Sealed NilFL

simplifyPush da (PrimFixup f1) (Fixup (PrimFixup f2) :>: ps)
 | IsEq <- isInverse = Sealed ps
 | otherwise
   = case commute (f1 :> f2) of
       Nothing -> Sealed (mapFL_FL (Fixup . PrimFixup) (canonizeFL da (f1 :>: f2 :>: NilFL)) +>+ ps)
       Just (f2' :> f1') -> mapSeal (Fixup (PrimFixup f2') :>:) (simplifyPush da (PrimFixup f1') ps)
  where isInverse = invert f1 =\/= f2

simplifyPush da (PrimFixup f) (Fixup (NameFixup n) :>: ps)
    = case commutePrimName (f :> n) of
        n' :> f' -> mapSeal (Fixup (NameFixup n') :>:) (simplifyPush da (PrimFixup f') ps)

simplifyPush da (PrimFixup f) (ToEdit e :>: ps)
   = case commuterIdNamed selfCommuter (fromPrim f :> e) of
       Nothing -> Sealed (Fixup (PrimFixup f) :>: ToEdit e :>: ps)
       Just (e' :> f') -> mapSeal (ToEdit e' :>:) (simplifyPushes da (mapFL_FL PrimFixup (effect f')) ps)

simplifyPush da (NameFixup n1) (Fixup (NameFixup n2) :>: ps)
 | IsEq <- isInverse = Sealed ps
 | otherwise
   = case commute (n1 :> n2) of
       Nothing -> Sealed (mapFL_FL (Fixup . NameFixup) (canonizeNamePair (n1 :> n2)) +>+ ps)
       Just (n2' :> n1') -> mapSeal (Fixup (NameFixup n2') :>:) (simplifyPush da (NameFixup n1') ps)
  where isInverse = invert n1 =\/= n2

simplifyPush da (NameFixup n) (Fixup (PrimFixup f) :>: ps) =
    case commuteNamePrim (n :> f) of
      f' :> n' -> mapSeal (Fixup (PrimFixup f') :>:) (simplifyPush da (NameFixup n') ps)

simplifyPush da (NameFixup (AddName an)) (p@(ToEdit (NamedP pn deps _)) :>: ps)
  | an == pn = impossible
  | an `elem` deps = Sealed (Fixup (NameFixup (AddName an)) :>: p :>: ps)
  | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (AddName an)) ps)
simplifyPush da (NameFixup (DelName dn)) (p@(ToEdit (NamedP pn deps _)) :>: ps)
  -- this case can arise if a patch is suspended then a fresh copy is pulled from another repo
  | dn == pn = Sealed (Fixup (NameFixup (DelName dn)) :>: p :>: ps)
  | dn `elem` deps = impossible
  | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (DelName dn)) ps)
simplifyPush da (NameFixup (Rename old new)) (p@(ToEdit (NamedP pn deps body)) :>: ps)
  | old == pn = impossible
  | new == pn = impossible
  | old `elem` deps = impossible
  | new `elem` deps =
      let newdeps = map (\dep -> if new == dep then old else dep) deps
      in mapSeal (ToEdit (NamedP pn newdeps (unsafeCoerceP body)) :>:) (simplifyPush da (NameFixup (Rename old new)) ps)
  | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (Rename old new)) ps)

-- |Like 'simplifyPush' but for a list of fixups.
simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
               => D.DiffAlgorithm -> FL (RebaseFixup p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
simplifyPushes _ NilFL ps = Sealed ps
simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps)

instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where
   showPatch f (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch f p $$ blueText ")"
   showPatch f (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch f p $$ blueText ")" where
   showPatch f (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch f p $$ blueText ")"

instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p)
    => ShowPatch (RebaseItem p) where

   summary (ToEdit p) = summary p
   summary (Fixup (PrimFixup p)) = plainSummaryPrim p
   summary (Fixup (NameFixup n)) = summary n
   summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts


instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where
   readPatch' = mapSeal ToEdit              <$> readWith (BC.pack "rebase-toedit") <|>
                mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|>
                mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name"  )
     where readWith :: forall m q wX . (ParserM m, ReadPatch q) => B.ByteString -> m (Sealed (q wX))
           readWith str = do lexString str
                             lexString (BC.pack "(")
                             res <- readPatch'
                             lexString (BC.pack ")")
                             return res

instance Check p => Check (RebaseItem p) where
   isInconsistent (Fixup _) = Nothing
   isInconsistent (ToEdit p) = isInconsistent p

instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseItem p) where
   listTouchedFiles (ToEdit p) = listTouchedFiles p
   listTouchedFiles (Fixup p) = listTouchedFiles p

   hunkMatches f (ToEdit p) = hunkMatches f p
   hunkMatches f (Fixup p) = hunkMatches f p