    -- 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,
                     slurpPristine,
                     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 ( rm_recursive, writeBinFile )
    import Workaround ( getCurrentDirectory )
    import Darcs.SlurpDirectory ( Slurpy,  mmap_slurp )

    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 qualified Data.ByteString as B (empty)
    import Darcs.RepoPath ( FilePathLike, toFilePath )
    import SHA1 ( sha1PS )
    import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree )
    import Darcs.Repository.InternalTypes ( Pristine(..) )
    import Darcs.Global ( darcsdir )
    #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
                                    writeFile (hashedPristineDirectory++"/"++sha1PS B.empty) ""
           return p

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

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

    slurpPristine :: Pristine -> IO (Maybe Slurpy)
    slurpPristine (PlainPristine n) = do cwd <- getCurrentDirectory
                                         slurpy <- mmap_slurp (cwd ++ "/" ++ n)
                                         return (Just slurpy)
    slurpPristine (NoPristine _) = return Nothing
    slurpPristine HashedPristine =
        bug "HashedPristine is not implemented yet."

    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."