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

    module Darcs.Repository.Repair ( replayRepository, checkIndex
                                   , RepositoryConsistency(..) )
           where

    import Control.Monad ( when, unless )
    import Control.Monad.Trans ( liftIO )
    import Control.Applicative( (<$>) )
    import Control.Exception ( finally )
    import Data.Maybe ( catMaybes )
    import Data.List ( sort, (\\) )
    import System.Directory ( createDirectoryIfMissing )

    import Darcs.Lock( rm_recursive )
    import Darcs.Hopefully ( PatchInfoAnd, info )

    import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL,
                         mapRL )
    import Darcs.Patch.Patchy ( applyAndTryToFix )
    import Darcs.Patch.Info ( PatchInfo( .. ), human_friendly )
    import Darcs.Patch.Set ( PatchSet )
    import Darcs.Patch ( RepoPatch )

    import Darcs.Repository.Format ( identifyRepoFormat,
                                     RepoProperty ( HashedInventory ), formatHas )
    import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )
    import Darcs.Repository.HashedIO ( clean_hashdir )
    import Darcs.Repository.HashedRepo ( readHashedPristineRoot )
    import Darcs.Repository.InternalTypes ( extractCache )
    import Darcs.Repository.Prefs ( filetypeFunction )
    import Darcs.Repository ( Repository, read_repo, makePatchLazy
                            , readRecorded, readIndex, readRecordedAndPending )

    import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )
    import Darcs.Utils ( catchall )
    import Darcs.Global ( darcsdir )
    import Printer ( Doc, putDocLn, text )
    import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) )

    import Darcs.Diff( treeDiff )
    import Storage.Hashed.Monad( TreeIO )
    import Storage.Hashed.Darcs( hashedTreeIO )
    import Storage.Hashed.Tree( Tree, emptyTree )
    import Storage.Hashed.AnchoredPath( anchorPath )
    import Storage.Hashed.Hash( Hash(NoHash), encodeBase16 )
    import Storage.Hashed.Tree( list, restrict, expand, itemHash, zipTrees )
    import Storage.Hashed.Darcs( darcsUpdateHashes )
    import Storage.Hashed.Index( updateIndex )
    import Storage.Hashed( readPlainTree )

    import qualified Data.ByteString.Char8 as BS

    #include "impossible.h"

    replaceInFL :: FL (PatchInfoAnd a)
                -> [(PatchInfo, PatchInfoAnd a)]
                -> FL (PatchInfoAnd a)
    replaceInFL orig [] = orig
    replaceInFL NilFL _ = impossible
    replaceInFL (o:>:orig) ch@((o',c):ch_rest)
        | info o == o' = c:>:replaceInFL orig ch_rest
        | otherwise = o:>:replaceInFL orig ch

    applyAndFix :: forall p. RepoPatch p => Repository p -> FL (PatchInfoAnd p) -> TreeIO (FL (PatchInfoAnd p), Bool)
    applyAndFix _ NilFL = return (NilFL, True)
    applyAndFix r psin =
        do liftIO $ beginTedious k
           liftIO $ tediousSize k $ lengthFL psin
           (repaired, ok) <- aaf psin
           liftIO $ endTedious k
           orig <- liftIO $ (reverseRL . concatRL) `fmap` read_repo r
           return (replaceInFL orig repaired, ok)
        where k = "Replaying patch"
              aaf :: FL (PatchInfoAnd p) -> TreeIO ([(PatchInfo, PatchInfoAnd p)], Bool)
              aaf NilFL = return ([], True)
              aaf (p:>:ps) = do
                mp' <- applyAndTryToFix p
                let !infp = info p -- assure that 'p' can be garbage collected.
                liftIO $ finishedOneIO k $ show $ human_friendly $ infp
                (ps', restok) <- aaf ps
                case mp' of
                  Nothing -> return (ps', restok)
                  Just (e,pp) -> do liftIO $ putStrLn e
                                    p' <- liftIO $ makePatchLazy r pp
                                    return ((infp, p'):ps', False)

    data RepositoryConsistency p =
        RepositoryConsistent
      | BrokenPristine (Tree IO)
      | BrokenPatches (Tree IO) (PatchSet p)

    check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO ()
    check_uniqueness putVerbose putInfo repository =
        do putVerbose $ text "Checking that patch names are unique..."
           r <- read_repo repository
           case has_duplicate $ mapRL info $ concatRL r of
             Nothing -> return ()
             Just pinf -> do putInfo $ text "Error! Duplicate patch name:"
                             putInfo $ human_friendly pinf
                             fail "Duplicate patches found."

    has_duplicate :: Ord a => [a] -> Maybe a
    has_duplicate li = hd $ sort li
        where hd [_] = Nothing
              hd [] = Nothing
              hd (x1:x2:xs) | x1 == x2 = Just x1
                            | otherwise = hd (x2:xs)
    replayRepository' :: (RepoPatch p) => Repository p -> [DarcsFlag] -> IO (RepositoryConsistency p)
    replayRepository' repo opts = do
      let putVerbose s = when (Verbose `elem` opts) $ putDocLn s
          putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s
      check_uniqueness putVerbose putInfo repo
      createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed"
      putVerbose $ text "Reading recorded state..."
      pris <- readRecorded repo `catch` \_ -> return emptyTree
      putVerbose $ text "Applying patches..."
      patches <- read_repo repo
      debugMessage "Fixing any broken patches..."
      let psin = reverseRL $ concatRL patches
          repair = applyAndFix repo psin
      ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree "_darcs/pristine.hashed"
      debugMessage "Done fixing broken patches..."
      let newpatches = reverseFL ps :<: NilRL

      debugMessage "Checking pristine against slurpy"
      ftf <- filetypeFunction
      is_same <- do diff <- treeDiff ftf pris newpris
                    return $ case diff of
                               NilFL -> True
                               _ -> False
                  `catchall` return False
      -- TODO is the latter condition needed? Does a broken patch imply pristine
      -- difference? Why, or why not?
      return (if is_same && patches_ok
         then RepositoryConsistent
         else if patches_ok
                then BrokenPristine newpris
                else BrokenPatches newpris newpatches)

    cleanupRepositoryReplay :: Repository p -> IO ()
    cleanupRepositoryReplay r = do
      let c = extractCache r
      rf_or_e <- identifyRepoFormat "."
      rf <- case rf_or_e of Left e -> fail e
                            Right x -> return x
      unless (formatHas HashedInventory rf) $
             rm_recursive $ darcsdir ++ "/pristine.hashed"
      when (formatHas HashedInventory rf) $ do
           current <- readHashedPristineRoot r
           clean_hashdir c HashedPristineDir $ catMaybes [current]

    replayRepository :: (RepoPatch p) => Repository p -> [DarcsFlag] -> (RepositoryConsistency p -> IO a) -> IO a
    replayRepository r opt f = run `finally` cleanupRepositoryReplay r
        where run = do
                st <- replayRepository' r opt
                f st

    checkIndex :: (RepoPatch p) => Repository p -> Bool -> IO Bool
    checkIndex repo quiet = do
      index <- updateIndex =<< readIndex repo
      pristine <- expand =<< readRecordedAndPending repo
      working <- expand =<< restrict pristine <$> readPlainTree "."
      working_hashed <- darcsUpdateHashes working
      let index_paths = [ p | (p, _) <- list index ]
          working_paths = [ p | (p, _) <- list working ]
          index_extra = index_paths \\ working_paths
          working_extra = working_paths \\ index_paths
          gethashes p (Just i1) (Just i2) = (p, itemHash i1, itemHash i2)
          gethashes p (Just i1) Nothing   = (p, itemHash i1, NoHash)
          gethashes p   Nothing (Just i2) = (p,      NoHash, itemHash i2)
          gethashes p   Nothing Nothing   = error $ "Bad case at " ++ show p
          mismatches = [ miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2 ]

          format paths = unlines $ (map $ (("  " ++) . anchorPath "")) paths
          mismatches_disp = unlines [ anchorPath "" p ++
                                        "\n    index: " ++ BS.unpack (encodeBase16 h1) ++
                                        "\n  working: " ++ BS.unpack (encodeBase16 h2)
                                      | (p, h1, h2) <- mismatches ]
      unless (quiet || null index_extra) $
             putStrLn $ "Extra items in index!\n" ++ format index_extra
      unless (quiet || null working_extra) $
             putStrLn $ "Missing items in index!\n" ++ format working_extra
      unless (quiet || null mismatches) $
             putStrLn $ "Hash mismatch(es)!\n" ++ mismatches_disp
      return $ null index_extra && null working_extra && null mismatches