{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-}
module Darcs.Patch.Prim.FileUUID.Apply ( hunkEdit, ObjectMap(..) ) where

import Darcs.Prelude

import Control.Monad.State( StateT, runStateT, gets, lift, put )
import qualified Data.ByteString as B
import qualified Data.Map as M

import Debug.Trace ( trace )
-- import Text.Show.Pretty ( ppShow )

import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.ApplyMonad
    ( ApplyMonad(..), ApplyMonadTrans(..)
    , ToTree(..), ApplyMonadState(..)
    )
import Darcs.Patch.Prim.Class ( PrimApply(..) )
import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..), HunkMove(..) )
import Darcs.Patch.Prim.FileUUID.Show
import Darcs.Patch.Prim.FileUUID.ObjectMap
import Darcs.Patch.Repair ( RepairToFL(..) )
import Darcs.Patch.Witnesses.Ordered ( FL(..) )

import Darcs.Util.Hash( Hash(..) )
import Darcs.Util.Printer( text, packedString, ($$), renderString )


instance Apply Prim where
  type ApplyState Prim = ObjectMap
  apply :: Prim wX wY -> m ()
apply (Manifest UUID
i (L UUID
dirid Name
name)) = UUID -> (DirContent -> DirContent) -> m ()
forall (m :: * -> *).
ApplyMonadObjectMap m =>
UUID -> (DirContent -> DirContent) -> m ()
editDirectory UUID
dirid (Name -> UUID -> DirContent -> DirContent
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name UUID
i)
  apply (Demanifest UUID
_ (L UUID
dirid Name
name)) = UUID -> (DirContent -> DirContent) -> m ()
forall (m :: * -> *).
ApplyMonadObjectMap m =>
UUID -> (DirContent -> DirContent) -> m ()
editDirectory UUID
dirid (Name -> DirContent -> DirContent
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
name)
  apply (Hunk UUID
i Hunk wX wY
hunk) = UUID -> (FileContent -> FileContent) -> m ()
forall (m :: * -> *).
ApplyMonadObjectMap m =>
UUID -> (FileContent -> FileContent) -> m ()
editFile UUID
i (Hunk wX wY -> FileContent -> FileContent
forall wX wY. Hunk wX wY -> FileContent -> FileContent
hunkEdit Hunk wX wY
hunk)
  apply (HunkMove (HM UUID
fs Int
ls UUID
ft Int
lt FileContent
c)) =
    UUID -> (FileContent -> FileContent) -> m ()
forall (m :: * -> *).
ApplyMonadObjectMap m =>
UUID -> (FileContent -> FileContent) -> m ()
editFile UUID
fs (Hunk Any Any -> FileContent -> FileContent
forall wX wY. Hunk wX wY -> FileContent -> FileContent
hunkEdit (Int -> FileContent -> FileContent -> Hunk Any Any
forall wX wY. Int -> FileContent -> FileContent -> Hunk wX wY
H Int
ls FileContent
c FileContent
B.empty)) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UUID -> (FileContent -> FileContent) -> m ()
forall (m :: * -> *).
ApplyMonadObjectMap m =>
UUID -> (FileContent -> FileContent) -> m ()
editFile UUID
ft (Hunk Any Any -> FileContent -> FileContent
forall wX wY. Hunk wX wY -> FileContent -> FileContent
hunkEdit (Int -> FileContent -> FileContent -> Hunk Any Any
forall wX wY. Int -> FileContent -> FileContent -> Hunk wX wY
H Int
lt FileContent
B.empty FileContent
c))
  apply Prim wX wY
Identity = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance RepairToFL Prim where
  applyAndTryToFixFL :: Prim wX wY -> m (Maybe (String, FL Prim wX wY))
applyAndTryToFixFL Prim wX wY
p = Prim wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply Prim wX wY
p m ()
-> m (Maybe (String, FL Prim wX wY))
-> m (Maybe (String, FL Prim wX wY))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (String, FL Prim wX wY) -> m (Maybe (String, FL Prim wX wY))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, FL Prim wX wY)
forall a. Maybe a
Nothing

instance PrimApply Prim where
  applyPrimFL :: FL Prim wX wY -> m ()
