{-# LANGUAGE FlexibleInstances #-}
import Prelude hiding ( read, filter, writeFile, readFile )

-- darcs stuff
import ByteStringUtils( is_funky )
import Darcs.Repository ( Repository(..), withRepository, withRepoLock, ($-),
                          tentativelyAddPatch, finalizeRepositoryChanges,
                          read_repo, identifyRepositoryFor )
import Darcs.Repository.Motd( show_motd )
import Darcs.Repository.Internal ( read_pending, setTentativePending
                                 , announce_merge_conflicts
                                 , check_unrecorded_conflicts )
import Darcs.Repository.HashedRepo ( add_to_tentative_inventory )
import Darcs.Repository.InternalTypes ( extractCache )
import Darcs.Resolution ( standard_resolution )
import Darcs.External ( backupByCopying )
import Darcs.IO ( runTolerantly, runSilently )
import Darcs.ProgressPatches (progressFL)
import Darcs.Patch.Depends ( get_common_and_uncommon )
import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply
                   , sort_coalesceFL, summarize, namepatch, fromPrims
                   , effect, list_touched_files, joinPatches, merge
                   , anonymous, patchcontents )
import Darcs.Ordered ( FL(..), (+>+), (:>)(..), nullFL,
                       concatRL, reverseRL, unsafeUnRL, (:\/:)(..),
                       mapFL_FL, (:/\:)(..) )
import Darcs.PrintPatch ( printPatch )
import Darcs.RepoPath( ioAbsolute )
import Darcs.Repository.Prefs ( filetype_function, FileType(..) )
import Darcs.Patch.TouchesFiles ( choose_touching )
import Darcs.SelectChanges ( with_selected_changes_to_files',
                             with_selected_changes  )
import Darcs.Commands.Record( get_date, get_log )
import Darcs.CommandsAux ( check_paths )
import Darcs.Arguments( get_author, fixUrl )
import Darcs.Lock( world_readable_temp )
import Darcs.Utils( clarify_errors )
import Darcs.IO
import Darcs.Hopefully ( n2pia, PatchInfoAnd, hopefully )
import Darcs.Sealed ( Sealed(Sealed), seal )
import Darcs.Patch.FileName ( fn2fp )
import Darcs.Flags ( Compression(..), DarcsFlag( FixFilePath ) )
import Printer ( putDocLn )

import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
import Control.Monad.State.Strict
import System( getArgs )
import System.Exit( exitWith, ExitCode(..) )
import System.Directory( removeFile, getCurrentDirectory )
import Data.Maybe
import Data.List( (\\) )

import Storage.Hashed
import Storage.Hashed.Tree
import Storage.Hashed.Index
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Monad
import Storage.Hashed.Diff
import Storage.Hashed

---- FIXME this is from Storage.Hashed.Utils which is hidden ...
darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n
    where n = (show s)

darcsFormatHash (Hash (Just s, h)) =
    BS.concat [ darcsFormatSize s
              , BS.singleton '-'
              , h ]
darcsFormatHash h =
    error $ "Unsuitable hash for darcs-compatible hashing " ++ show h
-- end FIXME

floatFn = floatPath . fn2fp

instance ReadableDirectory (StateT TreeState IO) where
    mDoesDirectoryExist d = gets (\x -> isJust $ findTree (tree x) (floatFn d))
    mDoesFileExist f = gets (\x -> isJust $ findFile (tree x) (floatFn f))
    mInCurrentDirectory d action = do -- TODO bracket?
      wd <- gets cwd
      modify (\x -> x { cwd = floatFn d })
      x <- action
      modify (\x -> x { cwd = wd })
      return x
    mGetDirectoryContents = error "get dir contents"
    mReadFilePS p = do x <- readFile (floatFn p)
                       return $ BS.concat (BL.toChunks x)

instance WriteableDirectory (StateT TreeState IO) where
    mWithCurrentDirectory = mInCurrentDirectory
    mSetFileExecutable _ _ = return ()
    mWriteFilePS p ps = writeFile (floatFn p) (BL.fromChunks [ps])
    mCreateDirectory p = createDirectory (floatFn p)
    mRename from to = rename (floatFn from) (floatFn to)
    mRemoveDirectory = unlink . floatFn
    mRemoveFile = unlink . floatFn

treeDiff :: (FilePath -> FileType) -> Tree -> Tree -> IO (FL Prim)
treeDiff ft t1 t2 = do
  (from, to) <- diffTrees t1 t2
  diffs <- sequence $ zipFiles diff_files from to
  return $ foldr (+>+) NilFL diffs
    where diff_files :: AnchoredPath -> Blob -> Blob -> IO (FL Prim)
          diff_files p a' b' =
              do a <- read a'
                 b <- read b'
                 let path = anchorPath "." p
                 case ft path of
                   TextFile | no_bin a && no_bin b ->
                                return $ text_diff path a b
                   _ -> return $ if a /= b
                                    then binary path (strict a) (strict b) :>: NilFL
                                    else NilFL
          text_diff p a b = canonize (hunk p 1 lines_a
                                               lines_b)
              -- FIXME this is all screwed up...
              where lines_b | BL.null b && BL.last a == '\n' = [BS.empty]
                            | BL.null b = []
                            | otherwise = lines b
                    lines_a | BL.null a && BL.last b == '\n' = [BS.empty]
                            | BL.null a = []
                            | otherwise = lines a
          no_bin = not . is_funky . strict . BL.take 4096
          lines = map strict . BL.split '\n'
          strict = BS.concat . BL.toChunks

readRecordedAndPending :: (RepoPatch p) => Repository p -> IO Tree
readRecordedAndPending repo = do
  pristine <- readDarcsPristine "."
  Sealed pend <- read_pending repo
  (_, t) <- virtualTreeIO (apply [] pend) pristine
  return t

unrecordedChanges :: (RepoPatch p) => Repository p ->
                     (Tree -> Tree) -> IO (FL Prim)
