{-# LANGUAGE StandaloneDeriving, TypeOperators #-}
module Darcs.Patch.Named.Wrapped
  ( WrappedNamed(..)
  , patch2patchinfo, activecontents
  , infopatch, namepatch, anonymous
  , getdeps, adddeps
  , mkRebase, toRebasing, fromRebasing
  , runInternalChecker, namedInternalChecker, namedIsInternal, removeInternalFL
  , fmapFL_WrappedNamed, (:~:)(..), (:~~:)(..)
  , generaliseRepoTypeWrapped
  ) where

import Prelude ()
import Darcs.Prelude
import Data.Coerce ( coerce )

import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )
import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.FileHunk ( IsHunk(..) )
import Darcs.Patch.Format ( PatchListFormat(..), ListFormat )
import Darcs.Patch.Info
  ( PatchInfo, showPatchInfo, displayPatchInfo, patchinfo
  )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Named ( Named(..), fmapFL_Named )
import qualified Darcs.Patch.Named as Base
  ( patch2patchinfo, patchcontents
  , infopatch, namepatch, anonymous
  , getdeps, adddeps
  )
import Darcs.Patch.Inspect ( PatchInspect(..) )
import Darcs.Patch.Merge ( Merge(..) )
import Darcs.Patch.Prim ( FromPrim )
import Darcs.Patch.Prim.Class ( PrimPatchBase(..) )
import Darcs.Patch.Read ( ReadPatch(..) )
import qualified Darcs.Patch.Rebase.Container as Rebase
  ( Suspended(..)
  , addFixupsToSuspended, removeFixupsFromSuspended
  )
import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL(..), Check(..) )
import Darcs.Patch.RepoType
  ( RepoType(..), IsRepoType(..), SRepoType(..)
  , RebaseType(..), RebaseTypeOf, SRebaseType(..)
  )
import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), ShowContextPatch(..), ShowPatchFor(..) )

import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Sealed ( mapSeal )
import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) )
import Darcs.Patch.Witnesses.Ordered
  ( FL(..), mapFL_FL, mapFL, (:>)(..)
  , (:\/:)(..), (:/\:)(..)
  )

import Darcs.Util.IsoDate ( getIsoDateTime )
import Darcs.Util.Text ( formatParas )
import Darcs.Util.Printer ( ($$), vcat, prefix )

import Control.Applicative ( (<|>) )

-- |A layer inbetween the 'Named p' type and 'PatchInfoAnd p'
-- design for holding "internal" patches such as the rebase
-- container. Ideally these patches would be stored at the
-- repository level but this would require some significant
-- refactoring/cleaning up of that code.
data WrappedNamed (rt :: RepoType) p wX wY where
  NormalP :: !(Named p wX wY) -> WrappedNamed rt p wX wY
  RebaseP
    :: (PrimPatchBase p, FromPrim p, Effect p)
    => !PatchInfo -- TODO: this should always be the "internal implementation detail" rebase
                  -- patch description, so could be replaced by just the Ignore-this and Date fields
    -> !(Rebase.Suspended p wX wX)
    -> WrappedNamed ('RepoType 'IsRebase) p wX wX


deriving instance Show2 p => Show (WrappedNamed rt p wX wY)

instance Show2 p => Show1 (WrappedNamed rt p wX) where
  showDict1 = ShowDictClass

instance Show2 p => Show2 (WrappedNamed rt p) where
  showDict2 = ShowDictClass

-- TODO use Data.Type.Equality and PolyKinds from GHC 7.8/base 4.7
data (a :: * -> * -> *) :~: b where
    ReflPatch :: a :~: a

data (a :: RebaseType) :~~: b where
    ReflRebaseType :: a :~~: a