applyPrimFL FL Prim wX wY
NilFL = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  applyPrimFL (Prim wX wY
p :>: FL Prim wY wY
ps) = Prim wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply Prim wX wY
p m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FL Prim wY wY -> m ()
forall (prim :: * -> * -> *) (m :: * -> *) wX wY.
(PrimApply prim, ApplyMonad (ApplyState prim) m) =>
FL prim wX wY -> m ()
applyPrimFL FL Prim wY wY
ps

instance ToTree ObjectMap -- TODO

hunkEdit :: Hunk wX wY -> FileContent -> FileContent
hunkEdit :: Hunk wX wY -> FileContent -> FileContent
hunkEdit h :: Hunk wX wY
h@(H Int
off FileContent
old FileContent
new) FileContent
c
  | FileContent
old FileContent -> FileContent -> Bool
`B.isPrefixOf` (Int -> FileContent -> FileContent
B.drop Int
off FileContent
c) =
      [FileContent] -> FileContent
B.concat [Int -> FileContent -> FileContent
B.take Int
off FileContent
c, FileContent
new, Int -> FileContent -> FileContent
B.drop (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FileContent -> Int
B.length FileContent
old) FileContent
c]
  | Bool
otherwise = String -> FileContent
forall a. HasCallStack => String -> a
error (String -> FileContent) -> String -> FileContent
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
      String -> Doc
text String
"##error applying hunk:" Doc -> Doc -> Doc
$$ Maybe UUID -> Hunk wX wY -> Doc
forall wX wY. Maybe UUID -> Hunk wX wY -> Doc
displayHunk Maybe UUID
forall a. Maybe a
Nothing Hunk wX wY
h Doc -> Doc -> Doc
$$ Doc
"##to" Doc -> Doc -> Doc
$$
      FileContent -> Doc
packedString FileContent
c
--       $$ text "##old=" <> text (ppShow old) $$
--       text "##new=" <> text (ppShow new) $$
--       text "##c=" <> text (ppShow c)

editObject :: Monad m
           => UUID
           -> (Maybe (Object m) -> Object m)
           -> (StateT (ObjectMap m) m) ()
editObject :: UUID -> (Maybe (Object m) -> Object m) -> StateT (ObjectMap m) m ()
editObject UUID
i Maybe (Object m) -> Object m
edit = do
  UUID -> m (Maybe (Object m))
load <- (ObjectMap m -> UUID -> m (Maybe (Object m)))
-> StateT (ObjectMap m) m (UUID -> m (Maybe (Object m)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ObjectMap m -> UUID -> m (Maybe (Object m))
forall (m :: * -> *). ObjectMap m -> UUID -> m (Maybe (Object m))
getObject
  UUID -> Object m -> m (ObjectMap m)
store <- (ObjectMap m -> UUID -> Object m -> m (ObjectMap m))
-> StateT (ObjectMap m) m (UUID -> Object m -> m (ObjectMap m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ObjectMap m -> UUID -> Object m -> m (ObjectMap m)
forall (m :: * -> *).
ObjectMap m -> UUID -> Object m -> m (ObjectMap m)
putObject
  Maybe (Object m)
obj <- m (Maybe (Object m)) -> StateT (ObjectMap m) m (Maybe (Object m))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (Object m)) -> StateT (ObjectMap m) m (Maybe (Object m)))
-> m (Maybe (Object m))
-> StateT (ObjectMap m) m (Maybe (Object m))
forall a b. (a -> b) -> a -> b
$ UUID -> m (Maybe (Object m))
load UUID
i
  ObjectMap m
new <- m (ObjectMap m) -> StateT (ObjectMap m) m (ObjectMap m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ObjectMap m) -> StateT (ObjectMap m) m (ObjectMap m))
-> m (ObjectMap m) -> StateT (ObjectMap m) m (ObjectMap m)
forall a b. (a -> b) -> a -> b
$ UUID -> Object m -> m (ObjectMap m)
store UUID
i (Object m -> m (ObjectMap m)) -> Object m -> m (ObjectMap m)
forall a b. (a -> b) -> a -> b
$ Maybe (Object m) -> Object m
edit Maybe (Object m)
obj
  ObjectMap m -> StateT (ObjectMap m) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ObjectMap m
new

-- a semantic, ObjectMap-based interface for patch application
class ApplyMonadObjectMap m where
  editFile :: UUID -> (FileContent -> FileContent) -> m ()
  editDirectory :: UUID -> (DirContent -> DirContent) -> m ()

instance ApplyMonadState ObjectMap where
  type ApplyMonadStateOperations ObjectMap = ApplyMonadObjectMap

instance (Monad m) => ApplyMonad ObjectMap (StateT (ObjectMap m) m) where
  type ApplyMonadBase (StateT (ObjectMap m) m) = m

instance (Monad m) => ApplyMonadObjectMap (StateT (ObjectMap m) m) where
  editFile :: UUID -> (FileContent -> FileContent) -> StateT (ObjectMap m) m ()
editFile UUID
i FileContent -> FileContent
edit = UUID -> (Maybe (Object m) -> Object m) -> StateT (ObjectMap m) m ()
forall (m :: * -> *).
Monad m =>
UUID -> (Maybe (Object m) -> Object m) -> StateT (ObjectMap m) m ()
editObject UUID
i Maybe (Object m) -> Object m
forall (m :: * -> *). Monad m => Maybe (Object m) -> Object m
edit'
    where
      edit' :: Maybe (Object m) -> Object m
edit' (Just (Blob m FileContent
x Hash
_)) = m FileContent -> Hash -> Object m
forall (m :: * -> *). m FileContent -> Hash -> Object m
Blob (FileContent -> FileContent
edit (FileContent -> FileContent) -> m FileContent -> m FileContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m FileContent
x) Hash
NoHash
      edit' Maybe (Object m)
