{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{-# LANGUAGE CPP, ScopedTypeVariables #-}

#include "gadts.h"

module Darcs.Repository.DarcsRepo ( writeInventory, writeInventoryAndPatches,
                                    addToInventory, addToTentativePristine,
                                    addToTentativeInventory, removeFromTentativeInventory,
                                    finalizeTentativeChanges, finalizePristineChanges,
                                    revertTentativeChanges,
                                    readRepo, readTentativeRepo, writeAndReadPatch,
                                    copyPatches, readCheckpoints
                                  ) where

import System.Directory ( createDirectoryIfMissing )
import Workaround ( renameFile )
import Darcs.Utils ( clarifyErrors )
import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO )
import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )
import System.IO ( hPutStrLn, stderr )
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.FilePath.Posix ( (</>) )
import Control.Monad ( when )
import Darcs.Hopefully ( PatchInfoAnd,
                         patchInfoAndPatch, info,
                         actually, hopefully, unavailable, n2pia )
import Darcs.SignalHandler ( withSignalsBlocked )

import ByteStringUtils ( gzReadFilePS )
import qualified Data.ByteString as B (ByteString, null, readFile, empty)
import qualified Data.ByteString.Char8 as BC (break, pack)

import Darcs.Patch ( RepoPatch, Effect, Prim, Named, invert,
                     effect,
                     patch2patchinfo,
                     readPatch,
                     showPatch )
import qualified Darcs.Patch as Patch

import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>>)(..), (+<+),
                             reverseFL, mapFL, unsafeCoerceP,
                             reverseRL, mapRL )
import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfo,
                          showPatchInfo, isTag
                 )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.External ( gzFetchFilePS, fetchFilePS, copyFilesOrUrls, Cachable(..),
                        cloneFile )
import Darcs.Lock ( writeBinFile, writeDocBinFile, appendDocBinFile, appendBinFile )
import Darcs.Flags ( DarcsFlag( NoCompress ) )
import Darcs.Patch.Depends ( slightlyOptimizePatchset, commuteToEnd, deepOptimizePatchset )
import Darcs.Repository.Pristine ( identifyPristine, applyPristine )
import Darcs.Global ( darcsdir )
import Darcs.Utils ( catchall )
import Darcs.ProgressPatches ( progressFL )
import Printer ( text, (<>), Doc, ($$), empty )
import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal )

#include "impossible.h"

writePatch :: RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath
writePatch opts p =
       do let writeFun = if NoCompress `elem` opts
                         then Patch.writePatch
                         else Patch.gzWritePatch
              pname = darcsdir++"/patches/"++makeFilename (patch2patchinfo p)
          writeFun pname p
          return pname

writeAndReadPatch :: RepoPatch p => [DarcsFlag] -> PatchInfoAnd p C(x y)
                     -> IO (PatchInfoAnd p C(x y))
writeAndReadPatch opts p =
    do fn <- writePatch opts $ hopefully p
       unsafeInterleaveIO $ parse fn
    where parse fn = do debugMessage ("Reading patch file: "++ fn)
                        ps <- gzReadFilePS fn
                        Sealed pp <- case readPatch ps of
                                    Just (x,_) -> return x
                                    Nothing -> fail ("Couldn't parse patch file "++fn)
                        return $ n2pia $ unsafeCoerceP pp

--formatInventory is not exported for use outside of the DarcsRepo module
--itself.
formatInventory :: [PatchInfo] -> Doc
formatInventory [] = empty
formatInventory (pinfo:ps) = showPatchInfo pinfo $$ formatInventory ps

writeInventory :: RepoPatch p => FilePath -> PatchSet p C(Origin x) -> IO ()
-- Note that writeInventory optimizes the inventory it writes out by
-- checking on tag dependencies.
-- FIXME: There is also a problem that writeInventory always writes
-- out the entire inventory, including the parts that you haven't
-- changed...
writeInventory dir ps = withSignalsBlocked $ do
    createDirectoryIfMissing False (dir++"/"++darcsdir++"/inventories")
    simplyWriteInventory "inventory" dir $ slightlyOptimizePatchset ps

simplyWriteInventory :: RepoPatch p => String -> FilePath -> PatchSet p C(Origin x) -> IO ()
simplyWriteInventory name dir (PatchSet NilRL NilRL) =
    writeBinFile (dir++"/"++darcsdir++"/"++name) ""
simplyWriteInventory name dir (PatchSet ps NilRL) = do
    writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ formatInventory $ mapFL info $ reverseRL ps
simplyWriteInventory name dir (PatchSet ps ts@(Tagged t _ _ :<: _)) = do -- nonempty Tagged
    simplyWriteTaggedInventory dir ts
    writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ text "Starting with tag:"
                                           $$ formatInventory (mapFL info $ t :>: reverseRL ps)