unrecordedChanges repo restrict = do
  pristine <- readDarcsPristine "."
  working <- (restrict `fmap` readIndex) >>= unfold
  Sealed pending_patches <- read_pending repo
  (_, pending') <- virtualTreeIO (apply [] pending_patches) pristine
  let pending = restrict pending'
  ft <- filetype_function
  diff <- treeDiff ft pending working
  return $ sort_coalesceFL (pending_patches +>+ diff)

-- XXX both application actions below could avoid unfolding if TreeIO would be
-- smart enough to unfold-as-needed...
applyToTentativePristine _ patches =
    do pristine <- readDarcsPristine "." >>= unfold
       (_, tree) <- hashedTreeIO (apply [] patches)
                    pristine "_darcs/pristine.hashed"
       BS.writeFile "_darcs/tentative_pristine" $
         BS.concat [BS.pack "pristine:"
                   , darcsFormatHash (fromJust $ treeHash tree)]

applyToWorking :: (RepoPatch p) => Repository p -> Sealed (FL Prim) -> IO Tree
applyToWorking _ (Sealed patches) =
    do pristine <- readDarcsPristine "." >>= unfold
       working <- readIndex
       snd `fmap` plainTreeIO (apply [] patches) working "."

tentativelyMerge r cmd usi themi =
  do let us = mapFL_FL hopefully usi
         them = mapFL_FL hopefully themi
         (_ :/\: pc) = merge (progressFL "Merging them" them
                                             :\/: progressFL "Merging us" us)
     pend <- unrecordedChanges r id
     anonpend <- anonymous (fromPrims pend)
     let pend' :/\: pw = merge (pc :\/: anonpend :>: NilFL)
         pwprim = joinPatches $ mapFL_FL patchcontents pw
         Sealed standard_resolved_pw = standard_resolution pwprim
     mapM_ backupByCopying $ list_touched_files standard_resolved_pw
     have_conflicts <- announce_merge_conflicts cmd [] standard_resolved_pw
     have_unrecorded_conflicts <- check_unrecorded_conflicts [] pc
     let Sealed pw_resolution = if have_conflicts || have_unrecorded_conflicts
                                   then seal NilFL
                                   else seal standard_resolved_pw
     let doChanges :: FL (PatchInfoAnd p) -> IO ()
         doChanges NilFL = applyps r themi
         doChanges _     = applyps r (mapFL_FL n2pia pc)
     doChanges usi
     setTentativePending r (effect pend' +>+ pw_resolution)
     return $ seal (effect pwprim +>+ pw_resolution)
  where mapAdd :: RepoPatch p => Repository p -> FL (PatchInfoAnd p) -> [IO ()]
        mapAdd _ NilFL = []
        mapAdd r' (a:>:as) =
               (add_to_tentative_inventory (extractCache r') NoCompression a >> return ()) : mapAdd r' as
        applyps :: (RepoPatch p) => Repository p -> FL (PatchInfoAnd p) -> IO ()
        applyps repo ps = do sequence_ $ mapAdd repo ps
                             applyToTentativePristine repo ps

filter_paths files =
    \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files

restrict_paths files = if null files
                          then id
                          else filter $ filter_paths files

cmd_wh summary repo files = do
  Sealed diff <- choose_touching (map (anchorPath "") files)
                   `fmap` unrecordedChanges repo (restrict_paths files)
  let display | summary = putDocLn . summarize
              | otherwise = printPatch
  display diff

die s = do putStrLn s
           exitWith $ ExitFailure 1

cmd_diff repo files = do
  pristine <- restrict_paths files `fmap` readRecordedAndPending repo
  working <- restrict_paths files `fmap` readIndex
  BL.unpack `fmap` unidiff pristine working >>= putStr

cmd_opt repo files = do
  pristine <- readRecordedAndPending repo
  updateIndexFrom pristine >>= unfold
  return ()

cmd_rec _ files =
    withRepoLock [] $- \repo -> do
      date <- get_date []
      my_author <- get_author []
      let make_log = world_readable_temp "gorsvet-record"
          paths = map (anchorPath "") files
          rec_bits (chs:>_) =
              if nullFL chs
                 then putStrLn "Nothing to record..."
                 else do_rec_bits chs
          do_rec_bits chs = do
              (name, my_log, logf) <- get_log [] Nothing make_log chs
              patch <- namepatch date name my_author my_log $
                       fromPrims chs
              tentativelyAddPatch repo [] $ n2pia patch
              finalizeRepositoryChanges repo
                 `clarify_errors` "Failed to record patch."
              when (isJust logf) $ removeFile (fromJust logf)
      diff <- unrecordedChanges repo (restrict_paths files)
      with_selected_changes_to_files' "rec" [] paths diff rec_bits

cmd_pull :: (RepoPatch p) => Repository p -> [String] -> IO ()
cmd_pull local [remote'] = withRepoLock [] $- \repo -> do
    do here <- getCurrentDirectory
       here_abs <- ioAbsolute here
       remote <- fixUrl [FixFilePath here_abs here_abs] remote' -- WTF?
       when (here == remote) $
            die "Can't pull from current repository..."
       them <- identifyRepositoryFor local remote >>= read_repo
       us <- read_repo local
       show_motd [] remote
       (common, ours :\/: theirs) <- return $ get_common_and_uncommon (us, them)
       let patches = reverseRL $ concatRL theirs
           pull_bits (p:>_) = if nullFL p then putStrLn "Nothing to pull..."
                                          else do_pull_bits p
           do_pull_bits patches = do
             check_paths [] patches
             pw <- tentativelyMerge local "pull"
                              (reverseRL $ head $ unsafeUnRL ours)
                              patches
             finalizeRepositoryChanges local
             applyToWorking local pw
             return ()
       with_selected_changes "pull" [] patches pull_bits
cmd_pull _ _ = die "Only know how to pull from a single repo."

main = do
  withRepository [] $- \r -> do
  (command:args) <- getArgs
  case command of
    "diff" -> cmd_diff r (map floatPath args)
    "wh" -> cmd_wh ("-s" `elem` args) r $ (map floatPath $ args \\ ["-s"])
    "rec" -> cmd_rec r (map floatPath args)
    "pull" -> cmd_pull r args
    "optimize" -> cmd_opt r (map floatPath args)
    x -> do die $ "Unknown command " ++ x ++ ", try diff, wh, rec or optimize."