-- |lift a function over an 'FL' of patches to one over
-- a 'WrappedNamed rt'.
-- The function is only applied to "normal" patches,
-- and any rebase container patch is left alone.
fmapFL_WrappedNamed
  :: (FL p wA wB -> FL q wA wB)
  -> (RebaseTypeOf rt :~~: 'IsRebase -> p :~: q)
     -- ^If the patch might be a rebase container patch,
     -- then 'p' and 'q' must be the same type, as no
     -- transformation is applied. This function provides
     -- a witness to this requirement: if 'RebaseTypeOf rt'
     -- might be 'IsRebase', then it must be able to return
     -- a proof that 'p' and 'q' are equal. If 'RebaseTypeOf rt'
     -- must be 'NoRebase', then this function can never be called
     -- with a valid value.
  -> WrappedNamed rt p wA wB
  -> WrappedNamed rt q wA wB
fmapFL_WrappedNamed f _ (NormalP n) = NormalP (fmapFL_Named f n)
fmapFL_WrappedNamed _ whenRebase (RebaseP n s) =
  case whenRebase ReflRebaseType of
    ReflPatch -> RebaseP n s

patch2patchinfo :: WrappedNamed rt p wX wY -> PatchInfo
patch2patchinfo (NormalP p) = Base.patch2patchinfo p
patch2patchinfo (RebaseP name _) = name

namepatch :: String -> String -> String -> [String] -> FL p wX wY -> IO (WrappedNamed rt p wX wY)
namepatch date name author desc p = fmap NormalP (Base.namepatch date name author desc p)

anonymous :: FL p wX wY -> IO (WrappedNamed rt p wX wY)
anonymous p = fmap NormalP (Base.anonymous p)

infopatch :: PatchInfo -> FL p wX wY -> WrappedNamed rt p wX wY
infopatch i ps = NormalP (Base.infopatch i ps)

-- |Return a list of the underlying patches that are actually
-- 'active' in the repository, i.e. not suspended as part of a rebase
activecontents :: WrappedNamed rt p wX wY -> FL p wX wY
activecontents (NormalP p) = Base.patchcontents p
activecontents (RebaseP {}) = NilFL

adddeps :: WrappedNamed rt p wX wY -> [PatchInfo] -> WrappedNamed rt p wX wY
adddeps (NormalP n) pis = NormalP (Base.adddeps n pis)
adddeps (RebaseP {}) _ = error "Internal error: can't add dependencies to a rebase internal patch"

getdeps :: WrappedNamed rt p wX wY -> [PatchInfo]
getdeps (NormalP n) = Base.getdeps n
getdeps (RebaseP {}) = []

mkRebase :: (PrimPatchBase p, FromPrim p, Effect p)
         => Rebase.Suspended p wX wX
         -> IO (WrappedNamed ('RepoType 'IsRebase) p wX wX)
mkRebase s = do
     let name = "DO NOT TOUCH: Rebase patch"
     let desc = formatParas 72
                ["This patch is an internal implementation detail of rebase, used to store suspended patches, " ++
                 "and should not be visible in the user interface. Please report a bug if a darcs " ++
                 "command is showing you this patch."]
     date <- getIsoDateTime
     let author = "Invalid <invalid@invalid>"
     info <- patchinfo date name author desc
     return $ RebaseP info s

toRebasing :: Named p wX wY -> WrappedNamed ('RepoType 'IsRebase) p wX wY
toRebasing n = NormalP n

fromRebasing :: WrappedNamed ('RepoType 'IsRebase) p wX wY -> Named p wX wY
fromRebasing (NormalP n) = n
fromRebasing (RebaseP {}) = error "internal error: found rebasing internal patch"

generaliseRepoTypeWrapped
  :: WrappedNamed ('RepoType 'NoRebase) p wA wB
  -> WrappedNamed rt p wA wB
generaliseRepoTypeWrapped (NormalP p) = NormalP p

-- Note: the EqCheck result could be replaced by a Bool if clients were changed to commute the patch
-- out if necessary.
newtype InternalChecker p =
  InternalChecker { runInternalChecker :: forall wX wY . p wX wY -> EqCheck wX wY }

-- |Is the given 'WrappedNamed' patch an internal implementation detail
-- that shouldn't be visible in the UI or included in tags/matchers etc?
-- Two-level checker for efficiency: if the value of this is 'Nothing' for a given
-- patch type then there's no need to inspect patches of this type at all,
-- as none of them can be internal.
namedInternalChecker :: forall rt p . IsRepoType rt => Maybe (InternalChecker (WrappedNamed rt p))
namedInternalChecker =
  case singletonRepoType :: SRepoType rt of
    SRepoType SNoRebase -> Nothing
    SRepoType SIsRebase ->
      let
        isInternal :: WrappedNamed rt p wX wY -> EqCheck wX wY
        isInternal (NormalP {}) = NotEq
        isInternal (RebaseP {}) = IsEq
      in Just (InternalChecker isInternal)

-- |Is the given 'WrappedNamed' patch an internal implementation detail
-- that shouldn't be visible in the UI or included in tags/matchers etc?
namedIsInternal :: IsRepoType rt => WrappedNamed rt p wX wY -> EqCheck wX wY
namedIsInternal = maybe (const NotEq) runInternalChecker namedInternalChecker

removeInternalFL :: IsRepoType rt => FL (WrappedNamed rt p) wX wY -> FL (Named p) wX wY
removeInternalFL NilFL = NilFL
removeInternalFL (NormalP n :>: ps) = n :>: removeInternalFL ps
removeInternalFL (RebaseP {} :>: ps) = removeInternalFL ps

instance PrimPatchBase p => PrimPatchBase (WrappedNamed rt p) where
  type PrimOf (WrappedNamed rt p) = PrimOf p

instance Invert p => Invert (WrappedNamed rt p) where
  invert (NormalP n) = NormalP (invert n)
  invert (RebaseP i s) = RebaseP i s -- TODO is this sensible?

instance PatchListFormat (WrappedNamed rt p)

instance IsHunk (WrappedNamed rt p) where
  isHunk _ = Nothing

instance (ShowPatchBasic p, PatchListFormat p)
  => ShowPatchBasic (WrappedNamed rt p) where

  showPatch f (NormalP n) = showPatch f n
  showPatch f (RebaseP i s) = showPatchInfo f i <> showPatch f s

instance ( ShowContextPatch p, PatchListFormat p, Apply p
         , PrimPatchBase p, IsHunk p
         )
  => ShowContextPatch (WrappedNamed rt p) where

  showContextPatch f (NormalP n) = showContextPatch f n
  showContextPatch f@ForDisplay (RebaseP i s) =
    fmap (showPatchInfo f i $$) $ return (showPatch f s)
  showContextPatch f@ForStorage (RebaseP i s) =
    fmap (showPatchInfo f i <>) $ return (showPatch f s)

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

  description (NormalP n) = description n
  description (RebaseP i _) = displayPatchInfo i

  summary (NormalP n) = summary n
  summary (RebaseP i _) = displayPatchInfo i

  summaryFL = vcat . mapFL summary

  showNicely (NormalP n) = showNicely n
  showNicely (RebaseP i s) = displayPatchInfo i $$
                             prefix "    " (showNicely s)

instance PatchInspect p => PatchInspect (WrappedNamed rt p) where
  listTouchedFiles (NormalP n) = listTouchedFiles n
  listTouchedFiles (RebaseP _ s) = listTouchedFiles s

  hunkMatches f (NormalP n) = hunkMatches f n
  hunkMatches f (RebaseP _ s) = hunkMatches f s

instance RepairToFL p => Repair (WrappedNamed rt p) where
  applyAndTryToFix (NormalP n) = fmap (mapMaybeSnd NormalP) $ applyAndTryToFix n
  applyAndTryToFix (RebaseP i s) = fmap (mapMaybeSnd (RebaseP i)) $ applyAndTryToFix s

-- This is a local hack to maintain backwards compatibility with
-- the on-disk format for rebases. Previously the rebase container
-- was internally represented via a 'Rebasing' type that sat *inside*
-- a 'Named', and so the rebase container patch had the structure
-- 'NamedP i [] (Suspendended s :>: NilFL)'. This structure was reflected
-- in the way it was saved on disk.
-- The easiest to read this structure is to use an intermediate type
-- that reflects the old structure.
-- TODO: switch to a more natural on-disk structure that directly
-- saves/reads 'RebaseP'.
data ReadRebasing p wX wY where
  ReadNormal    :: p wX wY -> ReadRebasing p wX wY
  ReadSuspended :: Rebase.Suspended p wX wX -> ReadRebasing p wX wX

instance ( ReadPatch p, PrimPatchBase p, FromPrim p, Effect p, PatchListFormat p
         , IsRepoType rt
         ) => ReadPatch (WrappedNamed rt p) where
  readPatch' =
    case singletonRepoType :: SRepoType rt of
      SRepoType SIsRebase ->
        let wrapNamed :: Named (ReadRebasing p) wX wY -> WrappedNamed rt p wX wY
            wrapNamed (NamedP i [] (ReadSuspended s :>: NilFL))
               = RebaseP i s
            wrapNamed (NamedP i deps ps) = NormalP (NamedP i deps (mapFL_FL unRead ps))

            unRead (ReadNormal p) = p
            unRead (ReadSuspended _) = error "unexpected suspended patch"

        in fmap (mapSeal wrapNamed) readPatch'

      _ -> fmap (mapSeal NormalP) readPatch'

instance PatchListFormat p => PatchListFormat (ReadRebasing p) where
  patchListFormat = coerce (patchListFormat :: ListFormat p)

instance (ReadPatch p, PatchListFormat p, PrimPatchBase p) => ReadPatch (ReadRebasing p) where
  readPatch' =
       mapSeal toSuspended <$> readPatch'
    <|> mapSeal ReadNormal <$> readPatch'
      where -- needed to get a suitably polymorphic type
            toSuspended :: Rebase.Suspended p wX wY -> ReadRebasing p wX wY
            toSuspended (Rebase.Items ps) = ReadSuspended (Rebase.Items ps)

instance (CommuteNoConflicts p, Conflict p) => Conflict (WrappedNamed rt p) where
  resolveConflicts (NormalP n) = resolveConflicts n
  resolveConflicts (RebaseP _ s) = resolveConflicts s

  conflictedEffect (NormalP n) = conflictedEffect n
  conflictedEffect (RebaseP _ s) = conflictedEffect s

instance Check p => Check (WrappedNamed rt p) where
  isInconsistent (NormalP n) = isInconsistent n
  isInconsistent (RebaseP _ s) = isInconsistent s

instance Apply p => Apply (WrappedNamed rt p) where
  type ApplyState (WrappedNamed rt p) = ApplyState p
  apply (NormalP n) = apply n
  apply (RebaseP _ s) = apply s

instance Effect p => Effect (WrappedNamed rt p) where
  effect (NormalP n) = effect n
  effect (RebaseP _ s) = effect s

  effectRL (NormalP n) = effectRL n
  effectRL (RebaseP _ s) = effectRL s

instance Commute p => Commute (WrappedNamed rt p) where
  commute (NormalP n1 :> NormalP n2) = do
    n2' :> n1' <- commute (n1 :> n2)
    return (NormalP n2' :> NormalP n1')

  commute (RebaseP i1 s1 :> RebaseP i2 s2) =
    -- Two rebases in sequence must have the same starting context,
    -- so they should trivially commute.
    -- This case shouldn't actually happen since each repo only has
    -- a single Suspended patch.
    return (RebaseP i2 s2 :> RebaseP i1 s1)

  commute (NormalP n1 :> RebaseP i2 s2) =
    return (RebaseP i2 (Rebase.addFixupsToSuspended n1 s2) :> NormalP n1)

  commute (RebaseP i1 s1 :> NormalP n2) =
    return (NormalP n2 :> RebaseP i1 (Rebase.removeFixupsFromSuspended n2 s1))

instance Merge p => Merge (WrappedNamed rt p) where
  merge (NormalP n1 :\/: NormalP n2) =
    case merge (n1 :\/: n2) of
      n2' :/\: n1' -> NormalP n2' :/\: NormalP n1'

  -- shouldn't happen as each repo only has a single Suspended patch
  merge (RebaseP i1 items1 :\/: RebaseP i2 items2) =
    RebaseP i2 items2 :/\: RebaseP i1 items1

  merge (NormalP n1 :\/: RebaseP i2 s2) =
    RebaseP i2 (Rebase.removeFixupsFromSuspended n1 s2) :/\: NormalP n1

  merge (RebaseP i1 s1 :\/: NormalP n2) =
    NormalP n2 :/\: RebaseP i1 (Rebase.removeFixupsFromSuspended n2 s1)