    {-# LANGUAGE CPP #-}
    {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}

    -- Copyright (C) 2009 Petr Rockai
    --
    -- Permission is hereby granted, free of charge, to any person
    -- obtaining a copy of this software and associated documentation
    -- files (the "Software"), to deal in the Software without
    -- restriction, including without limitation the rights to use, copy,
    -- modify, merge, publish, distribute, sublicense, and/or sell copies
    -- of the Software, and to permit persons to whom the Software is
    -- furnished to do so, subject to the following conditions:
    --
    -- The above copyright notice and this permission notice shall be
    -- included in all copies or substantial portions of the Software.
    --
    -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
    -- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
    -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
    -- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
    -- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
    -- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
    -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
    -- SOFTWARE.

    module Darcs.Repository.State
        ( restrictSubpaths, restrictBoring
        -- * Diffs.
        , unrecordedChanges, readPending, pendingChanges
        -- * Trees.
        , readRecorded, readUnrecorded, readRecordedAndPending, readWorking
        -- * Index.
        , readIndex, invalidateIndex ) where

    import Prelude hiding ( filter )
    import Control.Monad( when )
    import Control.Applicative( (<$>) )
    import Data.Maybe( isJust )
    import Data.List( union )
    import Text.Regex( matchRegex )

    import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile )
    import System.FilePath ( (</>) )
    import qualified Data.ByteString as BS
    import qualified Data.ByteString.Char8 as BSC

    import Darcs.Patch ( RepoPatch, Prim, invert, applyToTree, applyToFilepaths
                       , sortCoalesceFL )
    import Darcs.Patch.TouchesFiles ( choose_touching )
    import Darcs.Witnesses.Ordered ( FL(..), (+>+) )
    import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal )
    import Darcs.Diff ( treeDiff )
    import Darcs.Flags ( DarcsFlag( LookForAdds ), willIgnoreTimes )
    import Darcs.Global ( darcsdir )
    import Darcs.Utils ( filterPaths )

    import Darcs.Repository.InternalTypes ( Repository )
    import Darcs.Repository.LowLevel( read_pending )
    import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps )

    import Darcs.Patch.FileName ( fn2fp )
    import Darcs.RepoPath ( SubPath, sp2fn )

    import Storage.Hashed.AnchoredPath( AnchoredPath(..), anchorPath, floatPath, Name(..) )
    import Storage.Hashed.Tree( Tree, restrict, FilterTree, expand, filter, emptyTree, overlay, find )
    import Storage.Hashed.Plain( readPlainTree )
    import Storage.Hashed.Darcs( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )
    import Storage.Hashed.Hash( Hash( NoHash ) )
    import qualified Storage.Hashed.Index as I
    import qualified Storage.Hashed.Tree as Tree

    #include "gadts.h"

    -- | From a repository and a list of SubPath's, construct a filter that can be
    -- used on a Tree (recorded or unrecorded state) of this repository. This
    -- constructed filter will take pending into account, so the subpaths will be
    -- translated correctly relative to pending move patches. As an exception for
    -- convenience, if the subpath list is empty, the filter constructed is an
    -- identity.
    restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath]
                     -> IO (forall t m. FilterTree t m => t m -> t m)
    restrictSubpaths repo subpaths = do
      Sealed pending <- read_pending repo
      let paths = map (fn2fp . sp2fn) subpaths
          paths' = paths `union` applyToFilepaths pending paths
          anchored = map floatPath paths'
          restrictPaths :: FilterTree t m => t m -> t m
          restrictPaths = if null subpaths then id else filter (filterPaths anchored)
      return restrictPaths

    -- | Construct a Tree filter that removes any boring files the Tree might have
    -- contained. Additionally, you should (in most cases) pass an (expanded) Tree
    -- that corresponds to the recorded content of the repository. This is
    -- important in the cases when the repository contains files that would be
    -- boring otherwise. (If you pass emptyTree instead, such files will simply be
    -- discarded by the filter, which is usually not what you want.)
    --
    -- This function is most useful when you have a plain Tree corresponding to the
    -- full working copy of the repository, including untracked
    -- files. Cf. whatsnew, record --look-for-adds.  NB. Assumes that our CWD is
    -- the repository root.
    restrictBoring :: forall t m. Tree m -> IO (FilterTree t m => t m -> t m)
    restrictBoring guide = do
      boring <- boringRegexps
      let boring' (AnchoredPath (Name x:_)) | x == BSC.pack darcsdir = False
          boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring
              where p' = anchorPath "" p
          restrictTree :: FilterTree t m => t m -> t m
          restrictTree = filter $ \p _ -> case find guide p of
                                            Nothing -> boring' p
                                            _ -> True
      return restrictTree

    -- | For a repository and a list of paths (when empty, take everything) compute
    -- a (forward) list of prims (i.e. a patch) going from the recorded state of
    -- the repository (pristine) to the unrecorded state of the repository (the
    -- working copy + pending). When a non-empty list of paths is given, exactly
    -- the files that live under any of these paths in either recorded or
    -- unrecorded will be included in the resulting patch.
    --
    -- This also depends on the options given: with LookForAdds, we will include
    -- any non-boring files (i.e. also those that do not exist in the "recorded"
    -- state) in the working in the "unrecorded" state, and therefore they will
    -- show up in the patches as addfiles.
    --
    -- The IgnoreTimes option disables index usage completely -- for each file, we
    -- read both the unrecorded and the recorded copy and run a diff on them. This
    -- is very inefficient, although in extremely rare cases, the index could go
    -- out of sync (file is modified, index is updated and file is modified again
    -- within a single second).
    unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t)
                      -> [SubPath] -> IO (FL Prim C(r y))
    unrecordedChanges opts repo paths = do
      (all_current, _) <- readPending repo
      Sealed pending <- pendingChanges repo paths

      relevant <- restrictSubpaths repo paths
      let getIndex = I.updateIndex =<< (relevant <$> readIndex repo)
          current = relevant all_current

      working <- case (LookForAdds `elem` opts, willIgnoreTimes opts) of
                   (False, False) -> getIndex
                   (False, True) -> do
                     guide <- expand current
                     relevant <$> restrict guide <$> readPlainTree "."
                   (True, ignoretimes) -> do
                     index <- getIndex
                     nonboring <- restrictBoring index
                     plain <- relevant <$> nonboring <$> readPlainTree "."
                     return $ if ignoretimes then plain else plain `overlay` index

      ft <- filetypeFunction
      diff <- treeDiff ft current working
      return $ sortCoalesceFL (pending +>+ diff)

    -- | Obtains a Tree corresponding to the "recorded" state of the repository:
    -- this is the same as the pristine cache, which is the same as the result of
    -- applying all the repository's patches to an empty directory.
    --
    -- Handles the plain and hashed pristine cases. Currently does not handle the
    -- no-pristine case, as that requires replaying patches. Cf. 'readDarcsHashed'
    -- and 'readPlainTree' in hashed-storage that are used to do the actual 'Tree'
    -- construction.
    readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)
    readRecorded _repo = do
      let h_inventory = darcsdir </> "hashed_inventory"
      hashed <- doesFileExist h_inventory
      if hashed
         then do inv <- BS.readFile h_inventory
                 let linesInv = BSC.split '\n' inv
                 case linesInv of
                   [] -> return emptyTree
                   (pris_line:_) -> do
                              let hash = decodeDarcsHash $ BS.drop 9 pris_line
                                  size = decodeDarcsSize $ BS.drop 9 pris_line
                              when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line
                              readDarcsHashed (darcsdir </> "pristine.hashed") (size, hash)
         else do have_pristine <- doesDirectoryExist $ darcsdir </> "pristine"
                 have_current <- doesDirectoryExist $ darcsdir </> "current"
                 case (have_pristine, have_current) of
                   (True, _) -> readPlainTree $ darcsdir </> "pristine"
                   (False, True) -> readPlainTree $ darcsdir </> "current"
                   (_, _) -> fail "No pristine tree is available!"

    -- | Obtains a Tree corresponding to the "unrecorded" state of the repository:
    -- the working tree plus the "pending" patch.
    readUnrecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)
    readUnrecorded repo = readIndex repo >>= I.updateIndex

    -- | Obtains a Tree corresponding to the working copy of the
    -- repository. NB. Almost always, using readUnrecorded is the right
    -- choice. This function is only useful in not-completely-constructed
    -- repositories.
    readWorking :: IO (Tree IO)
    readWorking = expand =<< (nodarcs `fmap` readPlainTree ".")
      where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BSC.pack "_darcs")

    readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)
    readRecordedAndPending repo = do
      pristine <- readRecorded repo
      Sealed pending <- pendingChanges repo []
      applyToTree pending pristine

    readPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO, Sealed (FL Prim C(r)))
    readPending repo =
      do Sealed pending <- read_pending repo
         pristine <- readRecorded repo
         catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ err -> do
           putStrLn $ "Yikes, pending has conflicts! " ++ show err
           putStrLn $ "Stashing the buggy pending as _darcs/patches/pending_buggy"
           renameFile "_darcs/patches/pending"
                      "_darcs/patches/pending_buggy"
           return (pristine, seal NilFL)

    pendingChanges :: (RepoPatch p) => Repository p C(r u t)
                   -> [SubPath] -> IO (Sealed (FL Prim C(r)))
    pendingChanges repo paths = do
      Sealed pending <- snd `fmap` readPending repo
      let files = map (fn2fp . sp2fn) paths
          pre_files = applyToFilepaths (invert pending) files
          relevant = case paths of
                       [] -> seal pending
                       _ -> choose_touching pre_files pending
      return relevant

    -- | Mark the existing index as invalid. This has to be called whenever the
    -- listing of pristine changes and will cause darcs to update the index next
    -- time it tries to read it. (NB. This is about files added and removed from
    -- pristine: changes to file content in either pristine or working are handled
    -- transparently by the index reading code.)
    invalidateIndex :: t -> IO ()
    invalidateIndex _ = do
      BS.writeFile "_darcs/index_invalid" BS.empty

    readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO I.Index
    readIndex repo = do
      invalid <- doesFileExist "_darcs/index_invalid"
      exist <- doesFileExist "_darcs/index"
      format_valid <- if exist
                         then I.indexFormatValid "_darcs/index"
                         else return True
      when (exist && not format_valid) $
    #if mingw32_HOST_OS
           renameFile "_darcs/index" "_darcs/index.old"
    #else
           removeFile "_darcs/index"
    #endif
      if (not exist || invalid || not format_valid)
         then do pris <- readRecordedAndPending repo
                 idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris
                 when invalid $ removeFile "_darcs/index_invalid"
                 return idx
         else I.readIndex "_darcs/index" darcsTreeHash