simplyWriteTaggedInventory :: RepoPatch p => FilePath -> RL (Tagged p) C(Origin x) -> IO ()
simplyWriteTaggedInventory _ NilRL = return ()
simplyWriteTaggedInventory dir (Tagged t _ ps :<: NilRL) = do
    writeDocBinFile (dir </> "_darcs/inventories" </> makeFilename (info t)) $
                    formatInventory (mapFL info $ reverseRL ps)
simplyWriteTaggedInventory dir (Tagged t _ ps :<: ts@(Tagged t2 _ _ :<: _)) =
    do simplyWriteTaggedInventory dir ts
       writeDocBinFile (dir </> "_darcs/inventories" </> makeFilename (info t)) $
                       text "Starting with tag:" $$
                       formatInventory (mapFL info $ t2 :>: reverseRL ps)

writeInventoryAndPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin x) -> IO ()
writeInventoryAndPatches opts ps =    do writeInventory "." ps
                                         sequence_ $ mapRL (writePatch opts . hopefully) $ newset2RL ps

addToInventory :: FilePath -> [PatchInfo] -> IO ()
addToInventory dir pinfos =
    appendDocBinFile (dir++"/"++darcsdir++"/inventory") $ text "\n" <> pidocs pinfos
    where
        pidocs [] = text ""
        pidocs (p:ps) = showPatchInfo p $$ pidocs ps

addToTentativeInventory :: forall p C(x y). RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath
addToTentativeInventory opts p =
    do appendDocBinFile (darcsdir++"/tentative_inventory") $ text "\n"
                            <> showPatchInfo (patch2patchinfo p)
       when (isTag $ patch2patchinfo p) $
            do debugMessage "Optimizing the tentative inventory, since we're adding a tag."
               realdir <- toPath `fmap` ioAbsoluteOrRemote "."
               let k = "Reading tentative inventory"
               beginTedious k
               Sealed ps <- readRepoPrivate k realdir "tentative_inventory"
                            :: IO  (SealedPatchSet p C(Origin) )
               simplyWriteInventory "tentative_inventory" "." $ slightlyOptimizePatchset ps
       writePatch opts p

addToTentativePristine :: Effect p => p C(x y) -> IO ()
addToTentativePristine p =
    do -- Sealed p <- (fst . fromJust . readPatchCarefully) `fmap` gzReadFilePS fp
       appendDocBinFile (darcsdir++"/tentative_pristine") $ showPatch (effect p) -- FIXME: this is inefficient!
       appendBinFile (darcsdir++"/tentative_pristine") "\n"

removeFromTentativeInventory :: RepoPatch p => Bool -> [DarcsFlag]
                                -> FL (PatchInfoAnd p) C(x y) -> IO ()
removeFromTentativeInventory update_pristine opts to_remove =
    do finalizeTentativeChanges
       Sealed allpatches <- readRepo opts "."
       unmodified :>> skipped <- return $ commuteToEnd
                                          (reverseFL $ unsafeCoerceP to_remove) allpatches
       sequence_ $ mapRL (writePatch opts . hopefully) skipped
       let newpatches = case unmodified of
                        PatchSet ps ts -> PatchSet (skipped+<+ps) ts
       writeInventory "." $ deepOptimizePatchset newpatches
       when update_pristine $
            do pris <- identifyPristine
               repairable $ applyPristine pris
                              $ progressFL "Applying inverse to pristine" $ invert to_remove
       revertTentativeChanges

finalizeTentativeChanges :: IO ()
finalizeTentativeChanges = renameFile (darcsdir++"/tentative_inventory") (darcsdir++"/inventory")

finalizePristineChanges :: IO ()
finalizePristineChanges =
    do Sealed ps <- read_patches $ darcsdir++"/tentative_pristine"
       pris <- identifyPristine
       repairable $ applyPristine pris ps
    where
      read_patches :: String -> IO (Sealed (FL Prim C(x)))
      read_patches f = do ps <- B.readFile f
                          return $ case readPatch ps of
                                   Just (x, _) -> x
                                   Nothing -> seal $ NilFL

repairable :: IO a -> IO a
repairable x = x `clarifyErrors` unlines
               ["Your repository is now in an inconsistent state.",
                "This must be fixed by running darcs repair."]

revertTentativeChanges :: IO ()
revertTentativeChanges =
    do cloneFile (darcsdir++"/inventory") (darcsdir++"/tentative_inventory")
       writeBinFile (darcsdir++"/tentative_pristine") ""

copyPatches :: [DarcsFlag] -> FilePath -> FilePath -> [PatchInfo] -> IO ()
copyPatches opts dir out patches = do
  realdir <- toPath `fmap` ioAbsoluteOrRemote dir
  copyFilesOrUrls opts (realdir++"/"++darcsdir++"/patches") (map makeFilename patches)
                       (out++"/"++darcsdir++"/patches") Cachable