Nothing = m FileContent -> Hash -> Object m
forall (m :: * -> *). m FileContent -> Hash -> Object m
Blob (FileContent -> m FileContent
forall (m :: * -> *) a. Monad m => a -> m a
return (FileContent -> m FileContent) -> FileContent -> m FileContent
forall a b. (a -> b) -> a -> b
$ FileContent -> FileContent
edit FileContent
"") Hash
NoHash
      edit' (Just d :: Object m
d@(Directory DirContent
m)) =
        String -> Object m -> Object m
forall a. String -> a -> a
trace (String
"\neditFile called with Directory object: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (UUID, DirContent) -> String
forall a. Show a => a -> String
show (UUID
i,DirContent
m) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") Object m
d
  editDirectory :: UUID -> (DirContent -> DirContent) -> StateT (ObjectMap m) m ()
editDirectory UUID
i DirContent -> DirContent
edit = UUID -> (Maybe (Object m) -> Object m) -> StateT (ObjectMap m) m ()
forall (m :: * -> *).
Monad m =>
UUID -> (Maybe (Object m) -> Object m) -> StateT (ObjectMap m) m ()
editObject UUID
i Maybe (Object m) -> Object m
forall (m :: * -> *). Maybe (Object m) -> Object m
edit'
    where
      edit' :: Maybe (Object m) -> Object m
edit' (Just (Directory DirContent
x)) = DirContent -> Object m
forall (m :: * -> *). DirContent -> Object m
Directory (DirContent -> Object m) -> DirContent -> Object m
forall a b. (a -> b) -> a -> b
$ DirContent -> DirContent
edit DirContent
x
      edit' Maybe (Object m)
Nothing = DirContent -> Object m
forall (m :: * -> *). DirContent -> Object m
Directory (DirContent -> Object m) -> DirContent -> Object m
forall a b. (a -> b) -> a -> b
$ DirContent -> DirContent
edit DirContent
forall k a. Map k a
M.empty
      edit' (Just b :: Object m
b@(Blob m FileContent
_ Hash
h)) =
        String -> Object m -> Object m
forall a. String -> a -> a
trace (String
"\neditDirectory called with File object: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (UUID, Hash) -> String
forall a. Show a => a -> String
show (UUID
i,Hash
h) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") Object m
b

instance (Monad m) => ApplyMonadTrans ObjectMap m where
  type ApplyMonadOver ObjectMap m = StateT (ObjectMap m) m
  runApplyMonad :: ApplyMonadOver ObjectMap m x -> ObjectMap m -> m (x, ObjectMap m)
runApplyMonad = ApplyMonadOver ObjectMap m x -> ObjectMap m -> m (x, ObjectMap m)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT