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

import Prelude ()
import Darcs.Prelude

import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.ApplyMonad
  ( ApplyMonad(..), ApplyMonadTrans(..), ToTree(..), ApplyMonadState(..)
  )
import Darcs.Patch.Repair ( RepairToFL(..) )

import Darcs.Patch.Prim.Class ( PrimApply(..) )
import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), hunkEdit )
import Darcs.Patch.Prim.FileUUID.ObjectMap

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

-- import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )

import Darcs.Patch.Witnesses.Ordered ( FL(..) )
import Darcs.Util.Hash( Hash(..) )

import qualified Data.ByteString      as B

#include "impossible.h"

instance Apply Prim where
    type ApplyState Prim = ObjectMap
    apply (Manifest i (dirid, name)) = editDirectory dirid (M.insert name i)
    apply (Demanifest _ (dirid, name)) = editDirectory dirid (M.delete name)
    apply (TextHunk i hunk) = editFile i (hunkEdit hunk)
    apply (BinaryHunk i hunk) = editFile i (hunkEdit hunk)
    apply Identity = return ()
    apply (Move{}) = bug "apply for move not implemented"

instance RepairToFL Prim where
    applyAndTryToFixFL p = apply p >> return Nothing

instance PrimApply Prim where
    applyPrimFL NilFL = return ()
    applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps

instance ToTree ObjectMap -- TODO

editObject :: (Monad m) => UUID -> (Maybe (Object m) -> Object m) -> (StateT (ObjectMap m) m) ()
editObject i edit = do load <- gets getObject
                       store <- gets putObject
                       obj <- lift $ load i
                       new <- lift $ store i $ edit obj
                       put new
                       return ()


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

instance ApplyMonadState ObjectMap where
    type ApplyMonadStateOperations ObjectMap = ApplyMonadObjectMap

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

instance (Functor m, Monad m) => ApplyMonadObjectMap (StateT (ObjectMap m) m) where
    editFile i edit = editObject i edit'
      where edit' (Just (Blob x _)) = Blob (edit `fmap` x) NoHash
            edit' (Just (Directory x)) = Directory x -- error?
            edit' Nothing = Blob (return $ edit "") NoHash
    editDirectory i edit = editObject i edit'
      where edit' (Just (Directory x)) = Directory $ edit x
            edit' (Just (Blob x y)) = Blob x y -- error?
            edit' Nothing = Directory $ edit M.empty

instance (Functor m, Monad m) => ApplyMonadTrans ObjectMap m where
  type ApplyMonadOver ObjectMap m = StateT (ObjectMap m) m
  runApplyMonad = runStateT