readRepo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p C(Origin))
readRepo _ d = do
  realdir <- toPath `fmap` ioAbsoluteOrRemote d
  let k = "Reading inventory of repository "++d
  beginTedious k
  readRepoPrivate k realdir "inventory" `catch`
                        (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)
                                  ioError e)

readTentativeRepo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p C(Origin))
readTentativeRepo _ d = do
  realdir <- toPath `fmap` ioAbsoluteOrRemote d
  let k = "Reading tentative inventory of repository "++d
  beginTedious k
  readRepoPrivate k realdir "tentative_inventory" `catch`
                        (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)
                                  ioError e)

readRepoPrivate :: RepoPatch p => String -> FilePath -> FilePath -> IO (SealedPatchSet p C(Origin))
readRepoPrivate k d iname = do
    i <- gzFetchFilePS (d </> "_darcs" </> iname) Uncachable
    finishedOneIO k iname
    let parse inf = parse2 inf $ d </> "_darcs/patches" </> makeFilename inf
        (mt, is) = case BC.break ((==) '\n') i of
                   (swt,pistr) | swt == BC.pack "Starting with tag:" ->
                                     case readPatchIds pistr of
                                     (t:ids) -> (Just t,reverse ids)
                                     [] -> bug "bad inventory in readRepoPrivate"
                   _ -> (Nothing, reverse $ readPatchIds i)
    Sealed ts <- unseal seal `fmap` unsafeInterleaveIO (read_ts parse mt)
    Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is)
    return $ seal (PatchSet ps ts)
    where read_ts :: RepoPatch p =>
                     (FORALL(b) PatchInfo -> IO (Sealed (PatchInfoAnd p C(b))))
                  -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) C(Origin)))
          read_ts _ Nothing = do endTedious k
                                 return $ seal NilRL
          read_ts parse (Just tag0) =
              do debugMessage $ "Looking for inventory for:\n"++ show tag0
                 i <- unsafeInterleaveIO $
                      do x <- gzFetchFilePS (d</>"_darcs/inventories"</>makeFilename tag0) Uncachable
                         finishedOneIO k (show tag0)
                         return x
                 let (mt, is) = case BC.break ((==) '\n') i of
                                (swt,pistr) | swt == BC.pack "Starting with tag:" ->
                                                case readPatchIds pistr of
                                                (t:ids) -> (Just t,reverse ids)
                                                [] -> bug "bad inventory in readRepoPrivate"
                                _ -> (Nothing, reverse $ readPatchIds i)
                 Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $ read_ts parse mt
                 Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is)
                 Sealed tag00 <-  parse tag0 `catch`
                                  \e -> return $ seal $
                                        patchInfoAndPatch tag0 $ unavailable $ show e
                 return $ seal $ Tagged tag00 Nothing ps :<: ts
          parse2 :: RepoPatch p => PatchInfo -> FilePath
                                -> IO (Sealed (PatchInfoAnd p C(x)))
          parse2 i fn = do ps <- gzFetchFilePS fn Cachable
                           return $ hopefullyNoParseError i (toPath fn) (readPatch ps)
          hopefullyNoParseError :: PatchInfo -> String
                                -> Maybe (Sealed (Named a1dr C(x)), b)
                                -> Sealed (PatchInfoAnd a1dr C(x))
          hopefullyNoParseError i _ (Just (Sealed x, _)) =
              seal $ patchInfoAndPatch i $ actually x
          hopefullyNoParseError i s Nothing =
              seal $ patchInfoAndPatch i $ unavailable $ "Couldn't parse file "++s
          read_patches :: RepoPatch p =>
                          (FORALL(b) PatchInfo -> IO (Sealed (PatchInfoAnd p C(b))))
                       -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) C(x)))
          read_patches _ [] = return $ seal NilRL
          read_patches parse (i:is) =
              lift2Sealed (:<:)
                          (read_patches parse is)
                          (parse i `catch` \e ->
                           return $ seal $ patchInfoAndPatch i $ unavailable $ show e)
          lift2Sealed :: (FORALL(y z) q C(y z) -> pp C(y) -> r C(z))
                      -> IO (Sealed pp) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed r)
          lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox
                                     Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy
                                     return $ seal $ f y x

readPatchIds :: B.ByteString -> [PatchInfo]
readPatchIds inv | B.null inv = []
readPatchIds inv = case readPatchInfo inv of
                     Just (pinfo,r) -> pinfo : readPatchIds r
                     Nothing -> []

readCheckpoints :: String -> IO [PatchInfo]
readCheckpoints d = do
  realdir <- toPath `fmap` ioAbsoluteOrRemote d
  pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable
           `catchall` return B.empty
  pis <- return $ reverse $ readPatchIds pistr
  return pis