{-# LANGUAGE GADTs, OverloadedStrings #-}
module Export( fastExport ) where

import Prelude hiding ( readFile )

import Marks

import Data.Maybe ( catMaybes, fromJust )
import Data.DateTime ( formatDateTime, fromClockTime )
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Lazy.UTF8 as BLU
import Data.IORef ( newIORef, modifyIORef, readIORef )

import Control.Monad ( when, forM_, unless )
import Control.Monad.Trans ( liftIO )
import Control.Monad.State.Strict( gets )
import Control.Exception( finally )

import System.Time ( toClockTime )
import System.IO ( hPutStrLn, openFile, IOMode(..), stderr )

import Darcs.Hopefully ( PatchInfoAnd, info )
import Darcs.Repository ( Repository, ($-), readRepo, withRepository )
import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )
import Darcs.Repository.HashedRepo ( readHashedPristineRoot )
import Darcs.Repository.HashedIO ( cleanHashdir )
import Darcs.Repository.InternalTypes ( extractCache )
import Darcs.Patch ( effect, listTouchedFiles, apply, RepoPatch )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, nullFL )
import Darcs.Patch.Info ( isTag, PatchInfo, piAuthor, piName, piLog, piDate )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2FL )
import Darcs.Utils ( withCurrentDirectory )
import Utils

import Storage.Hashed.Monad hiding ( createDirectory, exists )
import Storage.Hashed.Darcs
import Storage.Hashed.Tree( emptyTree, listImmediate, findTree )
import Storage.Hashed.AnchoredPath( anchorPath, appendPath, floatPath
                                  , AnchoredPath  )

inOrderTag tags p = isTag (info p) && info p `elem` tags && nullFL (effect p)
next tags n p = if inOrderTag tags p then n else n + 1

tagName = map (cleanup " .") . drop 4 . patchName -- FIXME many more chars are probably illegal
  where cleanup bad x | x `elem` bad = '_'
                      | otherwise = x

patchName = piName . info
patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime . piDate . info

patchAuthor p = case span (/='<') author of
  (n, "") -> case span (/='@') $ author of
                 -- john@home -> john <john@home>
                 (n, "") -> n ++ " <unknown>"
                 (name, _) -> name ++ " <" ++ author ++ ">"
  (n, rest) -> case span (/='>') $ tail rest of
    (email, _) -> n ++ "<" ++ email ++ ">"
 where author = piAuthor (info p)

patchMessage p = BL.concat [ BLU.fromString (piName $ info p)
                           , case (unlines . piLog $ info p) of
                                "" -> BL.empty
                                plog -> BLU.fromString ("\n" ++ plog)]

dumpBits = liftIO . BL.putStrLn . BL.intercalate "\n"

dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles files = forM_ files $ \file -> do
  isfile <- fileExists file
  isdir <- directoryExists file
  when isfile $ do bits <- readFile file
                   dumpBits [ BLU.fromString $ "M 100644 inline " ++ anchorPath "" file
                            , BLU.fromString $ "data " ++ show (BL.length bits)
                            , bits ]
  when isdir $ do tt <- gets tree -- ick
                  let subs = [ file `appendPath` n | (n, _) <-
                                  listImmediate $ fromJust $ findTree tt file ]
                  dumpFiles subs
  when (not isfile && not isdir) $ liftIO $ putStrLn $ "D " ++ anchorPath "" file

dumpPatch mark p n =
  do dumpBits [ BLC.pack $ "progress " ++ show n ++ ": " ++ patchName p
              , "commit refs/heads/master" ]
     mark p n
     dumpBits [ BLU.fromString $ "committer " ++ patchAuthor p ++ " " ++ patchDate p
              , BLU.fromString $ "data " ++ show (BL.length $ patchMessage p)
              , patchMessage p ]
     when (n > 1) $ dumpBits [ BLU.fromString $ "from :" ++ show (n - 1) ]

dumpTag p n =
  dumpBits [ BLU.fromString $ "progress TAG " ++ tagName p
           , BLU.fromString $ "tag " ++ tagName p -- FIXME is this valid?
           , BLU.fromString $ "from :" ++ show (n - 1) -- the previous mark
           , BLU.fromString $ "tagger " ++ patchAuthor p ++ " " ++ patchDate p
           , BLU.fromString $ "data " ++ show (BL.length (patchMessage p) - 4)
           , BL.drop 4 $ patchMessage p ]

dumpPatches :: (RepoPatch p) => [PatchInfo] -> (PatchInfoAnd p -> Int -> TreeIO ())
               -> Int -> FL (PatchInfoAnd p) -> TreeIO ()
dumpPatches _ _ _ NilFL = liftIO $ putStrLn "progress (patches converted)"
dumpPatches tags mark n (p:>:ps) = do
  apply [] p
  if inOrderTag tags p && n > 0
     then dumpTag p n
     else do dumpPatch mark p n
             dumpFiles $ map floatPath $ listTouchedFiles p
  dumpPatches tags mark (next tags n p) ps

fastExport :: String -> Marks -> IO Marks
fastExport repodir marks =
  withCurrentDirectory repodir $ withRepository [] $- \repo -> fastExport' repo marks

fastExport' :: (RepoPatch p) => Repository p -> Marks -> IO Marks
fastExport' repo marks = do
  putStrLn "progress (reading repository)"
  patchset <- readRepo repo
  marksref <- newIORef marks
  let total = show (lengthFL patches)
      patches = newset2FL patchset
      tags = optimizedTags patchset
      mark p n = liftIO $ do putStrLn $ "mark :" ++ show n
                             modifyIORef marksref $ \m -> addMark m n (patchHash p)
      checkOne n p = do apply [] p
                        unless (inOrderTag tags p ||
                                (getMark marks n == Just (patchHash p))) $
                          die $ "FATAL: Marks do not correspond: expected " ++
                                (show $ getMark marks n) ++ ", got " ++ (BSC.unpack $ patchHash p)
      check _ NilFL = return (1, NilFL)
      check n allps@(p:>:ps)
        | n <= lastMark marks = do checkOne n p >> check (next tags n p) ps
        | n > lastMark marks = return (n, allps)
        | lastMark marks == 0 = return (1, allps)

  ((n, patches'), tree) <- hashedTreeIO (check 1 patches) emptyTree "_darcs/pristine.hashed"
  hashedTreeIO (dumpPatches tags mark n patches') tree "_darcs/pristine.hashed"
  readIORef marksref
 `finally` do
  putStrLn "progress (cleaning up)"
  current <- readHashedPristineRoot repo
  cleanHashdir (extractCache repo) HashedPristineDir $ catMaybes [current]
  putStrLn "progress done"

optimizedTags :: PatchSet p -> [PatchInfo]
optimizedTags (PatchSet _ ts) = go ts
  where go :: RL(Tagged t1) -> [PatchInfo]
        go (Tagged t _ _ :<: ts') = info t : go ts'
        go NilRL = []