-- Copyright (C) 2002-2005 David Roundy
-- Copyright (C) 2004 Juliusz Chroboczek
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP #-}

#include "gadts.h"

module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine,
                 createPristine, removePristine, identifyPristine,
                 applyPristine, createPristineFromWorking,
                 getPristinePop,
                 pristineDirectory, pristineToFlagString,
                 easyCreatePristineDirectoryTree,
                 easyCreatePartialsPristineDirectoryTree
               ) where

import Data.Maybe ( isJust )
import Control.Monad ( when, liftM )
import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, removeFile )
import Darcs.Lock ( rmRecursive, writeBinFile )

import Darcs.PopulationData ( Population, getPopFrom )
import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) )
import Darcs.Repository.Format ( RepoFormat, formatHas,
                                 RepoProperty(HashedInventory) )
import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) )
import Darcs.Patch ( Patchy, apply )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Patch.FileName ( fp2fn )
import Darcs.RepoPath ( FilePathLike, toFilePath )
import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree )
import Darcs.Repository.InternalTypes ( Pristine(..) )
import Darcs.Global ( darcsdir )
import Storage.Hashed.Darcs( writeDarcsHashed )
import Storage.Hashed.Tree( emptyTree )
#include "impossible.h"

nopristine :: Pristine
nopristine = NoPristine "aack?"

pristineName :: String
pristineName = "pristine"

identifyPristine :: IO (Pristine)
identifyPristine = do mp <- reallyIdentifyPristine
                      case mp of
                          Nothing -> fail "Pristine tree doesn't exist."
                          Just pristine -> return pristine

reallyIdentifyPristine :: IO (Maybe Pristine)
reallyIdentifyPristine =
    do dir <- findpristine doesDirectoryExist ""
       none <- findpristine doesFileExist ".none"
       hashinv <- doesFileExist $ darcsdir++"/hashed_inventory"
       hashpris <- doesDirectoryExist hashedPristineDirectory
       case (dir, none, hashinv && hashpris) of
           (Nothing, Nothing, False) -> return Nothing
           (Just n, Nothing, False) ->
               return (Just (PlainPristine n))
           (Nothing, Just n, False) ->
               return (Just (NoPristine n))
           (Nothing, Nothing, True) ->
               return (Just HashedPristine)
           _ -> fail "Multiple pristine trees."
    where findpristine fn ext =
              do e1 <- fn n1
                 e2 <- fn n2
                 case (e1, e2) of
                     (False, False) -> return Nothing
                     (True, False) -> return (Just n1)
                     (False, True) -> return (Just n2)
                     (True, True) -> fail "Multiple pristine trees."
              where  n1 = darcsdir++"/pristine" ++ ext
                     n2 = darcsdir++"/current" ++ ext

flagsToPristine :: [DarcsFlag] -> RepoFormat -> Pristine
flagsToPristine _ rf | formatHas HashedInventory rf = HashedPristine
flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none")
flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName)
flagsToPristine (_ : t) rf = flagsToPristine t rf
flagsToPristine [] rf = flagsToPristine [PristinePlain] rf

createPristine :: Pristine -> IO Pristine
createPristine p =
    do oldpristine <- reallyIdentifyPristine
       when (isJust oldpristine) $ fail "Pristine tree already exists."
       case p of
           NoPristine n -> writeBinFile n "Do not delete this file.\n"
           PlainPristine n -> createDirectory n
           HashedPristine -> do createDirectory hashedPristineDirectory
                                writeDarcsHashed emptyTree "_darcs/pristine.hashed"
                                return ()
       return p

hashedPristineDirectory :: String
hashedPristineDirectory = darcsdir++"/pristine.hashed"

removePristine :: Pristine -> IO ()
removePristine (NoPristine n) = removeFile n
removePristine (PlainPristine n) = rmRecursive n
removePristine HashedPristine = rmRecursive hashedPristineDirectory

applyPristine :: Patchy p => Pristine -> p C(x y) -> IO ()
applyPristine (NoPristine _) _ = return ()
-- We don't need flags for now, since we don't care about
-- SetScriptsExecutable for the pristine cache.
applyPristine (PlainPristine n) p =
    mWithCurrentDirectory (fp2fn n) $ apply [] p
applyPristine HashedPristine _ =
    bug "3 HashedPristine is not implemented yet."

createPristineFromWorking :: Pristine -> IO ()
createPristineFromWorking (NoPristine _) = return ()
createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n
createPristineFromWorking HashedPristine =
    bug "HashedPristine is not implemented yet."

getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population)
getPristinePop pinfo (PlainPristine n) =
    Just `liftM` getPopFrom n pinfo
getPristinePop _ _ = return Nothing

pristineDirectory :: Pristine -> Maybe String
pristineDirectory (PlainPristine n) = Just n
pristineDirectory _ = Nothing

pristineToFlagString :: Pristine -> String
pristineToFlagString (NoPristine _) = "--no-pristine-tree"
pristineToFlagString (PlainPristine _) = "--plain-pristine-tree"
pristineToFlagString HashedPristine =
    bug "HashedPristine is not implemented yet."

easyCreatePristineDirectoryTree :: Pristine -> FilePath -> IO Bool
easyCreatePristineDirectoryTree (NoPristine _) _ = return False
easyCreatePristineDirectoryTree (PlainPristine n) p
 = cloneTree n p >> return True
easyCreatePristineDirectoryTree HashedPristine _ =
    bug "HashedPristine is not implemented yet."

easyCreatePartialsPristineDirectoryTree :: FilePathLike fp => [fp] -> Pristine
                                        -> FilePath -> IO Bool
easyCreatePartialsPristineDirectoryTree _ (NoPristine _) _ = return False
easyCreatePartialsPristineDirectoryTree prefs (PlainPristine n) p
 = clonePartialsTree n p (map toFilePath prefs) >> return True
easyCreatePartialsPristineDirectoryTree _ HashedPristine _ =
    bug "HashedPristine is not implemented yet."